From a27509178871f447bd93e995797611c728c8e2b8 Mon Sep 17 00:00:00 2001 From: David Robillard Date: Thu, 29 Jan 2009 15:57:29 +0000 Subject: Pairs. Kinda. git-svn-id: http://svn.drobilla.net/resp/tuplr@38 ad02d1e2-f140-0410-9f75-f8b11f17cedd --- tuplr.cpp | 161 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 141 insertions(+), 20 deletions(-) diff --git a/tuplr.cpp b/tuplr.cpp index ada3073..ff30496 100644 --- a/tuplr.cpp +++ b/tuplr.cpp @@ -192,13 +192,13 @@ struct ASTTuple : public AST, public vector { 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) { return NULL; } + Value* compile(CEnv& cenv) { throw SyntaxError("Tuple compiled"); } }; /// Type Expression, e.g. "(Int)" or "(Fn ((Int)) (Float))" struct AType : public ASTTuple { AType(const ASTTuple& t) : ASTTuple(t), var(false), ctype(0) {} - AType(unsigned i) : var(true), ctype(0), id(i) {} + AType(unsigned i) : var(true), id(i), ctype(0) {} AType(ASTSymbol* n, const Type* t) : var(false), ctype(t) { push_back(n); } @@ -230,9 +230,22 @@ struct AType : public ASTTuple { return ASTTuple::operator==(rhs); return false; } + const Type* type() { + if (at(0)->str() == "Pair") { + vector types; + for (size_t i = 1; i < size(); ++i) { + assert(dynamic_cast(at(i))); + types.push_back(((AType*)at(i))->type()); + } + return PointerType::get(StructType::get(types, false), 0); + } else { + return ctype; + } + }; bool var; - const Type* ctype; unsigned id; +private: + const Type* ctype; }; /// Closure (first-class function with captured lexical bindings) @@ -256,7 +269,7 @@ struct ASTCall : public ASTTuple { Value* compile(CEnv& cenv); }; -/// Definition special form, e.g. "(def x 2)" or "(def (next y) (+ y 1))" +/// Definition special form, e.g. "(def x 2)" struct ASTDefinition : public ASTCall { ASTDefinition(const ASTTuple& t) : ASTCall(t) {} void constrain(TEnv& tenv) const; @@ -280,6 +293,27 @@ struct ASTPrimitive : public ASTCall { unsigned arg; }; +/// Cons special form, e.g. "(cons 1 2)" +struct ASTConsCall : public ASTCall { + ASTConsCall(const ASTTuple& t) : ASTCall(t) {} + void constrain(TEnv& tenv) const; + Value* compile(CEnv& cenv); +}; + +/// Car special form, e.g. "(car p)" +struct ASTCarCall : public ASTCall { + ASTCarCall(const ASTTuple& t) : ASTCall(t) {} + void constrain(TEnv& tenv) const; + Value* compile(CEnv& cenv); +}; + +/// Cdr special form, e.g. "(cdr p)" +struct ASTCdrCall : public ASTCall { + ASTCdrCall(const ASTTuple& t) : ASTCall(t) {} + void constrain(TEnv& tenv) const; + Value* compile(CEnv& cenv); +}; + /*************************************************************************** * Parser - S-Expressions (SExp) -> AST Nodes (AST) * @@ -366,6 +400,18 @@ parseFn(PEnv& penv, const SExp::List& c, UD) parseExpression(penv, *a++)); } +static AST* +parseCons(PEnv& penv, const SExp::List& c, UD) + { return new ASTConsCall(pmap(penv, c)); } + +static AST* +parseCar(PEnv& penv, const SExp::List& c, UD) + { return new ASTCarCall(pmap(penv, c)); } + +static AST* +parseCdr(PEnv& penv, const SExp::List& c, UD) + { return new ASTCdrCall(pmap(penv, c)); } + /*************************************************************************** * Generic Lexical Environment * @@ -511,6 +557,37 @@ ASTPrimitive::constrain(TEnv& tenv) const } } +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) { @@ -577,7 +654,8 @@ TEnv::unify(const Constraints& constraints) // TAPL 22.4 } else if (t->var && !s->contains(t)) { substConstraints(cp, t, s); return compose(unify(cp), TSubst(t, s)); - } else if (s->isForm("Fn") && t->isForm("Fn")) { + } else if ((s->isForm("Fn") && t->isForm("Fn")) + || (s->isForm("Pair") && t->isForm("Pair"))) { AType* s1 = dynamic_cast(s->at(1)); AType* t1 = dynamic_cast(t->at(1)); AType* s2 = dynamic_cast(s->at(2)); @@ -666,9 +744,9 @@ compileFunction(CEnv& cenv, const std::string& name, ASTTuple& prot, const Type* vector cprot; for (size_t i = 0; i < prot.size(); ++i) { - const AType* at = cenv.tenv.type(prot.at(i)); - if (!at->ctype || at->var) throw CompileError("Parameter is untyped"); - cprot.push_back(at->ctype); + AType* at = cenv.tenv.type(prot.at(i)); + if (!at->type() || at->var) throw CompileError("Parameter is untyped"); + cprot.push_back(at->type()); } if (!retT) throw CompileError("Return is untyped"); @@ -693,7 +771,7 @@ ASTSymbol::compile(CEnv& cenv) { AST** c = cenv.code.ref(this); if (!c) throw SyntaxError((string("Undefined symbol: ") + cppstr).c_str()); - return cenv.vals.def(this, cenv.compile(*c)); + return cenv.compile(*c); } void @@ -709,7 +787,7 @@ ASTClosure::lift(CEnv& cenv) cenv.push(); // Write function declaration - Function* f = compileFunction(cenv, cenv.gensym("_fn"), *prot, cenv.tenv.type(at(2))->ctype); + Function* f = compileFunction(cenv, cenv.gensym("_fn"), *prot, cenv.tenv.type(at(2))->type()); BasicBlock* bb = BasicBlock::Create("entry", f); cenv.builder.SetInsertPoint(bb); @@ -784,7 +862,7 @@ ASTCall::compile(CEnv& cenv) vector params(size() - 1); for (size_t i = 1; i < size(); ++i) - params[i-1] = cenv.compile(at(i)); + params[i-1] = cenv.compile(at(i)); return cenv.builder.CreateCall(f, params.begin(), params.end(), "calltmp"); } @@ -842,7 +920,7 @@ ASTIf::compile(CEnv& cenv) // Emit merge block (Phi node) parent->getBasicBlockList().push_back(mergeBB); cenv.builder.SetInsertPoint(mergeBB); - PHINode* pn = cenv.builder.CreatePHI(cenv.tenv.type(this)->ctype, "ifval"); + 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); @@ -886,6 +964,43 @@ ASTPrimitive::compile(CEnv& cenv) throw CompileError("Unknown primitive"); } +Value* +ASTConsCall::compile(CEnv& cenv) +{ + vector types; + for (size_t i = 1; i < size(); ++i) + types.push_back(cenv.tenv.type(at(i))->type()); + + StructType* t = StructType::get(types, false); + Value* sP = cenv.builder.CreateMalloc(t); + Value* s = cenv.builder.CreateGEP(sP, ConstantInt::get(Type::Int32Ty, 0), "pair"); + Value* carP = cenv.builder.CreateStructGEP(s, 0, "car"); + Value* cdrP = cenv.builder.CreateStructGEP(s, 1, "cdr"); + cenv.builder.CreateStore(cenv.compile(at(1)), carP); + cenv.builder.CreateStore(cenv.compile(at(2)), cdrP); + return sP; +} + +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); +} + /*************************************************************************** * REPL * @@ -896,9 +1011,12 @@ main() { #define PRIM(O, A) PEnv::Parser(parsePrim, Op(Instruction:: O, A)) PEnv penv; - penv.reg("fn", PEnv::Parser(parseFn, Op())); - penv.reg("if", PEnv::Parser(parseIf, Op())); - penv.reg("def", PEnv::Parser(parseDef, Op())); + penv.reg("fn", PEnv::Parser(parseFn, Op())); + penv.reg("if", PEnv::Parser(parseIf, Op())); + penv.reg("def", PEnv::Parser(parseDef, Op())); + penv.reg("cons", PEnv::Parser(parseCons, Op())); + penv.reg("car", PEnv::Parser(parseCar, Op())); + penv.reg("cdr", PEnv::Parser(parseCdr, Op())); penv.reg("+", PRIM(Add, 0)); penv.reg("-", PRIM(Sub, 0)); penv.reg("*", PRIM(Mul, 0)); @@ -934,6 +1052,7 @@ main() try { AST* body = parseExpression(penv, exp); // Parse input body->constrain(cenv.tenv); // Constrain types + cenv.tenv.solve(); // Solve and apply type constraints AType* bodyT = cenv.tenv.type(body); @@ -942,10 +1061,10 @@ main() body->lift(cenv); - if (bodyT->ctype) { + if (bodyT->type()) { // Create anonymous function to insert code into. ASTTuple* prot = new ASTTuple(); - Function* f = compileFunction(cenv, cenv.gensym("_repl"), *prot, bodyT->ctype); + Function* f = compileFunction(cenv, cenv.gensym("_repl"), *prot, bodyT->type()); BasicBlock* bb = BasicBlock::Create("entry", f); cenv.builder.SetInsertPoint(bb); try { @@ -957,12 +1076,14 @@ main() throw e; } void* fp = engine->getPointerToFunction(f); - if (bodyT->ctype == Type::Int32Ty) + if (bodyT->type() == Type::Int32Ty) std::cout << "; " << ((int32_t (*)())fp)(); - else if (bodyT->ctype == Type::FloatTy) + else if (bodyT->type() == Type::FloatTy) std::cout << "; " << ((float (*)())fp)(); - else if (bodyT->ctype == Type::Int1Ty) + else if (bodyT->type() == Type::Int1Ty) std::cout << "; " << ((bool (*)())fp)(); + else + std::cout << "; " << ((void* (*)())fp)(); } else { Value* val = cenv.compile(body); std::cout << "; " << val; -- cgit v1.2.1