Split LLVM dependent backend from core code.

No more pretty little one filer.  Oh well.


git-svn-id: http://svn.drobilla.net/resp/tuplr@51 ad02d1e2-f140-0410-9f75-f8b11f17cedd

1 files changed, 464 insertions, 0 deletions

diff --git a/tuplr.hpp b/tuplr.hpp
new file mode 100644
index 0000000..1d3eb0d
--- /dev/null
+++ b/tuplr.hpp
@@ -0,0 +1,464 @@
+/* Tuplr: A programming language
+ * Copyright (C) 2008-2009 David Robillard <dave@drobilla.net>
+ *
+ * Tuplr is free software: you can redistribute it and/or modify it under
+ * the terms of the GNU Affero General Public License as published by the
+ * Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Tuplr is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General
+ * Public License for more details.
+ *
+ * You should have received a copy of the GNU Affero General Public License
+ * along with Tuplr.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef TUPLR_HPP
+#define TUPLR_HPP
+
+#include <stdarg.h>
+#include <iostream>
+#include <list>
+#include <map>
+#include <string>
+#include <vector>
+#include <boost/format.hpp>
+#include "tuplr_llvm.hpp"
+
+#define FOREACH(IT, i, c) for (IT i = (c).begin(); i != (c).end(); ++i)
+
+using namespace std;
+using boost::format;
+
+extern std::ostream& err;
+extern std::ostream& out;
+
+struct Cursor {
+	Cursor(const string& n="", unsigned l=1, unsigned c=0) : name(n), line(l), col(c) {}
+	string str() const { return (format("%1%:%2%:%3%") % name % line % col).str(); }
+	string   name;
+	unsigned line;
+	unsigned col;
+};
+
+struct Error {
+	Error(const string& m, Cursor c=Cursor()) : msg(m), loc(c) {}
+	const string what() const throw() { return loc.str() + ": error: " + msg; }
+	string msg;
+	Cursor loc;
+};
+
+template<typename Atom>
+struct Exp { // ::= Atom | (Exp*)
+	Exp(Cursor c)                : type(LIST), loc(c)          {}
+	Exp(Cursor c, const Atom& a) : type(ATOM), loc(c), atom(a) {}
+	typedef std::vector< Exp<Atom> > List;
+	enum { ATOM, LIST } type;
+	Cursor loc;
+	Atom   atom;
+	List   list;
+};
+
+
+/***************************************************************************
+ * S-Expression Lexer :: text -> S-Expressions (SExp)                      *
+ ***************************************************************************/
+
+typedef Exp<string> SExp; ///< Textual S-Expression
+
+SExp readExpression(Cursor& cur, std::istream& in);
+
+
+/***************************************************************************
+ * Abstract Syntax Tree                                                    *
+ ***************************************************************************/
+
+struct TEnv;  ///< Type-Time Environment
+struct CEnv;  ///< Compile-Time Environment
+
+/// Base class for all AST nodes
+struct AST {
+	virtual ~AST() {}
+	virtual string  str()                    const = 0;
+	virtual bool    operator==(const AST& o) const = 0;
+	virtual bool    contains(AST* child)     const { return false; }
+	virtual void    constrain(TEnv& tenv)    const {}
+	virtual void    lift(CEnv& cenv)               {}
+	virtual CValue* compile(CEnv& cenv)            = 0;
+};
+
+/// Literal value
+template<typename VT>
+struct ASTLiteral : public AST {
+	ASTLiteral(VT v) : val(v) {}
+	bool operator==(const AST& rhs) const {
+		const ASTLiteral<VT>* r = dynamic_cast<const ASTLiteral<VT>*>(&rhs);
+		return (r && (val == r->val));
+	}
+	string  str() const { return (format("%1%") % val).str(); }
+	void    constrain(TEnv& tenv) const;
+	CValue* compile(CEnv& cenv);
+	const VT val;
+};
+
+/// Symbol, e.g. "a"
+struct ASTSymbol : public AST {
+	ASTSymbol(const string& s, Cursor c=Cursor()) : loc(c), cppstr(s) {}
+	bool    operator==(const AST& rhs) const { return this == &rhs; }
+	string  str()                      const { return cppstr; }
+	CValue* compile(CEnv& cenv);
+private:
+	Cursor       loc;
+	const string cppstr;
+};
+
+/// Tuple (heterogeneous sequence of fixed length), e.g. "(a b c)"
+struct ASTTuple : public AST, public vector<AST*> {
+	ASTTuple(const vector<AST*>& t=vector<AST*>()) : vector<AST*>(t) {}
+	ASTTuple(size_t size) : vector<AST*>(size) {}
+	ASTTuple(AST* ast, ...) {
+		push_back(ast);
+		va_list args;
+		va_start(args, ast);
+		for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*))
+			push_back(a);
+		va_end(args);
+	}
+	string str() const {
+		string ret = "(";
+		for (size_t i = 0; i != size(); ++i)
+			ret += at(i)->str() + ((i != size() - 1) ? " " : "");
+		return ret + ")";
+	}
+	bool operator==(const AST& rhs) const {
+		const ASTTuple* rt = dynamic_cast<const ASTTuple*>(&rhs);
+		if (!rt) return false;
+		if (rt->size() != size()) return false;
+		const_iterator l = begin();
+		FOREACH(const_iterator, r, *rt) {
+			AST* mine = *l++;
+			AST* other = *r;
+			if (!(*mine == *other))
+				return false;
+		}
+		return true;
+	}
+	void lift(CEnv& cenv) {
+		FOREACH(iterator, t, *this)
+			(*t)->lift(cenv);
+	}
+	bool    contains(AST* child) const;
+	void    constrain(TEnv& tenv) const;
+	CValue* compile(CEnv& cenv) { throw Error("tuple compiled"); }
+};
+
+/// Type Expression, e.g. "Int", "(Fn (Int Int) Float)"
+struct AType : public ASTTuple {
+	AType(const ASTTuple& t) : ASTTuple(t), kind(EXPR), ctype(0) {}
+	AType(unsigned i) : kind(VAR), id(i), ctype(0) {}
+	AType(ASTSymbol* n, const CType* t) : kind(PRIM), ctype(t) { push_back(n); }
+	string str() const {
+		switch (kind) {
+		case VAR:  return (format("?%1%") % id).str();
+		case PRIM: return at(0)->str();
+		case EXPR: return ASTTuple::str();
+		}
+		return ""; // never reached
+	}
+	void    constrain(TEnv& tenv) const {}
+	CValue* compile(CEnv& cenv) { return NULL; }
+	bool    var() const { return kind == VAR; }
+	bool concrete() const {
+		switch (kind) {
+		case VAR:  return false;
+		case PRIM: return true;
+		case EXPR:
+			FOREACH(const_iterator, t, *this) {
+				AType* kid = dynamic_cast<AType*>(*t);
+				if (kid && !kid->concrete())
+					return false;
+			}
+		}
+		return true;
+	}
+	bool operator==(const AST& rhs) const {
+		const AType* rt = dynamic_cast<const AType*>(&rhs);
+		if (!rt)
+			return false;
+		else if (kind != rt->kind)
+			return false;
+		else
+			switch (kind) {
+			case VAR:  return id == rt->id;
+			case PRIM: return at(0)->str() == rt->at(0)->str();
+			case EXPR: return ASTTuple::operator==(rhs);
+			}
+		return false; // never reached
+	}
+	const CType* type();
+	enum Kind { VAR, PRIM, EXPR };
+	Kind     kind;
+	unsigned id;
+private:
+	const CType* ctype;
+};
+
+/// Lifted system functions (of various types) for a single Tuplr function
+struct Funcs : public list< pair<AType*, CFunction*> > {
+	CFunction* find(AType* type) const {
+		for (const_iterator f = begin(); f != end(); ++f)
+			if (*f->first == *type)
+				return f->second;
+		return NULL;
+	}
+	void insert(AType* type, CFunction* func) {
+		push_back(make_pair(type, func));
+	}
+};
+
+/// Closure (first-class function with captured lexical bindings)
+struct ASTClosure : public ASTTuple {
+	ASTClosure(ASTTuple* p, AST* b, const string& n="")
+		: ASTTuple(0, p, b, NULL), name(n) {}
+	bool      operator==(const AST& rhs) const { return this == &rhs; }
+	string    str() const { return (format("%1%") % this).str(); }
+	void      constrain(TEnv& tenv) const;
+	void      lift(CEnv& cenv);
+	CValue*   compile(CEnv& cenv);
+	ASTTuple* prot() const { return dynamic_cast<ASTTuple*>(at(1)); }
+private:
+	Funcs  funcs;
+	string name;
+};
+
+/// Function call/application, e.g. "(func arg1 arg2)"
+struct ASTCall : public ASTTuple {
+	ASTCall(const SExp& e, const ASTTuple& t) : ASTTuple(t), exp(e) {}
+	void    constrain(TEnv& tenv) const;
+	void    lift(CEnv& cenv);
+	CValue* compile(CEnv& cenv);
+	const SExp& exp;
+};
+
+/// Definition special form, e.g. "(def x 2)"
+struct ASTDefinition : public ASTCall {
+	ASTDefinition(const SExp& e, const ASTTuple& t, CArg ca=CArg()) : ASTCall(e, t) {}
+	void    constrain(TEnv& tenv) const;
+	void    lift(CEnv& cenv);
+	CValue* compile(CEnv& cenv);
+};
+
+/// Conditional special form, e.g. "(if cond thenexp elseexp)"
+struct ASTIf : public ASTCall {
+	ASTIf(const SExp& e, const ASTTuple& t, CArg ca=CArg()) : ASTCall(e, t) {}
+	void    constrain(TEnv& tenv) const;
+	CValue* compile(CEnv& cenv);
+};
+
+/// Primitive (builtin arithmetic function), e.g. "(+ 2 3)"
+struct ASTPrimitive : public ASTCall {
+	ASTPrimitive(const SExp& e, const ASTTuple& t, CArg ca=CArg()) : ASTCall(e, t), arg(ca) {}
+	void    constrain(TEnv& tenv) const;
+	CValue* compile(CEnv& cenv);
+	CArg arg;
+};
+
+/// Cons special form, e.g. "(cons 1 2)"
+struct ASTConsCall : public ASTCall {
+	ASTConsCall(const SExp& e, const ASTTuple& t, CArg ca=CArg()) : ASTCall(e, t) {}
+	AType*  functionType(CEnv& cenv);
+	void    constrain(TEnv& tenv) const;
+	void    lift(CEnv& cenv);
+	CValue* compile(CEnv& cenv);
+	static Funcs funcs;
+};
+
+/// Car special form, e.g. "(car p)"
+struct ASTCarCall : public ASTCall {
+	ASTCarCall(const SExp& e, const ASTTuple& t, CArg ca=CArg()) : ASTCall(e, t) {}
+	void    constrain(TEnv& tenv) const;
+	CValue* compile(CEnv& cenv);
+};
+
+/// Cdr special form, e.g. "(cdr p)"
+struct ASTCdrCall : public ASTCall {
+	ASTCdrCall(const SExp& e, const ASTTuple& t, CArg ca=CArg()) : ASTCall(e, t) {}
+	void    constrain(TEnv& tenv) const;
+	CValue* compile(CEnv& cenv);
+};
+
+
+/***************************************************************************
+ * Parser - S-Expressions (SExp) -> AST Nodes (AST)                        *
+ ***************************************************************************/
+
+// Parse Time Environment (symbol table)
+struct PEnv : private map<const string, ASTSymbol*> {
+	typedef AST* (*PF)(PEnv&, const SExp&, CArg); // Parse Function
+	struct Parser { Parser(PF f, CArg a=CArg()) : func(f), arg(a) {} PF func; CArg arg; };
+	map<string, Parser> parsers;
+	void reg(const string& s, const Parser& p) {
+		parsers.insert(make_pair(sym(s)->str(), p));
+	}
+	const Parser* parser(const string& s) const {
+		map<string, Parser>::const_iterator i = parsers.find(s);
+		return (i != parsers.end()) ? &i->second : NULL;
+	}
+	ASTSymbol* sym(const string& s, Cursor c=Cursor()) {
+		const const_iterator i = find(s);
+		return ((i != end())
+			? i->second
+			: insert(make_pair(s, new ASTSymbol(s, c))).first->second);
+	}
+};
+
+/// The fundamental parser method
+static AST* parseExpression(PEnv& penv, const SExp& exp);
+
+static ASTTuple
+pmap(PEnv& penv, const SExp::List& l)
+{
+	ASTTuple ret(l.size());
+	size_t n = 0;
+	FOREACH(SExp::List::const_iterator, i, l)
+		ret[n++] = parseExpression(penv, *i);
+	return ret;
+}
+
+static AST*
+parseExpression(PEnv& penv, const SExp& exp)
+{
+	if (exp.type == SExp::LIST) {
+		if (exp.list.empty()) throw Error("call to empty list", exp.loc);
+		if (exp.list.front().type == SExp::ATOM) {
+			const PEnv::Parser* handler = penv.parser(exp.list.front().atom);
+			if (handler) // Dispatch to parse function
+				return handler->func(penv, exp, handler->arg);
+		}
+		return new ASTCall(exp, pmap(penv, exp.list)); // Parse as regular call
+	} else if (isdigit(exp.atom[0])) {
+		if (exp.atom.find('.') == string::npos)
+			return new ASTLiteral<int32_t>(strtol(exp.atom.c_str(), NULL, 10));
+		else
+			return new ASTLiteral<float>(strtod(exp.atom.c_str(), NULL));
+	} else if (exp.atom == "true") {
+		return new ASTLiteral<bool>(true);
+	} else if (exp.atom == "false") {
+		return new ASTLiteral<bool>(false);
+	}
+	return penv.sym(exp.atom, exp.loc);
+}
+
+template<typename C>
+inline AST*
+parseAST(PEnv& penv, const SExp& exp, CArg arg=CArg())
+{
+	return new C(exp, pmap(penv, exp.list), arg);
+}
+
+inline AST*
+parseFn(PEnv& penv, const SExp& exp, CArg arg)
+{
+	SExp::List::const_iterator a = exp.list.begin(); ++a;
+	return new ASTClosure(
+			new ASTTuple(pmap(penv, (*a++).list)),
+			parseExpression(penv, *a++));
+}
+
+
+/***************************************************************************
+ * Generic Lexical Environment                                             *
+ ***************************************************************************/
+
+template<typename K, typename V>
+struct Env : public list< map<K,V> > {
+	typedef map<K,V> Frame;
+	Env() : list<Frame>(1) {}
+	void push() { list<Frame>::push_front(Frame()); }
+	void pop()  { assert(!this->empty()); list<Frame>::pop_front(); }
+	const V& def(const K& k, const V& v) {
+		typename Frame::iterator existing = this->front().find(k);
+		if (existing != this->front().end() && existing->second != v)
+			throw Error("redefinition");
+		return (this->front()[k] = v);
+	}
+	V* ref(const K& name) {
+		typename Frame::iterator s;
+		for (typename Env::iterator i = this->begin(); i != this->end(); ++i)
+			if ((s = i ->find(name)) != i->end())
+				return &s->second;
+		return 0;
+	}
+};
+
+
+/***************************************************************************
+ * Typing                                                                  *
+ ***************************************************************************/
+
+struct TSubst : public map<AType*, AType*> {
+	TSubst(AType* s=0, AType* t=0) { if (s && t) insert(make_pair(s, t)); }
+};
+
+/// Type-Time Environment
+struct TEnv : public Env<const AST*,AType*> {
+	TEnv(PEnv& p) : penv(p), varID(1) {}
+	typedef list< pair<AType*, AType*> > Constraints;
+	AType* var() { return new AType(varID++); }
+	AType* type(const AST* ast) {
+		AType** t = ref(ast);
+		return t ? *t : def(ast, var());
+	}
+	AType* named(const string& name) {
+		return *ref(penv.sym(name));
+	}
+	void constrain(const AST* o, AType* t) {
+		assert(!dynamic_cast<const AType*>(o));
+		constraints.push_back(make_pair(type(o), t));
+	}
+	void          solve() { apply(unify(constraints)); }
+	void          apply(const TSubst& substs);
+	static TSubst unify(const Constraints& c);
+	PEnv&       penv;
+	Constraints constraints;
+	unsigned    varID;
+};
+
+
+/***************************************************************************
+ * Code Generation                                                         *
+ ***************************************************************************/
+
+struct CEnvPimpl;
+
+/// Compile-Time Environment
+struct CEnv {
+	CEnv(PEnv& p, CEngine& engine);
+	~CEnv();
+	
+	typedef Env<const AST*, AST*>    Code;
+	typedef Env<const AST*, CValue*> Vals;
+	
+	string  gensym(const char* s="_") { return (format("%s%d") % s % symID++).str(); }
+	void    push() { code.push(); vals.push(); }
+	void    pop()  { code.pop();  vals.pop();  }
+	void    precompile(AST* obj, CValue* value) { vals.def(obj, value); }
+	CValue* compile(AST* obj);
+	void    optimise(CFunction& f);
+	
+	CEngine&   engine;
+	PEnv&      penv;
+	TEnv       tenv;
+	Code       code;
+	Vals       vals;
+	unsigned   symID;
+	CFunction* alloc;
+
+private:
+	CEnvPimpl* _pimpl;
+};
+
+#endif // TUPLR_HPP
+