diff options
| -rwxr-xr-x | build.sh | 2 | ||||
| -rw-r--r-- | tuplr.cpp | 1187 | ||||
| -rw-r--r-- | tuplr.hpp | 464 | ||||
| -rw-r--r-- | tuplr_llvm.cpp | 635 | ||||
| -rw-r--r-- | tuplr_llvm.hpp | 47 | ||||
| -rw-r--r-- | typing.cpp | 198 |
6 files changed, 1351 insertions, 1182 deletions
@@ -1,5 +1,5 @@ #!/bin/sh CXXFLAGS="-O0 -g -Wall -Wextra -Wno-unused-parameter" -g++ $CXXFLAGS tuplr.cpp `llvm-config --cppflags --ldflags --libs core jit native` -lm -o tuplr +g++ $CXXFLAGS tuplr.cpp typing.cpp tuplr_llvm.cpp `llvm-config --cppflags --ldflags --libs core jit native` -lm -o tuplr @@ -1,4 +1,4 @@ -/* Tuplr: A minimalist programming language +/* 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 @@ -15,70 +15,25 @@ * along with Tuplr. If not, see <http://www.gnu.org/licenses/>. */ -#include <stdarg.h> -#include <fstream> -#include <iostream> -#include <list> -#include <map> -#include <sstream> #include <stack> -#include <string> -#include <vector> -#include <boost/format.hpp> -#include "llvm/Analysis/Verifier.h" -#include "llvm/DerivedTypes.h" -#include "llvm/ExecutionEngine/ExecutionEngine.h" -#include "llvm/Instructions.h" -#include "llvm/Module.h" -#include "llvm/ModuleProvider.h" -#include "llvm/PassManager.h" -#include "llvm/Support/IRBuilder.h" -#include "llvm/Target/TargetData.h" -#include "llvm/Transforms/Scalar.h" +#include "tuplr.hpp" #define FOREACH(IT, i, c) for (IT i = (c).begin(); i != (c).end(); ++i) -using namespace llvm; using namespace std; +using namespace llvm; using boost::format; +Funcs ASTConsCall::funcs; + std::ostream& err = std::cerr; std::ostream& out = std::cout; -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; - -static SExp +SExp readExpression(Cursor& cur, std::istream& in) { #define PUSH(s, t) { if (t != "") { s.top().list.push_back(SExp(loc, t)); t = ""; } } @@ -134,1133 +89,3 @@ readExpression(Cursor& cur, std::istream& in) return SExp(cur); } - -/*************************************************************************** - * Abstract Syntax Tree * - ***************************************************************************/ - -struct TEnv; ///< Type-Time Environment -struct CEnv; ///< Compile-Time Environment - -/// Constructor user data argument (LLVM opcode) -struct CArg { CArg(int o=0, int a=0) : op(o), arg(a) {} int op; int arg; }; - -/// Base class for all AST nodes -struct AST { - virtual ~AST() {} - virtual bool contains(AST* child) const { return false; } - virtual bool operator==(const AST& o) const = 0; - virtual string str() const = 0; - virtual void constrain(TEnv& tenv) const {} - virtual void lift(CEnv& cenv) {} - virtual Value* compile(CEnv& cenv) = 0; -}; - -/// Literal -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; - Value* 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; } - Value* compile(CEnv& cenv); - Cursor loc; -private: - 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 isForm(const string& f) { return !empty() && at(0)->str() == f; } - bool contains(AST* child) const; - void constrain(TEnv& tenv) const; - Value* 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 Type* 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 {} - Value* 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 Type* type() { - if (at(0)->str() == "Pair") { - vector<const Type*> types; - for (size_t i = 1; i < size(); ++i) { - assert(dynamic_cast<AType*>(at(i))); - types.push_back(((AType*)at(i))->type()); - } - return PointerType::get(StructType::get(types, false), 0); - } else { - return ctype; - } - } - enum Kind { VAR, PRIM, EXPR }; - Kind kind; - unsigned id; -private: - const Type* ctype; -}; - -/// Lifted LLVM functions for a single Tuplr function -struct Funcs : public list< pair<AType*, Function*> > { - Function* 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, Function* 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), 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); - Value* 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); - Value* 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); - Value* 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; - Value* 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), op(ca.op), arg(ca.arg) {} - void constrain(TEnv& tenv) const; - Value* compile(CEnv& cenv); - unsigned op; - unsigned 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); - Value* compile(CEnv& cenv); - static Funcs funcs; -}; - -Funcs ASTConsCall::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; - Value* 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; - Value* 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> -static AST* -parseAST(PEnv& penv, const SExp& exp, CArg arg=CArg()) -{ - return new C(exp, pmap(penv, exp.list), arg); -} - -static 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() { 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; -}; - -#define OP_IS_A(o, t) ((o) >= t ## Begin && (o) < t ## End) - -void -ASTTuple::constrain(TEnv& tenv) const -{ - AType* t = new AType(ASTTuple()); - FOREACH(const_iterator, p, *this) { - (*p)->constrain(tenv); - t->push_back(tenv.type(*p)); - } - tenv.constrain(this, t); -} - -void -ASTClosure::constrain(TEnv& tenv) const -{ - at(1)->constrain(tenv); - at(2)->constrain(tenv); - AType* protT = tenv.type(at(1)); - AType* bodyT = tenv.type(at(2)); - tenv.constrain(this, new AType(ASTTuple( - tenv.penv.sym("Fn"), protT, bodyT, 0))); -} - -void -ASTCall::constrain(TEnv& tenv) const -{ - FOREACH(const_iterator, p, *this) - (*p)->constrain(tenv); - AType* retT = tenv.type(this); - AType* argsT = new AType(ASTTuple()); - for (size_t i = 1; i < size(); ++i) - argsT->push_back(tenv.type(at(i))); - tenv.constrain(at(0), new AType(ASTTuple( - tenv.penv.sym("Fn"), argsT, retT, NULL))); -} - -void -ASTDefinition::constrain(TEnv& tenv) const -{ - if (size() != 3) - throw Error("`def' requires exactly 2 arguments", exp.loc); - if (!dynamic_cast<const ASTSymbol*>(at(1))) - throw Error("`def' name is not a symbol", exp.loc); - FOREACH(const_iterator, p, *this) - (*p)->constrain(tenv); - AType* tvar = tenv.type(this); - tenv.constrain(at(1), tvar); - tenv.constrain(at(2), tvar); -} - -void -ASTIf::constrain(TEnv& tenv) const -{ - FOREACH(const_iterator, p, *this) - (*p)->constrain(tenv); - AType* tvar = tenv.type(this); - tenv.constrain(at(1), tenv.named("Bool")); - tenv.constrain(at(2), tvar); - tenv.constrain(at(3), tvar); -} - -void -ASTPrimitive::constrain(TEnv& tenv) const -{ - FOREACH(const_iterator, p, *this) - (*p)->constrain(tenv); - if (OP_IS_A(op, Instruction::BinaryOps)) { - if (size() <= 2) throw Error((format("`%1%' requires at least 2 arguments") - % at(0)->str()).str(), exp.loc); - AType* tvar = tenv.type(this); - for (size_t i = 1; i < size(); ++i) - tenv.constrain(at(i), tvar); - } else if (op == Instruction::ICmp) { - if (size() != 3) throw Error((format("`%1%' requires exactly 2 arguments") - % at(0)->str()).str(), exp.loc); - tenv.constrain(at(1), tenv.type(at(2))); - tenv.constrain(this, tenv.named("Bool")); - } else { - throw Error((format("unknown primitive `%1%'") % at(0)->str()).str(), exp.loc); - } -} - -void -ASTConsCall::constrain(TEnv& tenv) const -{ - AType* t = new AType(ASTTuple(tenv.penv.sym("Pair"), 0)); - for (size_t i = 1; i < size(); ++i) { - at(i)->constrain(tenv); - t->push_back(tenv.type(at(i))); - } - tenv.constrain(this, t); -} - -void -ASTCarCall::constrain(TEnv& tenv) const -{ - at(1)->constrain(tenv); - AType* ct = tenv.var(); - AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), ct, tenv.var(), 0)); - tenv.constrain(at(1), tt); - tenv.constrain(this, ct); -} - -void -ASTCdrCall::constrain(TEnv& tenv) const -{ - at(1)->constrain(tenv); - AType* ct = tenv.var(); - AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), tenv.var(), ct, 0)); - tenv.constrain(at(1), tt); - tenv.constrain(this, ct); -} - -static void -substitute(ASTTuple* tup, AST* from, AST* to) -{ - if (!tup) return; - for (size_t i = 0; i < tup->size(); ++i) - if (*tup->at(i) == *from) - tup->at(i) = to; - else - substitute(dynamic_cast<ASTTuple*>(tup->at(i)), from, to); -} - -bool -ASTTuple::contains(AST* child) const -{ - if (*this == *child) return true; - FOREACH(const_iterator, p, *this) - if (**p == *child || (*p)->contains(child)) - return true; - return false; -} - -TSubst -compose(const TSubst& delta, const TSubst& gamma) // TAPL 22.1.1 -{ - TSubst r; - for (TSubst::const_iterator g = gamma.begin(); g != gamma.end(); ++g) { - TSubst::const_iterator d = delta.find(g->second); - r.insert(make_pair(g->first, ((d != delta.end()) ? d : g)->second)); - } - for (TSubst::const_iterator d = delta.begin(); d != delta.end(); ++d) { - if (gamma.find(d->first) == gamma.end()) - r.insert(*d); - } - return r; -} - -void -substConstraints(TEnv::Constraints& constraints, AType* s, AType* t) -{ - for (TEnv::Constraints::iterator c = constraints.begin(); c != constraints.end();) { - TEnv::Constraints::iterator next = c; ++next; - if (*c->first == *s) c->first = t; - if (*c->second == *s) c->second = t; - substitute(c->first, s, t); - substitute(c->second, s, t); - c = next; - } -} - -TSubst -TEnv::unify(const Constraints& constraints) // TAPL 22.4 -{ - if (constraints.empty()) return TSubst(); - AType* s = constraints.begin()->first; - AType* t = constraints.begin()->second; - Constraints cp = constraints; - cp.erase(cp.begin()); - - if (*s == *t) { - return unify(cp); - } else if (s->var() && !t->contains(s)) { - substConstraints(cp, s, t); - return compose(unify(cp), TSubst(s, t)); - } else if (t->var() && !s->contains(t)) { - substConstraints(cp, t, s); - return compose(unify(cp), TSubst(t, s)); - } else if (s->size() == t->size()) { - for (size_t i = 0; i < s->size(); ++i) { - AType* si = dynamic_cast<AType*>(s->at(i)); - AType* ti = dynamic_cast<AType*>(t->at(i)); - if (si && ti) - cp.push_back(make_pair(si, ti)); - } - return unify(cp); - } else { - throw Error("Type unification failed"); - } -} - -void -TEnv::apply(const TSubst& substs) -{ - FOREACH(TSubst::const_iterator, s, substs) - FOREACH(Frame::iterator, t, front()) - if (*t->second == *s->first) - t->second = s->second; - else - substitute(t->second, s->first, s->second); -} - - -/*************************************************************************** - * Code Generation * - ***************************************************************************/ - -class PEnv; - -/// Compile-Time Environment -struct CEnv { - CEnv(PEnv& p, Module* m, const TargetData* target) - : penv(p), tenv(p), module(m), emp(module), opt(&emp), symID(0) - { - // Set up the optimizer pipeline: - opt.add(new TargetData(*target)); // Register target arch - opt.add(createInstructionCombiningPass()); // Simple optimizations - opt.add(createReassociatePass()); // Reassociate expressions - opt.add(createGVNPass()); // Eliminate Common Subexpressions - opt.add(createCFGSimplificationPass()); // Simplify control flow - } - string gensym(const char* s="_") { return (format("%1%%2%") % s % symID++).str(); } - void push() { code.push(); vals.push(); } - void pop() { code.pop(); vals.pop(); } - Value* compile(AST* obj) { - Value** v = vals.ref(obj); - return (v) ? *v : vals.def(obj, obj->compile(*this)); - } - void precompile(AST* obj, Value* value) { - assert(!vals.ref(obj)); - vals.def(obj, value); - } - void optimise(Function& f) { return; verifyFunction(f); opt.run(f); } - typedef Env<const AST*, AST*> Code; - typedef Env<const AST*, Value*> Vals; - PEnv& penv; - TEnv tenv; - IRBuilder<> builder; - Module* module; - ExistingModuleProvider emp; - FunctionPassManager opt; - unsigned symID; - Code code; - Vals vals; - Function* alloc; -}; - -#define LITERAL(CT, NAME, COMPILED) \ -template<> Value* \ -ASTLiteral<CT>::compile(CEnv& cenv) { return (COMPILED); } \ -template<> void \ -ASTLiteral<CT>::constrain(TEnv& tenv) const { tenv.constrain(this, tenv.named(NAME)); } - -/// Literal template instantiations -LITERAL(int32_t, "Int", ConstantInt::get(Type::Int32Ty, val, true)) -LITERAL(float, "Float", ConstantFP::get(Type::FloatTy, val)) -LITERAL(bool, "Bool", ConstantInt::get(Type::Int1Ty, val, false)) - -static Function* -compileFunction(CEnv& cenv, const std::string& name, const Type* retT, const ASTTuple& prot, - const vector<string> argNames=vector<string>()) -{ - Function::LinkageTypes linkage = Function::ExternalLinkage; - - vector<const Type*> cprot; - for (size_t i = 0; i < prot.size(); ++i) { - AType* at = cenv.tenv.type(prot.at(i)); - if (!at->type() || at->var()) throw Error("function parameter is untyped"); - cprot.push_back(at->type()); - } - - if (!retT) throw Error("function return is untyped"); - FunctionType* fT = FunctionType::get(retT, cprot, false); - Function* f = Function::Create(fT, linkage, name, cenv.module); - - if (f->getName() != name) { - f->eraseFromParent(); - throw Error("function redefined"); - } - - // Set argument names in generated code - Function::arg_iterator a = f->arg_begin(); - if (!argNames.empty()) - for (size_t i = 0; i != prot.size(); ++a, ++i) - a->setName(argNames.at(i)); - else - for (size_t i = 0; i != prot.size(); ++a, ++i) - a->setName(prot.at(i)->str()); - - BasicBlock* bb = BasicBlock::Create("entry", f); - cenv.builder.SetInsertPoint(bb); - - return f; -} - -Value* -ASTSymbol::compile(CEnv& cenv) -{ - AST** c = cenv.code.ref(this); - if (!c) throw Error((string("undefined symbol `") + cppstr + "'").c_str(), loc); - return cenv.compile(*c); -} - -void -ASTClosure::lift(CEnv& cenv) -{ - AType* type = cenv.tenv.type(this); - if (!type->concrete()) { - err << "closure is untyped, not lifting" << endl; - return; - } - - if (funcs.find(type)) - return; - - cenv.push(); - - // Write function declaration - string name = this->name == "" ? cenv.gensym("_fn") : this->name; - Function* f = compileFunction(cenv, name, cenv.tenv.type(at(2))->type(), *prot()); - - // Bind argument values in CEnv - vector<Value*> args; - const_iterator p = prot()->begin(); - for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++p) - cenv.vals.def(dynamic_cast<ASTSymbol*>(*p), &*a); - - // Write function body - try { - cenv.precompile(this, f); // Define our value first for recursion - Value* retVal = cenv.compile(at(2)); - cenv.builder.CreateRet(retVal); // Finish function - cenv.optimise(*f); - funcs.insert(type, f); - } catch (Error& e) { - f->eraseFromParent(); // Error reading body, remove function - throw e; - } - - cenv.pop(); -} - -Value* -ASTClosure::compile(CEnv& cenv) -{ - return funcs.find(cenv.tenv.type(this)); -} - -void -ASTCall::lift(CEnv& cenv) -{ - ASTClosure* c = dynamic_cast<ASTClosure*>(at(0)); - if (!c) { - AST** val = cenv.code.ref(at(0)); - c = (val) ? dynamic_cast<ASTClosure*>(*val) : c; - } - - // Lift arguments - for (size_t i = 1; i < size(); ++i) - at(i)->lift(cenv); - - if (!c) return; - - // Extend environment with bound and typed parameters - cenv.push(); - if (c->prot()->size() < size() - 1) - throw Error((format("too many arguments to function `%1%'") % at(0)->str()).str(), exp.loc); - if (c->prot()->size() > size() - 1) - throw Error((format("too few arguments to function `%1%'") % at(0)->str()).str(), exp.loc); - - for (size_t i = 1; i < size(); ++i) - cenv.code.def(c->prot()->at(i-1), at(i)); - - c->lift(cenv); // Lift called closure - cenv.pop(); // Restore environment -} - -Value* -ASTCall::compile(CEnv& cenv) -{ - ASTClosure* c = dynamic_cast<ASTClosure*>(at(0)); - if (!c) { - AST** val = cenv.code.ref(at(0)); - c = (val) ? dynamic_cast<ASTClosure*>(*val) : c; - } - - assert(c); - Function* f = dynamic_cast<Function*>(cenv.compile(c)); - if (!f) throw Error("callee failed to compile", exp.loc); - - vector<Value*> params(size() - 1); - for (size_t i = 1; i < size(); ++i) - params[i-1] = cenv.compile(at(i)); - - return cenv.builder.CreateCall(f, params.begin(), params.end(), "calltmp"); -} - -void -ASTDefinition::lift(CEnv& cenv) -{ - if (cenv.code.ref((ASTSymbol*)at(1))) - throw Error(string("`") + at(1)->str() + "' redefined", exp.loc); - cenv.code.def((ASTSymbol*)at(1), at(2)); // Define first for recursion - at(2)->lift(cenv); -} - -Value* -ASTDefinition::compile(CEnv& cenv) -{ - return cenv.compile(at(2)); -} - -Value* -ASTIf::compile(CEnv& cenv) -{ - typedef vector< pair<Value*, BasicBlock*> > Branches; - Function* parent = cenv.builder.GetInsertBlock()->getParent(); - BasicBlock* mergeBB = BasicBlock::Create("endif"); - BasicBlock* nextBB = NULL; - Branches branches; - ostringstream ss; - for (size_t i = 1; i < size() - 1; i += 2) { - Value* condV = cenv.compile(at(i)); - - ss.str(""); ss << "then" << ((i + 1) / 2); - BasicBlock* thenBB = BasicBlock::Create(ss.str()); - - ss.str(""); ss << "else" << ((i + 1) / 2); - nextBB = BasicBlock::Create(ss.str()); - - cenv.builder.CreateCondBr(condV, thenBB, nextBB); - - // Emit then block for this condition - parent->getBasicBlockList().push_back(thenBB); - cenv.builder.SetInsertPoint(thenBB); - Value* thenV = cenv.compile(at(i + 1)); - cenv.builder.CreateBr(mergeBB); - branches.push_back(make_pair(thenV, cenv.builder.GetInsertBlock())); - - parent->getBasicBlockList().push_back(nextBB); - cenv.builder.SetInsertPoint(nextBB); - } - - // Emit else block - cenv.builder.SetInsertPoint(nextBB); - Value* elseV = cenv.compile(at(size() - 1)); - cenv.builder.CreateBr(mergeBB); - branches.push_back(make_pair(elseV, cenv.builder.GetInsertBlock())); - - // Emit merge block (Phi node) - parent->getBasicBlockList().push_back(mergeBB); - cenv.builder.SetInsertPoint(mergeBB); - PHINode* pn = cenv.builder.CreatePHI(cenv.tenv.type(this)->type(), "ifval"); - - for (Branches::iterator i = branches.begin(); i != branches.end(); ++i) - pn->addIncoming(i->first, i->second); - - return pn; -} - -Value* -ASTPrimitive::compile(CEnv& cenv) -{ - Value* a = cenv.compile(at(1)); - Value* b = cenv.compile(at(2)); - - if (OP_IS_A(op, Instruction::BinaryOps)) { - const Instruction::BinaryOps bo = (Instruction::BinaryOps)op; - if (size() == 2) - return cenv.compile(at(1)); - Value* val = cenv.builder.CreateBinOp(bo, a, b); - for (size_t i = 3; i < size(); ++i) - val = cenv.builder.CreateBinOp(bo, val, cenv.compile(at(i))); - return val; - } else if (op == Instruction::ICmp) { - bool isInt = cenv.tenv.type(at(1))->str() == "Int"; - if (isInt) { - return cenv.builder.CreateICmp((CmpInst::Predicate)arg, a, b); - } else { - // Translate to floating point operation - switch (arg) { - case CmpInst::ICMP_EQ: arg = CmpInst::FCMP_OEQ; break; - case CmpInst::ICMP_NE: arg = CmpInst::FCMP_ONE; break; - case CmpInst::ICMP_SGT: arg = CmpInst::FCMP_OGT; break; - case CmpInst::ICMP_SGE: arg = CmpInst::FCMP_OGE; break; - case CmpInst::ICMP_SLT: arg = CmpInst::FCMP_OLT; break; - case CmpInst::ICMP_SLE: arg = CmpInst::FCMP_OLE; break; - default: throw Error("Unknown primitive", exp.loc); - } - return cenv.builder.CreateFCmp((CmpInst::Predicate)arg, a, b); - } - } - throw Error("Unknown primitive", exp.loc); -} - -AType* -ASTConsCall::functionType(CEnv& cenv) -{ - ASTTuple* protTypes = new ASTTuple(cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), NULL); - AType* cellType = new AType(ASTTuple(cenv.penv.sym("Pair"), - cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), NULL)); - return new AType(ASTTuple(cenv.penv.sym("Fn"), protTypes, cellType, NULL)); -} - -void -ASTConsCall::lift(CEnv& cenv) -{ - AType* funcType = functionType(cenv); - if (funcs.find(functionType(cenv))) - return; - - ASTCall::lift(cenv); - - ASTTuple* prot = new ASTTuple(at(1), at(2), NULL); - - vector<const Type*> types; - size_t sz = 0; - for (size_t i = 1; i < size(); ++i) { - const Type* t = cenv.tenv.type(at(i))->type(); - types.push_back(t); - sz += t->getPrimitiveSizeInBits(); - } - sz = (sz % 8 == 0) ? sz / 8 : sz / 8 + 1; - - StructType* sT = StructType::get(types, false); - Type* pT = PointerType::get(sT, 0); - - // Write function declaration - vector<string> argNames; - argNames.push_back("car"); - argNames.push_back("cdr"); - Function* func = compileFunction(cenv, cenv.gensym("cons"), pT, *prot, argNames); - - Value* mem = cenv.builder.CreateCall(cenv.alloc, ConstantInt::get(Type::Int32Ty, sz), "mem"); - Value* cell = cenv.builder.CreateBitCast(mem, pT, "cell"); - Value* s = cenv.builder.CreateGEP(cell, ConstantInt::get(Type::Int32Ty, 0), "pair"); - Value* carP = cenv.builder.CreateStructGEP(s, 0, "car"); - Value* cdrP = cenv.builder.CreateStructGEP(s, 1, "cdr"); - Function::arg_iterator ai = func->arg_begin(); - Value& carArg = *ai++; - Value& cdrArg = *ai++; - cenv.builder.CreateStore(&carArg, carP); - cenv.builder.CreateStore(&cdrArg, cdrP); - cenv.builder.CreateRet(cell); - cenv.optimise(*func); - - funcs.insert(funcType, func); -} - -Value* -ASTConsCall::compile(CEnv& cenv) -{ - vector<Value*> params(size() - 1); - for (size_t i = 1; i < size(); ++i) - params[i-1] = cenv.compile(at(i)); - - return cenv.builder.CreateCall(funcs.find(functionType(cenv)), params.begin(), params.end()); -} - -Value* -ASTCarCall::compile(CEnv& cenv) -{ - AST** arg = cenv.code.ref(at(1)); - Value* sP = arg ? (*arg)->compile(cenv) : at(1)->compile(cenv); - Value* s = cenv.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair"); - Value* carP = cenv.builder.CreateStructGEP(s, 0, "car"); - return cenv.builder.CreateLoad(carP); -} - -Value* -ASTCdrCall::compile(CEnv& cenv) -{ - AST** arg = cenv.code.ref(at(1)); - Value* sP = arg ? (*arg)->compile(cenv) : at(1)->compile(cenv); - Value* s = cenv.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair"); - Value* cdrP = cenv.builder.CreateStructGEP(s, 1, "cdr"); - return cenv.builder.CreateLoad(cdrP); -} - - -/*************************************************************************** - * EVAL/REPL/MAIN * - ***************************************************************************/ - -std::string -call(AType* retT, void* fp) -{ - std::stringstream ss; - if (retT->type() == Type::Int32Ty) - ss << ((int32_t (*)())fp)(); - else if (retT->type() == Type::FloatTy) - ss << ((float (*)())fp)(); - else if (retT->type() == Type::Int1Ty) - ss << ((bool (*)())fp)(); - else - ss << ((void* (*)())fp)(); - return ss.str(); -} - -int -eval(CEnv& cenv, ExecutionEngine* engine, const string& name, istream& is) -{ - AST* result = NULL; - AType* resultType = NULL; - list< pair<SExp, AST*> > exprs; - Cursor cursor(name); - try { - while (true) { - SExp exp = readExpression(cursor, is); - if (exp.type == SExp::LIST && exp.list.empty()) - break; - - result = parseExpression(cenv.penv, exp); // Parse input - result->constrain(cenv.tenv); // Constrain types - cenv.tenv.solve(); // Solve and apply type constraints - resultType = cenv.tenv.type(result); - result->lift(cenv); // Lift functions - exprs.push_back(make_pair(exp, result)); - } - - if (!resultType || resultType->var()) throw Error("body is undefined/untyped", cursor); - - const Type* ctype = resultType->type(); - if (!ctype) throw Error("body has no system type", cursor); - - // Create function for top-level of program - Function* f = compileFunction(cenv, cenv.gensym("input"), ctype, ASTTuple()); - - // Compile all expressions into it - Value* val = NULL; - for (list< pair<SExp, AST*> >::const_iterator i = exprs.begin(); i != exprs.end(); ++i) - val = cenv.compile(i->second); - - // Finish function - cenv.builder.CreateRet(val); - cenv.optimise(*f); - - string resultStr = call(resultType, engine->getPointerToFunction(f)); - out << resultStr << " : " << resultType->str() << endl; - - } catch (Error& e) { - err << e.what() << endl; - return 1; - } - - return 0; -} - -int -repl(CEnv& cenv, ExecutionEngine* engine) -{ - while (1) { - out << "() "; - out.flush(); - Cursor cursor("(stdin)"); - SExp exp = readExpression(cursor, std::cin); - if (exp.type == SExp::LIST && exp.list.empty()) - break; - - try { - AST* body = parseExpression(cenv.penv, exp); // Parse input - body->constrain(cenv.tenv); // Constrain types - cenv.tenv.solve(); // Solve and apply type constraints - - AType* bodyT = cenv.tenv.type(body); - if (!bodyT) throw Error("call to untyped body", cursor); - if (!bodyT->concrete()) throw Error("call to variable typed body", cursor); - - body->lift(cenv); - - if (bodyT->type()) { - // Create anonymous function to insert code into - Function* f = compileFunction(cenv, cenv.gensym("_repl"), bodyT->type(), ASTTuple()); - try { - Value* retVal = cenv.compile(body); - cenv.builder.CreateRet(retVal); // Finish function - cenv.optimise(*f); - } catch (Error& e) { - f->eraseFromParent(); // Error reading body, remove function - throw e; - } - out << call(bodyT, engine->getPointerToFunction(f)); - } else { - Value* val = cenv.compile(body); - out << "; " << val; - } - out << " : " << cenv.tenv.type(body)->str() << endl; - - } catch (Error& e) { - err << e.what() << endl; - } - } - - return 0; -} - -int -main(int argc, char** argv) -{ -#define PRIM(O, A) PEnv::Parser(parseAST<ASTPrimitive>, CArg(Instruction:: O, A)) - PEnv penv; - penv.reg("fn", PEnv::Parser(parseFn)); - penv.reg("if", PEnv::Parser(parseAST<ASTIf>)); - penv.reg("def", PEnv::Parser(parseAST<ASTDefinition>)); - penv.reg("cons", PEnv::Parser(parseAST<ASTConsCall>)); - penv.reg("car", PEnv::Parser(parseAST<ASTCarCall>)); - penv.reg("cdr", PEnv::Parser(parseAST<ASTCdrCall>)); - penv.reg("+", PRIM(Add, 0)); - penv.reg("-", PRIM(Sub, 0)); - penv.reg("*", PRIM(Mul, 0)); - penv.reg("/", PRIM(FDiv, 0)); - penv.reg("%", PRIM(FRem, 0)); - penv.reg("&", PRIM(And, 0)); - penv.reg("|", PRIM(Or, 0)); - penv.reg("^", PRIM(Xor, 0)); - penv.reg("=", PRIM(ICmp, CmpInst::ICMP_EQ)); - penv.reg("!=", PRIM(ICmp, CmpInst::ICMP_NE)); - penv.reg(">", PRIM(ICmp, CmpInst::ICMP_SGT)); - penv.reg(">=", PRIM(ICmp, CmpInst::ICMP_SGE)); - penv.reg("<", PRIM(ICmp, CmpInst::ICMP_SLT)); - penv.reg("<=", PRIM(ICmp, CmpInst::ICMP_SLE)); - - Module* module = new Module("interactive"); - ExecutionEngine* engine = ExecutionEngine::create(module); - CEnv cenv(penv, module, engine->getTargetData()); - - cenv.tenv.def(penv.sym("Bool"), new AType(penv.sym("Bool"), Type::Int1Ty)); - cenv.tenv.def(penv.sym("Int"), new AType(penv.sym("Int"), Type::Int32Ty)); - cenv.tenv.def(penv.sym("Float"), new AType(penv.sym("Float"), Type::FloatTy)); - - // Host provided allocation primitive prototypes - std::vector<const Type*> argsT(1, Type::Int32Ty); - FunctionType* funcT = FunctionType::get(PointerType::get(Type::Int8Ty, 0), argsT, false); - cenv.alloc = Function::Create(funcT, Function::ExternalLinkage, "malloc", module); - - int ret; - if (argc > 2 && !strncmp(argv[1], "-e", 3)) { - std::istringstream is(argv[2]); - ret = eval(cenv, engine, "(command line)", is); - } else if (argc > 2 && !strncmp(argv[1], "-f", 3)) { - std::ifstream is(argv[2]); - ret = eval(cenv, engine, argv[2], is); - is.close(); - } else { - ret = repl(cenv, engine); - } - - //out << endl << "*** Generated Code ***" << endl; - //cenv.module->dump(); - - return ret; -} - 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 + diff --git a/tuplr_llvm.cpp b/tuplr_llvm.cpp new file mode 100644 index 0000000..a807f75 --- /dev/null +++ b/tuplr_llvm.cpp @@ -0,0 +1,635 @@ +/* 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/>. + */ + +#include <sstream> +#include <fstream> +#include "tuplr.hpp" +#include "tuplr_llvm.hpp" + +using namespace llvm; +using namespace std; +using boost::format; + + +/*************************************************************************** + * Abstract Syntax Tree * + ***************************************************************************/ + +const CType* +AType::type() +{ + if (at(0)->str() == "Pair") { + vector<const CType*> types; + for (size_t i = 1; i < size(); ++i) { + assert(dynamic_cast<AType*>(at(i))); + types.push_back(((AType*)at(i))->type()); + } + return PointerType::get(StructType::get(types, false), 0); + } else { + return ctype; + } +} + + +/*************************************************************************** + * Typing * + ***************************************************************************/ + +#define OP_IS_A(o, t) ((o) >= t ## Begin && (o) < t ## End) + +void +ASTPrimitive::constrain(TEnv& tenv) const +{ + FOREACH(const_iterator, p, *this) + (*p)->constrain(tenv); + if (OP_IS_A(arg.op, Instruction::BinaryOps)) { + if (size() <= 2) throw Error((format("`%1%' requires at least 2 arguments") + % at(0)->str()).str(), exp.loc); + AType* tvar = tenv.type(this); + for (size_t i = 1; i < size(); ++i) + tenv.constrain(at(i), tvar); + } else if (arg.op == Instruction::ICmp) { + if (size() != 3) throw Error((format("`%1%' requires exactly 2 arguments") + % at(0)->str()).str(), exp.loc); + tenv.constrain(at(1), tenv.type(at(2))); + tenv.constrain(this, tenv.named("Bool")); + } else { + throw Error((format("unknown primitive `%1%'") % at(0)->str()).str(), exp.loc); + } +} + + +/*************************************************************************** + * Code Generation * + ***************************************************************************/ + +// Compile-Time Environment + +CEngine::CEngine() + : module(new Module("tuplr")) + , engine(ExecutionEngine::create(module)) +{ +} + +struct CEnvPimpl { + CEnvPimpl(CEngine& engine) + : module(engine.module), emp(module), opt(&emp) + { + // Set up the optimizer pipeline: + const TargetData* target = engine.engine->getTargetData(); + opt.add(new TargetData(*target)); // Register target arch + opt.add(createInstructionCombiningPass()); // Simple optimizations + opt.add(createReassociatePass()); // Reassociate expressions + opt.add(createGVNPass()); // Eliminate Common Subexpressions + opt.add(createCFGSimplificationPass()); // Simplify control flow + } + + Module* module; + ExistingModuleProvider emp; + FunctionPassManager opt; + Function* alloc; +}; + +CEnv::CEnv(PEnv& p, CEngine& eng) + : engine(eng), penv(p), tenv(p), symID(0), _pimpl(new CEnvPimpl(eng)) +{ +} + +CEnv::~CEnv() +{ + delete _pimpl; +} + +CValue* +CEnv::compile(AST* obj) +{ + CValue** v = vals.ref(obj); + return (v) ? *v : vals.def(obj, obj->compile(*this)); +} + +void +CEnv::optimise(Function& f) +{ + verifyFunction(f); + _pimpl->opt.run(f); +} + +#define LITERAL(CT, NAME, COMPILED) \ +template<> CValue* \ +ASTLiteral<CT>::compile(CEnv& cenv) { return (COMPILED); } \ +template<> void \ +ASTLiteral<CT>::constrain(TEnv& tenv) const { tenv.constrain(this, tenv.named(NAME)); } + +/// Literal template instantiations +LITERAL(int32_t, "Int", ConstantInt::get(Type::Int32Ty, val, true)) +LITERAL(float, "Float", ConstantFP::get(Type::FloatTy, val)) +LITERAL(bool, "Bool", ConstantInt::get(Type::Int1Ty, val, false)) + +static Function* +compileFunction(CEnv& cenv, const std::string& name, const CType* retT, const ASTTuple& prot, + const vector<string> argNames=vector<string>()) +{ + Function::LinkageTypes linkage = Function::ExternalLinkage; + + vector<const CType*> cprot; + for (size_t i = 0; i < prot.size(); ++i) { + AType* at = cenv.tenv.type(prot.at(i)); + if (!at->type() || at->var()) throw Error("function parameter is untyped"); + cprot.push_back(at->type()); + } + + if (!retT) throw Error("function return is untyped"); + FunctionType* fT = FunctionType::get(retT, cprot, false); + Function* f = Function::Create(fT, linkage, name, cenv.engine.module); + + if (f->getName() != name) { + f->eraseFromParent(); + throw Error("function redefined"); + } + + // Set argument names in generated code + Function::arg_iterator a = f->arg_begin(); + if (!argNames.empty()) + for (size_t i = 0; i != prot.size(); ++a, ++i) + a->setName(argNames.at(i)); + else + for (size_t i = 0; i != prot.size(); ++a, ++i) + a->setName(prot.at(i)->str()); + + BasicBlock* bb = BasicBlock::Create("entry", f); + cenv.engine.builder.SetInsertPoint(bb); + + return f; +} + +CValue* +ASTSymbol::compile(CEnv& cenv) +{ + AST** c = cenv.code.ref(this); + if (!c) throw Error((string("undefined symbol `") + cppstr + "'").c_str(), loc); + return cenv.compile(*c); +} + +void +ASTClosure::lift(CEnv& cenv) +{ + AType* type = cenv.tenv.type(this); + if (!type->concrete()) { + err << "closure is untyped, not lifting" << endl; + return; + } + + if (funcs.find(type)) + return; + + cenv.push(); + + // Write function declaration + string name = this->name == "" ? cenv.gensym("_fn") : this->name; + Function* f = compileFunction(cenv, name, cenv.tenv.type(at(2))->type(), *prot()); + + // Bind argument values in CEnv + vector<CValue*> args; + const_iterator p = prot()->begin(); + for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++p) + cenv.vals.def(dynamic_cast<ASTSymbol*>(*p), &*a); + + // Write function body + try { + cenv.precompile(this, f); // Define our value first for recursion + CValue* retVal = cenv.compile(at(2)); + cenv.engine.builder.CreateRet(retVal); // Finish function + cenv.optimise(*f); + funcs.insert(type, f); + } catch (Error& e) { + f->eraseFromParent(); // Error reading body, remove function + throw e; + } + + cenv.pop(); +} + +CValue* +ASTClosure::compile(CEnv& cenv) +{ + return funcs.find(cenv.tenv.type(this)); +} + +void +ASTCall::lift(CEnv& cenv) +{ + ASTClosure* c = dynamic_cast<ASTClosure*>(at(0)); + if (!c) { + AST** val = cenv.code.ref(at(0)); + c = (val) ? dynamic_cast<ASTClosure*>(*val) : c; + } + + // Lift arguments + for (size_t i = 1; i < size(); ++i) + at(i)->lift(cenv); + + if (!c) return; + + // Extend environment with bound and typed parameters + cenv.push(); + if (c->prot()->size() < size() - 1) + throw Error((format("too many arguments to function `%1%'") % at(0)->str()).str(), exp.loc); + if (c->prot()->size() > size() - 1) + throw Error((format("too few arguments to function `%1%'") % at(0)->str()).str(), exp.loc); + + for (size_t i = 1; i < size(); ++i) + cenv.code.def(c->prot()->at(i-1), at(i)); + + c->lift(cenv); // Lift called closure + cenv.pop(); // Restore environment +} + +CValue* +ASTCall::compile(CEnv& cenv) +{ + ASTClosure* c = dynamic_cast<ASTClosure*>(at(0)); + if (!c) { + AST** val = cenv.code.ref(at(0)); + c = (val) ? dynamic_cast<ASTClosure*>(*val) : c; + } + + assert(c); + Function* f = dynamic_cast<Function*>(cenv.compile(c)); + if (!f) throw Error("callee failed to compile", exp.loc); + + vector<CValue*> params(size() - 1); + for (size_t i = 1; i < size(); ++i) + params[i-1] = cenv.compile(at(i)); + + return cenv.engine.builder.CreateCall(f, params.begin(), params.end(), "calltmp"); +} + +void +ASTDefinition::lift(CEnv& cenv) +{ + if (cenv.code.ref((ASTSymbol*)at(1))) + throw Error(string("`") + at(1)->str() + "' redefined", exp.loc); + cenv.code.def((ASTSymbol*)at(1), at(2)); // Define first for recursion + at(2)->lift(cenv); +} + +CValue* +ASTDefinition::compile(CEnv& cenv) +{ + return cenv.compile(at(2)); +} + +CValue* +ASTIf::compile(CEnv& cenv) +{ + typedef vector< pair<CValue*, BasicBlock*> > Branches; + Function* parent = cenv.engine.builder.GetInsertBlock()->getParent(); + BasicBlock* mergeBB = BasicBlock::Create("endif"); + BasicBlock* nextBB = NULL; + Branches branches; + ostringstream ss; + for (size_t i = 1; i < size() - 1; i += 2) { + CValue* condV = cenv.compile(at(i)); + + ss.str(""); ss << "then" << ((i + 1) / 2); + BasicBlock* thenBB = BasicBlock::Create(ss.str()); + + ss.str(""); ss << "else" << ((i + 1) / 2); + nextBB = BasicBlock::Create(ss.str()); + + cenv.engine.builder.CreateCondBr(condV, thenBB, nextBB); + + // Emit then block for this condition + parent->getBasicBlockList().push_back(thenBB); + cenv.engine.builder.SetInsertPoint(thenBB); + CValue* thenV = cenv.compile(at(i + 1)); + cenv.engine.builder.CreateBr(mergeBB); + branches.push_back(make_pair(thenV, cenv.engine.builder.GetInsertBlock())); + + parent->getBasicBlockList().push_back(nextBB); + cenv.engine.builder.SetInsertPoint(nextBB); + } + + // Emit else block + cenv.engine.builder.SetInsertPoint(nextBB); + CValue* elseV = cenv.compile(at(size() - 1)); + cenv.engine.builder.CreateBr(mergeBB); + branches.push_back(make_pair(elseV, cenv.engine.builder.GetInsertBlock())); + + // Emit merge block (Phi node) + parent->getBasicBlockList().push_back(mergeBB); + cenv.engine.builder.SetInsertPoint(mergeBB); + PHINode* pn = cenv.engine.builder.CreatePHI(cenv.tenv.type(this)->type(), "ifval"); + + for (Branches::iterator i = branches.begin(); i != branches.end(); ++i) + pn->addIncoming(i->first, i->second); + + return pn; +} + +CValue* +ASTPrimitive::compile(CEnv& cenv) +{ + CValue* a = cenv.compile(at(1)); + CValue* b = cenv.compile(at(2)); + + if (OP_IS_A(arg.op, Instruction::BinaryOps)) { + const Instruction::BinaryOps bo = (Instruction::BinaryOps)arg.op; + if (size() == 2) + return cenv.compile(at(1)); + CValue* val = cenv.engine.builder.CreateBinOp(bo, a, b); + for (size_t i = 3; i < size(); ++i) + val = cenv.engine.builder.CreateBinOp(bo, val, cenv.compile(at(i))); + return val; + } else if (arg.op == Instruction::ICmp) { + bool isInt = cenv.tenv.type(at(1))->str() == "Int"; + if (isInt) { + return cenv.engine.builder.CreateICmp((CmpInst::Predicate)arg.arg, a, b); + } else { + // Translate to floating point operation + switch (arg.arg) { + case CmpInst::ICMP_EQ: arg.arg = CmpInst::FCMP_OEQ; break; + case CmpInst::ICMP_NE: arg.arg = CmpInst::FCMP_ONE; break; + case CmpInst::ICMP_SGT: arg.arg = CmpInst::FCMP_OGT; break; + case CmpInst::ICMP_SGE: arg.arg = CmpInst::FCMP_OGE; break; + case CmpInst::ICMP_SLT: arg.arg = CmpInst::FCMP_OLT; break; + case CmpInst::ICMP_SLE: arg.arg = CmpInst::FCMP_OLE; break; + default: throw Error("Unknown primitive", exp.loc); + } + return cenv.engine.builder.CreateFCmp((CmpInst::Predicate)arg.arg, a, b); + } + } + throw Error("Unknown primitive", exp.loc); +} + +AType* +ASTConsCall::functionType(CEnv& cenv) +{ + ASTTuple* protTypes = new ASTTuple(cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), NULL); + AType* cellType = new AType(ASTTuple(cenv.penv.sym("Pair"), + cenv.tenv.type(at(1)), cenv.tenv.type(at(2)), NULL)); + return new AType(ASTTuple(cenv.penv.sym("Fn"), protTypes, cellType, NULL)); +} + +void +ASTConsCall::lift(CEnv& cenv) +{ + AType* funcType = functionType(cenv); + if (funcs.find(functionType(cenv))) + return; + + ASTCall::lift(cenv); + + ASTTuple* prot = new ASTTuple(at(1), at(2), NULL); + + vector<const CType*> types; + size_t sz = 0; + for (size_t i = 1; i < size(); ++i) { + const CType* t = cenv.tenv.type(at(i))->type(); + types.push_back(t); + sz += t->getPrimitiveSizeInBits(); + } + sz = (sz % 8 == 0) ? sz / 8 : sz / 8 + 1; + + StructType* sT = StructType::get(types, false); + CType* pT = PointerType::get(sT, 0); + + // Write function declaration + vector<string> argNames; + argNames.push_back("car"); + argNames.push_back("cdr"); + Function* func = compileFunction(cenv, cenv.gensym("cons"), pT, *prot, argNames); + + CValue* mem = cenv.engine.builder.CreateCall(cenv.alloc, ConstantInt::get(Type::Int32Ty, sz), "mem"); + CValue* cell = cenv.engine.builder.CreateBitCast(mem, pT, "cell"); + CValue* s = cenv.engine.builder.CreateGEP(cell, ConstantInt::get(Type::Int32Ty, 0), "pair"); + CValue* carP = cenv.engine.builder.CreateStructGEP(s, 0, "car"); + CValue* cdrP = cenv.engine.builder.CreateStructGEP(s, 1, "cdr"); + Function::arg_iterator ai = func->arg_begin(); + Value& carArg = *ai++; + Value& cdrArg = *ai++; + cenv.engine.builder.CreateStore(&carArg, carP); + cenv.engine.builder.CreateStore(&cdrArg, cdrP); + cenv.engine.builder.CreateRet(cell); + cenv.optimise(*func); + + funcs.insert(funcType, func); +} + +CValue* +ASTConsCall::compile(CEnv& cenv) +{ + vector<CValue*> params(size() - 1); + for (size_t i = 1; i < size(); ++i) + params[i-1] = cenv.compile(at(i)); + + return cenv.engine.builder.CreateCall(funcs.find(functionType(cenv)), params.begin(), params.end()); +} + +CValue* +ASTCarCall::compile(CEnv& cenv) +{ + AST** arg = cenv.code.ref(at(1)); + CValue* sP = arg ? (*arg)->compile(cenv) : at(1)->compile(cenv); + CValue* s = cenv.engine.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair"); + CValue* carP = cenv.engine.builder.CreateStructGEP(s, 0, "car"); + return cenv.engine.builder.CreateLoad(carP); +} + +CValue* +ASTCdrCall::compile(CEnv& cenv) +{ + AST** arg = cenv.code.ref(at(1)); + CValue* sP = arg ? (*arg)->compile(cenv) : at(1)->compile(cenv); + CValue* s = cenv.engine.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair"); + CValue* cdrP = cenv.engine.builder.CreateStructGEP(s, 1, "cdr"); + return cenv.engine.builder.CreateLoad(cdrP); +} + + +/*************************************************************************** + * EVAL/REPL/MAIN * + ***************************************************************************/ + +std::string +call(AType* retT, void* fp) +{ + std::stringstream ss; + if (retT->type() == Type::Int32Ty) + ss << ((int32_t (*)())fp)(); + else if (retT->type() == Type::FloatTy) + ss << ((float (*)())fp)(); + else if (retT->type() == Type::Int1Ty) + ss << ((bool (*)())fp)(); + else + ss << ((void* (*)())fp)(); + return ss.str(); +} + +int +eval(CEnv& cenv, const string& name, istream& is) +{ + AST* result = NULL; + AType* resultType = NULL; + list< pair<SExp, AST*> > exprs; + Cursor cursor(name); + try { + while (true) { + SExp exp = readExpression(cursor, is); + if (exp.type == SExp::LIST && exp.list.empty()) + break; + + result = parseExpression(cenv.penv, exp); // Parse input + result->constrain(cenv.tenv); // Constrain types + cenv.tenv.solve(); // Solve and apply type constraints + resultType = cenv.tenv.type(result); + result->lift(cenv); // Lift functions + exprs.push_back(make_pair(exp, result)); + } + + if (!resultType || resultType->var()) throw Error("body is undefined/untyped", cursor); + + const CType* ctype = resultType->type(); + if (!ctype) throw Error("body has no system type", cursor); + + // Create function for top-level of program + Function* f = compileFunction(cenv, cenv.gensym("input"), ctype, ASTTuple()); + + // Compile all expressions into it + CValue* val = NULL; + for (list< pair<SExp, AST*> >::const_iterator i = exprs.begin(); i != exprs.end(); ++i) + val = cenv.compile(i->second); + + // Finish function + cenv.engine.builder.CreateRet(val); + cenv.optimise(*f); + + string resultStr = call(resultType, cenv.engine.engine->getPointerToFunction(f)); + out << resultStr << " : " << resultType->str() << endl; + + } catch (Error& e) { + err << e.what() << endl; + return 1; + } + + return 0; +} + +int +repl(CEnv& cenv) +{ + while (1) { + out << "() "; + out.flush(); + Cursor cursor("(stdin)"); + SExp exp = readExpression(cursor, std::cin); + if (exp.type == SExp::LIST && exp.list.empty()) + break; + + try { + AST* body = parseExpression(cenv.penv, exp); // Parse input + body->constrain(cenv.tenv); // Constrain types + cenv.tenv.solve(); // Solve and apply type constraints + + AType* bodyT = cenv.tenv.type(body); + if (!bodyT) throw Error("call to untyped body", cursor); + if (!bodyT->concrete()) throw Error("call to variable typed body", cursor); + + body->lift(cenv); + + if (bodyT->type()) { + // Create anonymous function to insert code into + Function* f = compileFunction(cenv, cenv.gensym("_repl"), bodyT->type(), ASTTuple()); + try { + CValue* retVal = cenv.compile(body); + cenv.engine.builder.CreateRet(retVal); // Finish function + cenv.optimise(*f); + } catch (Error& e) { + f->eraseFromParent(); // Error reading body, remove function + throw e; + } + out << call(bodyT, cenv.engine.engine->getPointerToFunction(f)); + } else { + CValue* val = cenv.compile(body); + out << "; " << val; + } + out << " : " << cenv.tenv.type(body)->str() << endl; + + } catch (Error& e) { + err << e.what() << endl; + } + } + + return 0; +} + +int +main(int argc, char** argv) +{ +#define PRIM(O, A) PEnv::Parser(parseAST<ASTPrimitive>, CArg(Instruction:: O, A)) + PEnv penv; + penv.reg("fn", PEnv::Parser(parseFn)); + penv.reg("if", PEnv::Parser(parseAST<ASTIf>)); + penv.reg("def", PEnv::Parser(parseAST<ASTDefinition>)); + penv.reg("cons", PEnv::Parser(parseAST<ASTConsCall>)); + penv.reg("car", PEnv::Parser(parseAST<ASTCarCall>)); + penv.reg("cdr", PEnv::Parser(parseAST<ASTCdrCall>)); + penv.reg("+", PRIM(Add, 0)); + penv.reg("-", PRIM(Sub, 0)); + penv.reg("*", PRIM(Mul, 0)); + penv.reg("/", PRIM(FDiv, 0)); + penv.reg("%", PRIM(FRem, 0)); + penv.reg("&", PRIM(And, 0)); + penv.reg("|", PRIM(Or, 0)); + penv.reg("^", PRIM(Xor, 0)); + penv.reg("=", PRIM(ICmp, CmpInst::ICMP_EQ)); + penv.reg("!=", PRIM(ICmp, CmpInst::ICMP_NE)); + penv.reg(">", PRIM(ICmp, CmpInst::ICMP_SGT)); + penv.reg(">=", PRIM(ICmp, CmpInst::ICMP_SGE)); + penv.reg("<", PRIM(ICmp, CmpInst::ICMP_SLT)); + penv.reg("<=", PRIM(ICmp, CmpInst::ICMP_SLE)); + + CEngine engine; + CEnv cenv(penv, engine); + + cenv.tenv.def(penv.sym("Bool"), new AType(penv.sym("Bool"), Type::Int1Ty)); + cenv.tenv.def(penv.sym("Int"), new AType(penv.sym("Int"), Type::Int32Ty)); + cenv.tenv.def(penv.sym("Float"), new AType(penv.sym("Float"), Type::FloatTy)); + + // Host provided allocation primitive prototypes + std::vector<const CType*> argsT(1, Type::Int32Ty); + FunctionType* funcT = FunctionType::get(PointerType::get(Type::Int8Ty, 0), argsT, false); + cenv.alloc = Function::Create(funcT, Function::ExternalLinkage, "malloc", engine.module); + + int ret; + if (argc > 2 && !strncmp(argv[1], "-e", 3)) { + std::istringstream is(argv[2]); + ret = eval(cenv, "(command line)", is); + } else if (argc > 2 && !strncmp(argv[1], "-f", 3)) { + std::ifstream is(argv[2]); + ret = eval(cenv, argv[2], is); + is.close(); + } else { + ret = repl(cenv); + } + + //out << endl << "*** Generated Code ***" << endl; + //cenv.module->dump(); + + return ret; +} + diff --git a/tuplr_llvm.hpp b/tuplr_llvm.hpp new file mode 100644 index 0000000..99be041 --- /dev/null +++ b/tuplr_llvm.hpp @@ -0,0 +1,47 @@ +/* Tuplr LLVM Backend Definitions + * 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_LLVM_HPP +#define TUPLR_LLVM_HPP + +#include "tuplr.hpp" +#include "llvm/Analysis/Verifier.h" +#include "llvm/DerivedTypes.h" +#include "llvm/ExecutionEngine/ExecutionEngine.h" +#include "llvm/Instructions.h" +#include "llvm/Module.h" +#include "llvm/ModuleProvider.h" +#include "llvm/PassManager.h" +#include "llvm/Support/IRBuilder.h" +#include "llvm/Target/TargetData.h" +#include "llvm/Transforms/Scalar.h" + +typedef llvm::Value CValue; +typedef llvm::Type CType; +typedef llvm::Function CFunction; + +struct CArg { CArg(int o=0, int a=0) : op(o), arg(a) {} int op; int arg; }; + +struct CEngine { + CEngine(); + llvm::Module* module; + llvm::ExecutionEngine* engine; + llvm::IRBuilder<> builder; +}; + +#endif // TUPLR_LLVM_HPP + diff --git a/typing.cpp b/typing.cpp new file mode 100644 index 0000000..eeba8dc --- /dev/null +++ b/typing.cpp @@ -0,0 +1,198 @@ +/* Tuplr Type Inferencing + * 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/>. + */ + +#include "tuplr.hpp" +void +ASTTuple::constrain(TEnv& tenv) const +{ + AType* t = new AType(ASTTuple()); + FOREACH(const_iterator, p, *this) { + (*p)->constrain(tenv); + t->push_back(tenv.type(*p)); + } + tenv.constrain(this, t); +} + +void +ASTClosure::constrain(TEnv& tenv) const +{ + at(1)->constrain(tenv); + at(2)->constrain(tenv); + AType* protT = tenv.type(at(1)); + AType* bodyT = tenv.type(at(2)); + tenv.constrain(this, new AType(ASTTuple( + tenv.penv.sym("Fn"), protT, bodyT, 0))); +} + +void +ASTCall::constrain(TEnv& tenv) const +{ + FOREACH(const_iterator, p, *this) + (*p)->constrain(tenv); + AType* retT = tenv.type(this); + AType* argsT = new AType(ASTTuple()); + for (size_t i = 1; i < size(); ++i) + argsT->push_back(tenv.type(at(i))); + tenv.constrain(at(0), new AType(ASTTuple( + tenv.penv.sym("Fn"), argsT, retT, NULL))); +} + +void +ASTDefinition::constrain(TEnv& tenv) const +{ + if (size() != 3) + throw Error("`def' requires exactly 2 arguments", exp.loc); + if (!dynamic_cast<const ASTSymbol*>(at(1))) + throw Error("`def' name is not a symbol", exp.loc); + FOREACH(const_iterator, p, *this) + (*p)->constrain(tenv); + AType* tvar = tenv.type(this); + tenv.constrain(at(1), tvar); + tenv.constrain(at(2), tvar); +} + +void +ASTIf::constrain(TEnv& tenv) const +{ + FOREACH(const_iterator, p, *this) + (*p)->constrain(tenv); + AType* tvar = tenv.type(this); + tenv.constrain(at(1), tenv.named("Bool")); + tenv.constrain(at(2), tvar); + tenv.constrain(at(3), tvar); +} + +void +ASTConsCall::constrain(TEnv& tenv) const +{ + AType* t = new AType(ASTTuple(tenv.penv.sym("Pair"), 0)); + for (size_t i = 1; i < size(); ++i) { + at(i)->constrain(tenv); + t->push_back(tenv.type(at(i))); + } + tenv.constrain(this, t); +} + +void +ASTCarCall::constrain(TEnv& tenv) const +{ + at(1)->constrain(tenv); + AType* ct = tenv.var(); + AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), ct, tenv.var(), 0)); + tenv.constrain(at(1), tt); + tenv.constrain(this, ct); +} + +void +ASTCdrCall::constrain(TEnv& tenv) const +{ + at(1)->constrain(tenv); + AType* ct = tenv.var(); + AType* tt = new AType(ASTTuple(tenv.penv.sym("Pair"), tenv.var(), ct, 0)); + tenv.constrain(at(1), tt); + tenv.constrain(this, ct); +} + +static void +substitute(ASTTuple* tup, AST* from, AST* to) +{ + if (!tup) return; + for (size_t i = 0; i < tup->size(); ++i) + if (*tup->at(i) == *from) + tup->at(i) = to; + else + substitute(dynamic_cast<ASTTuple*>(tup->at(i)), from, to); +} + +bool +ASTTuple::contains(AST* child) const +{ + if (*this == *child) return true; + FOREACH(const_iterator, p, *this) + if (**p == *child || (*p)->contains(child)) + return true; + return false; +} + +TSubst +compose(const TSubst& delta, const TSubst& gamma) // TAPL 22.1.1 +{ + TSubst r; + for (TSubst::const_iterator g = gamma.begin(); g != gamma.end(); ++g) { + TSubst::const_iterator d = delta.find(g->second); + r.insert(make_pair(g->first, ((d != delta.end()) ? d : g)->second)); + } + for (TSubst::const_iterator d = delta.begin(); d != delta.end(); ++d) { + if (gamma.find(d->first) == gamma.end()) + r.insert(*d); + } + return r; +} + +void +substConstraints(TEnv::Constraints& constraints, AType* s, AType* t) +{ + for (TEnv::Constraints::iterator c = constraints.begin(); c != constraints.end();) { + TEnv::Constraints::iterator next = c; ++next; + if (*c->first == *s) c->first = t; + if (*c->second == *s) c->second = t; + substitute(c->first, s, t); + substitute(c->second, s, t); + c = next; + } +} + +TSubst +TEnv::unify(const Constraints& constraints) // TAPL 22.4 +{ + if (constraints.empty()) return TSubst(); + AType* s = constraints.begin()->first; + AType* t = constraints.begin()->second; + Constraints cp = constraints; + cp.erase(cp.begin()); + + if (*s == *t) { + return unify(cp); + } else if (s->var() && !t->contains(s)) { + substConstraints(cp, s, t); + return compose(unify(cp), TSubst(s, t)); + } else if (t->var() && !s->contains(t)) { + substConstraints(cp, t, s); + return compose(unify(cp), TSubst(t, s)); + } else if (s->size() == t->size()) { + for (size_t i = 0; i < s->size(); ++i) { + AType* si = dynamic_cast<AType*>(s->at(i)); + AType* ti = dynamic_cast<AType*>(t->at(i)); + if (si && ti) + cp.push_back(make_pair(si, ti)); + } + return unify(cp); + } else { + throw Error("Type unification failed"); + } +} + +void +TEnv::apply(const TSubst& substs) +{ + FOREACH(TSubst::const_iterator, s, substs) + FOREACH(Frame::iterator, t, front()) + if (*t->second == *s->first) + t->second = s->second; + else + substitute(t->second, s->first, s->second); +} |