diff options
Diffstat (limited to 'tuplr.cpp')
| -rw-r--r-- | tuplr.cpp | 1187 |
1 files changed, 6 insertions, 1181 deletions
@@ -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; -} - |