From 2d925912c38c2557ac853fb1b6de5fd6e5d4c5b5 Mon Sep 17 00:00:00 2001 From: David Robillard Date: Sun, 28 Jun 2009 23:29:27 +0000 Subject: Move code into src directory. git-svn-id: http://svn.drobilla.net/resp/tuplr@160 ad02d1e2-f140-0410-9f75-f8b11f17cedd --- Makefile | 4 +- cps.cpp | 136 ------------ gc.cpp | 92 -------- gclib.cpp | 41 ---- llvm.cpp | 544 ----------------------------------------------- src/cps.cpp | 136 ++++++++++++ src/gc.cpp | 92 ++++++++ src/gclib.cpp | 41 ++++ src/llvm.cpp | 544 +++++++++++++++++++++++++++++++++++++++++++++++ src/tuplr.cpp | 471 +++++++++++++++++++++++++++++++++++++++++ src/tuplr.hpp | 654 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/typing.cpp | 232 ++++++++++++++++++++ src/unify.cpp | 94 +++++++++ src/write.cpp | 97 +++++++++ tuplr.cpp | 471 ----------------------------------------- tuplr.hpp | 654 --------------------------------------------------------- typing.cpp | 232 -------------------- unify.cpp | 94 --------- write.cpp | 97 --------- 19 files changed, 2363 insertions(+), 2363 deletions(-) delete mode 100644 cps.cpp delete mode 100644 gc.cpp delete mode 100644 gclib.cpp delete mode 100644 llvm.cpp create mode 100644 src/cps.cpp create mode 100644 src/gc.cpp create mode 100644 src/gclib.cpp create mode 100644 src/llvm.cpp create mode 100644 src/tuplr.cpp create mode 100644 src/tuplr.hpp create mode 100644 src/typing.cpp create mode 100644 src/unify.cpp create mode 100644 src/write.cpp delete mode 100644 tuplr.cpp delete mode 100644 tuplr.hpp delete mode 100644 typing.cpp delete mode 100644 unify.cpp delete mode 100644 write.cpp diff --git a/Makefile b/Makefile index fbd1201..6eff895 100644 --- a/Makefile +++ b/Makefile @@ -23,10 +23,10 @@ OBJECTS = \ build/tuplr: $(OBJECTS) g++ -o $@ $^ $(LDFLAGS) -build/%.o: %.cpp tuplr.hpp +build/%.o: src/%.cpp src/tuplr.hpp g++ $(CXXFLAGS) -o $@ -c $< -build/%.so: %.cpp tuplr.hpp +build/%.so: src/%.cpp src/tuplr.hpp g++ -fPIC -dPIC -shared $(CXXFLAGS) -o $@ $< clean: diff --git a/cps.cpp b/cps.cpp deleted file mode 100644 index 8df11c2..0000000 --- a/cps.cpp +++ /dev/null @@ -1,136 +0,0 @@ -/* Tuplr Type Inferencing - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include -#include "tuplr.hpp" - -/*************************************************************************** - * CPS Conversion * - ***************************************************************************/ - -/** (cps x cont) => (cont x) */ -AST* -AST::cps(TEnv& tenv, AST* cont) -{ - return tup(loc, cont, this, 0); -} - -/** (cps (fn (a ...) body) cont) => (cont (fn (a ... k) (cps body k))*/ -AST* -AFn::cps(TEnv& tenv, AST* cont) -{ - ATuple* copyProt = new ATuple(prot()->loc, *prot()); - ASymbol* contArg = tenv.penv.gensym("_k"); - copyProt->push_back(contArg); - AFn* copy = tup(loc, tenv.penv.sym("fn"), copyProt, 0); - const_iterator p = begin(); - ++(++p); - for (; p != end(); ++p) - copy->push_back((*p)->cps(tenv, contArg)); - return tup(loc, cont, copy, 0); -} - -AST* -APrimitive::cps(TEnv& tenv, AST* cont) -{ - return value() ? tup(loc, cont, this, 0) : ACall::cps(tenv, cont); -} - -/** (cps (f a b ...)) => (a (fn (x) (b (fn (y) ... (cont (f x y ...)) */ -AST* -ACall::cps(TEnv& tenv, AST* cont) -{ - std::vector< std::pair > funcs; - AFn* fn = NULL; - ASymbol* arg = NULL; - - // Make a continuation for each element (operator and arguments) - // Argument evaluation continuations are not themselves in CPS. - // Each makes a tail call to the next, and the last makes a tail - // call to the continuation of this call - ssize_t firstFn = -1; - for (size_t i = 0; i < size(); ++i) { - if (!at(i)->to()) { - funcs.push_back(make_pair((AFn*)NULL, at(i))); - } else { - arg = tenv.penv.gensym("a"); - - if (firstFn == -1) - firstFn = i; - - AFn* thisFn = tup(loc, tenv.penv.sym("fn"), - tup(at(i)->loc, arg, 0), - 0); - - if (fn) - fn->push_back(at(i)->cps(tenv, thisFn)); - - funcs.push_back(make_pair(thisFn, arg)); - fn = thisFn; - } - } - - if (firstFn != -1) { - // Call this call's callee in the last argument evaluator - ACall* call = tup(loc, 0); - assert(funcs.size() == size()); - for (size_t i = 0; i < funcs.size(); ++i) - call->push_back(funcs[i].second); - - assert(fn); - fn->push_back(call->cps(tenv, cont)); - return at(firstFn)->cps(tenv, funcs[firstFn].first); - } else { - assert(at(0)->value()); - ACall* ret = tup(loc, 0); - for (size_t i = 0; i < size(); ++i) - ret->push_back(at(i)); - if (!to()) - ret->push_back(cont); - return ret; - } -} - -/** (cps (def x y)) => (y (fn (x) (cont))) */ -AST* -ADef::cps(TEnv& tenv, AST* cont) -{ - AST* val = at(2)->cps(tenv, cont); - ACall* valCall = val->to(); - assert(valCall); - return tup(loc, tenv.penv.sym("def"), sym(), valCall->at(1), 0); -} - -/** (cps (if c t ... e)) => */ -AST* -AIf::cps(TEnv& tenv, AST* cont) -{ - ASymbol* argSym = tenv.penv.gensym("c"); - if (at(1)->value()) { - return tup(loc, tenv.penv.sym("if"), at(1), - at(2)->cps(tenv, cont), - at(3)->cps(tenv, cont), 0); - } else { - AFn* contFn = tup(loc, tenv.penv.sym("fn"), - tup(at(1)->loc, argSym, tenv.penv.gensym("_k"), 0), - tup(loc, tenv.penv.sym("if"), argSym, - at(2)->cps(tenv, cont), - at(3)->cps(tenv, cont), 0)); - return at(1)->cps(tenv, contFn); - } -} - diff --git a/gc.cpp b/gc.cpp deleted file mode 100644 index 3964324..0000000 --- a/gc.cpp +++ /dev/null @@ -1,92 +0,0 @@ -/* Tuplr: A programming language - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include -#include -#include -#include "tuplr.hpp" - -using namespace std; - -void* -GC::alloc(size_t size, GC::Tag tag) -{ - size += (4 - (size % 4)); // Align to 32-bits - size += sizeof(Object::Header); - void* ret = malloc(size); - ((Object::Header*)ret)->mark = 0; - ((Object::Header*)ret)->tag = tag; - ret = (char*)ret + sizeof(Object::Header); - _heap.push_back((Object*)ret); - return ret; -} - -inline void -mark(const Object* obj) -{ - if (!obj || obj->marked()) - return; - - obj->mark(true); - switch (obj->tag()) { - case GC::TAG_FRAME: - break; - case GC::TAG_AST: - const ATuple* tup = dynamic_cast((AST*)obj); - if (tup) - FOREACH(ATuple::const_iterator, i, *tup) - mark(*i); - break; - } -} - -void -GC::collect(const Roots& roots) -{ - //const size_t oldSize = _heap.size(); - - for (Roots::const_iterator i = roots.begin(); i != roots.end(); ++i) - mark(*i); - - for (Heap::iterator i = _heap.begin(); i != _heap.end();) { - assert((*i)->tag() == GC::TAG_AST || (*i)->tag() == GC::TAG_FRAME); - Heap::iterator next = i; - ++next; - - if ((*i)->marked()) { - (*i)->mark(false); - } else { - switch ((*i)->tag()) { - case GC::TAG_FRAME: - free((char*)(*i) - sizeof(Object::Header)); - _heap.erase(i); - break; - case GC::TAG_AST: - AST* ast = (AST*)*i; - if (!ast->to()) { // FIXME - (ast)->~AST(); - free((char*)(*i) - sizeof(Object::Header)); - _heap.erase(i); - } - break; - } - } - i = next; - } - //std::cerr << "[GC] Collect " << oldSize << " => " << _heap.size() << endl; -} - diff --git a/gclib.cpp b/gclib.cpp deleted file mode 100644 index 8c9f140..0000000 --- a/gclib.cpp +++ /dev/null @@ -1,41 +0,0 @@ -/* Tuplr: A programming language - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include "tuplr.hpp" -#include -#include -#include - -extern "C" { - -void* -tuplr_gc_allocate(unsigned size, uint8_t tag) -{ - static const size_t COLLECT_SIZE = 8 * 1024 * 1024; // 8 MiB - - static size_t allocated = 0; - allocated += size; - if (allocated > COLLECT_SIZE) { - Object::pool.collect(Object::pool.roots()); - allocated = 0; - } - - return Object::pool.alloc(size, (GC::Tag)tag); -} - -} - diff --git a/llvm.cpp b/llvm.cpp deleted file mode 100644 index b5e397e..0000000 --- a/llvm.cpp +++ /dev/null @@ -1,544 +0,0 @@ -/* Tuplr: A programming language - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include -#include -#include -#include "llvm/Analysis/Verifier.h" -#include "llvm/Assembly/AsmAnnotationWriter.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" - -using namespace llvm; -using namespace std; -using boost::format; - -static inline Value* llVal(CValue v) { return static_cast(v); } -static inline Function* llFunc(CFunction f) { return static_cast(f); } - -static const Type* -llType(const AType* t) -{ - if (t->kind == AType::PRIM) { - if (t->at(0)->str() == "Nothing") return Type::VoidTy; - if (t->at(0)->str() == "Bool") return Type::Int1Ty; - if (t->at(0)->str() == "Int") return Type::Int32Ty; - if (t->at(0)->str() == "Float") return Type::FloatTy; - throw Error(t->loc, string("Unknown primitive type `") + t->str() + "'"); - /*} else if (t->kind == AType::EXPR && t->at(0)->str() == "Fn") { - AType* retT = t->at(2)->as(); - if (!llType(retT)) - return NULL; - - vector cprot; - const ATuple* prot = t->at(1)->to(); - for (size_t i = 0; i < prot->size(); ++i) { - AType* at = prot->at(i)->to(); - const Type* lt = llType(at); - if (lt) - cprot.push_back(lt); - else - return NULL; - } - - FunctionType* fT = FunctionType::get(llType(retT), cprot, false); - return PointerType::get(fT, 0); - */ - } - return NULL; // non-primitive type -} - - -/*************************************************************************** - * LLVM Engine * - ***************************************************************************/ - -struct LLVMEngine : public Engine { - LLVMEngine() - : module(new Module("tuplr")) - , engine(ExecutionEngine::create(module)) - , emp(module) - , opt(&emp) - { - // Set up optimiser pipeline - const TargetData* target = 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 - - // Declare host provided allocation primitive - std::vector argsT(1, Type::Int32Ty); // unsigned size - argsT.push_back(Type::Int8Ty); // char tag - FunctionType* funcT = FunctionType::get(PointerType::get(Type::Int8Ty, 0), argsT, false); - alloc = Function::Create(funcT, Function::ExternalLinkage, - "tuplr_gc_allocate", module); - } - - CFunction startFunction(CEnv& cenv, - const std::string& name, const AType* retT, const ATuple& argsT, - const vector argNames) - { - Function::LinkageTypes linkage = Function::ExternalLinkage; - - vector cprot; - for (size_t i = 0; i < argsT.size(); ++i) { - AType* at = argsT.at(i)->as(); - THROW_IF(!llType(at), Cursor(), string("parameter has non-concrete type ") - + at->str()) - cprot.push_back(llType(at)); - } - - THROW_IF(!llType(retT), Cursor(), "return has non-concrete type"); - FunctionType* fT = FunctionType::get(llType(retT), cprot, false); - Function* f = Function::Create(fT, linkage, name, module); - - // Note f->getName() may be different from name - // however LLVM chooses to mangle is fine, we keep a pointer - - // Set argument names in generated code - Function::arg_iterator a = f->arg_begin(); - if (!argNames.empty()) - for (size_t i = 0; i != argsT.size(); ++a, ++i) - a->setName(argNames.at(i)); - - BasicBlock* bb = BasicBlock::Create("entry", f); - builder.SetInsertPoint(bb); - - return f; - } - - void finishFunction(CEnv& cenv, CFunction f, const AType* retT, CValue ret) { - if (retT->concrete()) { - Value* retVal = llVal(ret); - builder.CreateRet(retVal); - } else { - builder.CreateRetVoid(); - } - - /*std::cerr << "MODULE {" << endl; - module->dump(); - std::cerr << "}" << endl;*/ - verifyFunction(*static_cast(f)); - if (cenv.args.find("-g") == cenv.args.end()) - opt.run(*static_cast(f)); - } - - void eraseFunction(CEnv& cenv, CFunction f) { - if (f) - llFunc(f)->eraseFromParent(); - } - - void writeModule(CEnv& cenv, std::ostream& os) { - AssemblyAnnotationWriter writer; - module->print(os, &writer); - } - - const string call(CEnv& cenv, CFunction f, AType* retT) { - void* fp = engine->getPointerToFunction(llFunc(f)); - const Type* t = llType(retT); - THROW_IF(!fp, Cursor(), "unable to get function pointer"); - THROW_IF(!t, Cursor(), "function with non-concrete return type called"); - - std::stringstream ss; - if (t == Type::Int32Ty) - ss << ((int32_t (*)())fp)(); - else if (t == Type::FloatTy) - ss << showpoint << ((float (*)())fp)(); - else if (t == Type::Int1Ty) - ss << (((bool (*)())fp)() ? "#t" : "#f"); - else - ss << ((void* (*)())fp)(); - return ss.str(); - } - - Module* module; - ExecutionEngine* engine; - IRBuilder<> builder; - CFunction alloc; - ExistingModuleProvider emp; - FunctionPassManager opt; -}; - -static LLVMEngine* -llEngine(CEnv& cenv) -{ - return reinterpret_cast(cenv.engine()); -} - -/// Shared library entry point -Engine* -tuplr_new_engine() -{ - return new LLVMEngine(); -} - -/// Shared library entry point -void -tuplr_free_engine(Engine* engine) -{ - delete (LLVMEngine*)engine; -} - - -/*************************************************************************** - * Code Generation * - ***************************************************************************/ - -#define LITERAL(CT, NAME, COMPILED) \ -template<> CValue ALiteral::compile(CEnv& cenv) { return (COMPILED); } \ -template<> void \ -ALiteral::constrain(TEnv& tenv, Constraints& c) const { \ - c.constrain(tenv, 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)) - -CValue -ASymbol::compile(CEnv& cenv) -{ - return cenv.vals.ref(this); -} - -void -AFn::lift(CEnv& cenv) -{ - cenv.push(); - for (const_iterator p = prot()->begin(); p != prot()->end(); ++p) - cenv.def((*p)->as(), *p, NULL, NULL); - - // Lift body - for (size_t i = 2; i < size(); ++i) - at(i)->lift(cenv); - - cenv.pop(); - - AType* type = cenv.type(this); - if (impls.find(type) || !type->concrete()) - return; - - AType* protT = type->at(1)->as(); - liftCall(cenv, *protT); -} - -void -AFn::liftCall(CEnv& cenv, const AType& argsT) -{ - TEnv::GenericTypes::const_iterator gt = cenv.tenv.genericTypes.find(this); - assert(gt != cenv.tenv.genericTypes.end()); - AType* genericType = new AType(*gt->second); - AType* thisType = genericType; - Subst argsSubst; - - if (!genericType->concrete()) { - // Build substitution to apply to generic type - assert(argsT.size() == prot()->size()); - ATuple* genericProtT = gt->second->at(1)->as(); - for (size_t i = 0; i < argsT.size(); ++i) { - const AType* genericArgT = genericProtT->at(i)->to(); - AType* callArgT = argsT.at(i)->to(); - assert(genericArgT); - assert(callArgT); - if (callArgT->kind == AType::EXPR) { - assert(genericArgT->kind == AType::EXPR); - assert(callArgT->size() == genericArgT->size()); - for (size_t i = 0; i < callArgT->size(); ++i) { - AType* gT = genericArgT->at(i)->to(); - AType* aT = callArgT->at(i)->to(); - if (gT && aT) - argsSubst.add(gT, aT); - } - } else { - argsSubst.add(genericArgT, callArgT); - } - } - - // Apply substitution to get concrete type for this call - thisType = argsSubst.apply(genericType)->as(); - THROW_IF(!thisType->concrete(), loc, - string("unable to resolve concrete type for function :: ") - + thisType->str() + "\n" + this->str()); - } - - Object::pool.addRoot(thisType); - if (impls.find(thisType)) - return; - - ATuple* protT = thisType->at(1)->as(); - - vector argNames; - for (size_t i = 0; i < prot()->size(); ++i) { - argNames.push_back(prot()->at(i)->str()); - } - - // Write function declaration - const string name = (this->name == "") ? cenv.penv.gensymstr("_fn") : this->name; - Function* f = llFunc(cenv.engine()->startFunction(cenv, name, - thisType->at(thisType->size()-1)->to(), - *protT, argNames)); - - cenv.push(); - Subst oldSubst = cenv.tsubst; - cenv.tsubst = Subst::compose(cenv.tsubst, Subst::compose(argsSubst, subst)); - -//#define EXPLICIT_STACK_FRAMES 1 - -#ifdef EXPLICIT_STACK_FRAMES - vector types; - types.push_back(Type::Int8Ty); - types.push_back(Type::Int8Ty); - size_t s = 16; // stack frame size in bits -#endif - - // Bind argument values in CEnv - vector args; - const_iterator p = prot()->begin(); - size_t i = 0; - for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++p, ++i) { - AType* t = protT->at(i)->as(); - const Type* lt = llType(t); - THROW_IF(!lt, loc, "untyped parameter\n"); - cenv.def((*p)->as(), *p, t, &*a); -#ifdef EXPLICIT_STACK_FRAMES - types.push_back(lt); - s += std::max(lt->getPrimitiveSizeInBits(), unsigned(8)); -#endif - } - - -#ifdef EXPLICIT_STACK_FRAMES - IRBuilder<> builder = llEngine(cenv)->builder; - - // Scan out definitions - for (size_t i = 0; i < size(); ++i) { - ADef* def = at(i)->to(); - if (def) { - const Type* lt = llType(cenv.type(def->at(2))); - THROW_IF(!lt, loc, "untyped definition\n"); - types.push_back(lt); - s += std::max(lt->getPrimitiveSizeInBits(), unsigned(8)); - } - } - - // Create stack frame - StructType* frameT = StructType::get(types, false); - Value* tag = ConstantInt::get(Type::Int8Ty, GC::TAG_FRAME); - Value* frameSize = ConstantInt::get(Type::Int32Ty, s / 8); - Value* frame = builder.CreateCall2(llVal(cenv.alloc), frameSize, tag, "frame"); - Value* framePtr = builder.CreateBitCast(frame, PointerType::get(frameT, 0)); - - // Bind parameter values in stack frame - i = 2; - for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++i) { - Value* v = builder.CreateStructGEP(framePtr, i, "arg"); - builder.CreateStore(&*a, v); - } -#endif - - // Write function body - try { - // Define value first for recursion - cenv.precompile(this, f); - impls.push_back(make_pair(thisType, f)); - CValue retVal = NULL; - for (size_t i = 2; i < size(); ++i) - retVal = cenv.compile(at(i)); - cenv.engine()->finishFunction(cenv, f, cenv.type(at(size()-1)), retVal); - } catch (Error& e) { - f->eraseFromParent(); // Error reading body, remove function - cenv.pop(); - throw e; - } - cenv.tsubst = oldSubst; - cenv.pop(); -} - -CValue -AFn::compile(CEnv& cenv) -{ - return NULL; -} - -void -ACall::lift(CEnv& cenv) -{ - AFn* c = cenv.tenv.resolve(at(0))->to(); - AType argsT(loc, NULL); - - // Lift arguments - for (size_t i = 1; i < size(); ++i) { - at(i)->lift(cenv); - argsT.push_back(cenv.type(at(i))); - } - - if (!c) return; // Primitive - - if (c->prot()->size() < size() - 1) - throw Error(loc, (format("too many arguments to function `%1%'") % at(0)->str()).str()); - if (c->prot()->size() > size() - 1) - throw Error(loc, (format("too few arguments to function `%1%'") % at(0)->str()).str()); - - c->liftCall(cenv, argsT); // Lift called closure -} - -CValue -ACall::compile(CEnv& cenv) -{ - AFn* c = cenv.tenv.resolve(at(0))->to(); - - if (!c) return NULL; // Primitive - - AType protT(loc, NULL); - vector types; - for (size_t i = 1; i < size(); ++i) { - protT.push_back(cenv.type(at(i))); - types.push_back(llType(cenv.type(at(i)))); - } - - TEnv::GenericTypes::const_iterator gt = cenv.tenv.genericTypes.find(c); - assert(gt != cenv.tenv.genericTypes.end()); - AType fnT(loc, cenv.penv.sym("Fn"), &protT, cenv.type(this), 0); - Function* f = (Function*)c->impls.find(&fnT); - THROW_IF(!f, loc, (format("callee failed to compile for type %1%") % fnT.str()).str()); - - vector params(size() - 1); - for (size_t i = 0; i < types.size(); ++i) - params[i] = llVal(cenv.compile(at(i+1))); - - return llEngine(cenv)->builder.CreateCall(f, params.begin(), params.end()); -} - -void -ADef::lift(CEnv& cenv) -{ - // Define stub first for recursion - cenv.def(sym(), at(2), cenv.type(at(2)), NULL); - AFn* c = at(2)->to(); - if (c) - c->name = sym()->str(); - at(2)->lift(cenv); -} - -CValue -ADef::compile(CEnv& cenv) -{ - // Define stub first for recursion - cenv.def(sym(), at(2), cenv.type(at(2)), NULL); - CValue val = cenv.compile(at(size() - 1)); - cenv.vals.def(sym(), val); - return val; -} - -CValue -AIf::compile(CEnv& cenv) -{ - typedef vector< pair > Branches; - Function* parent = llEngine(cenv)->builder.GetInsertBlock()->getParent(); - BasicBlock* mergeBB = BasicBlock::Create("endif"); - BasicBlock* nextBB = NULL; - Branches branches; - for (size_t i = 1; i < size() - 1; i += 2) { - Value* condV = llVal(cenv.compile(at(i))); - BasicBlock* thenBB = BasicBlock::Create((format("then%1%") % ((i+1)/2)).str()); - - nextBB = BasicBlock::Create((format("else%1%") % ((i+1)/2)).str()); - - llEngine(cenv)->builder.CreateCondBr(condV, thenBB, nextBB); - - // Emit then block for this condition - parent->getBasicBlockList().push_back(thenBB); - llEngine(cenv)->builder.SetInsertPoint(thenBB); - Value* thenV = llVal(cenv.compile(at(i+1))); - llEngine(cenv)->builder.CreateBr(mergeBB); - branches.push_back(make_pair(thenV, llEngine(cenv)->builder.GetInsertBlock())); - - parent->getBasicBlockList().push_back(nextBB); - llEngine(cenv)->builder.SetInsertPoint(nextBB); - } - - // Emit final else block - llEngine(cenv)->builder.SetInsertPoint(nextBB); - Value* elseV = llVal(cenv.compile(at(size() - 1))); - llEngine(cenv)->builder.CreateBr(mergeBB); - branches.push_back(make_pair(elseV, llEngine(cenv)->builder.GetInsertBlock())); - - // Emit merge block (Phi node) - parent->getBasicBlockList().push_back(mergeBB); - llEngine(cenv)->builder.SetInsertPoint(mergeBB); - PHINode* pn = llEngine(cenv)->builder.CreatePHI(llType(cenv.type(this)), "ifval"); - - FOREACH(Branches::iterator, i, branches) - pn->addIncoming(i->first, i->second); - - return pn; -} - -CValue -APrimitive::compile(CEnv& cenv) -{ - Value* a = llVal(cenv.compile(at(1))); - Value* b = llVal(cenv.compile(at(2))); - bool isFloat = cenv.type(at(1))->str() == "Float"; - const string n = at(0)->to()->str(); - - // Binary arithmetic operations - Instruction::BinaryOps op = (Instruction::BinaryOps)0; - if (n == "+") op = Instruction::Add; - if (n == "-") op = Instruction::Sub; - if (n == "*") op = Instruction::Mul; - if (n == "and") op = Instruction::And; - if (n == "or") op = Instruction::Or; - if (n == "xor") op = Instruction::Xor; - if (n == "/") op = isFloat ? Instruction::FDiv : Instruction::SDiv; - if (n == "%") op = isFloat ? Instruction::FRem : Instruction::SRem; - if (op != 0) { - Value* val = llEngine(cenv)->builder.CreateBinOp(op, a, b); - for (size_t i = 3; i < size(); ++i) - val = llEngine(cenv)->builder.CreateBinOp(op, val, llVal(cenv.compile(at(i)))); - return val; - } - - // Comparison operations - CmpInst::Predicate pred = (CmpInst::Predicate)0; - if (n == "=") pred = isFloat ? CmpInst::FCMP_OEQ : CmpInst::ICMP_EQ ; - if (n == "!=") pred = isFloat ? CmpInst::FCMP_ONE : CmpInst::ICMP_NE ; - if (n == ">") pred = isFloat ? CmpInst::FCMP_OGT : CmpInst::ICMP_SGT; - if (n == ">=") pred = isFloat ? CmpInst::FCMP_OGE : CmpInst::ICMP_SGE; - if (n == "<") pred = isFloat ? CmpInst::FCMP_OLT : CmpInst::ICMP_SLT; - if (n == "<=") pred = isFloat ? CmpInst::FCMP_OLE : CmpInst::ICMP_SLE; - if (pred != 0) { - if (isFloat) - return llEngine(cenv)->builder.CreateFCmp(pred, a, b); - else - return llEngine(cenv)->builder.CreateICmp(pred, a, b); - } - - throw Error(loc, "unknown primitive"); -} - diff --git a/src/cps.cpp b/src/cps.cpp new file mode 100644 index 0000000..8df11c2 --- /dev/null +++ b/src/cps.cpp @@ -0,0 +1,136 @@ +/* Tuplr Type Inferencing + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include +#include "tuplr.hpp" + +/*************************************************************************** + * CPS Conversion * + ***************************************************************************/ + +/** (cps x cont) => (cont x) */ +AST* +AST::cps(TEnv& tenv, AST* cont) +{ + return tup(loc, cont, this, 0); +} + +/** (cps (fn (a ...) body) cont) => (cont (fn (a ... k) (cps body k))*/ +AST* +AFn::cps(TEnv& tenv, AST* cont) +{ + ATuple* copyProt = new ATuple(prot()->loc, *prot()); + ASymbol* contArg = tenv.penv.gensym("_k"); + copyProt->push_back(contArg); + AFn* copy = tup(loc, tenv.penv.sym("fn"), copyProt, 0); + const_iterator p = begin(); + ++(++p); + for (; p != end(); ++p) + copy->push_back((*p)->cps(tenv, contArg)); + return tup(loc, cont, copy, 0); +} + +AST* +APrimitive::cps(TEnv& tenv, AST* cont) +{ + return value() ? tup(loc, cont, this, 0) : ACall::cps(tenv, cont); +} + +/** (cps (f a b ...)) => (a (fn (x) (b (fn (y) ... (cont (f x y ...)) */ +AST* +ACall::cps(TEnv& tenv, AST* cont) +{ + std::vector< std::pair > funcs; + AFn* fn = NULL; + ASymbol* arg = NULL; + + // Make a continuation for each element (operator and arguments) + // Argument evaluation continuations are not themselves in CPS. + // Each makes a tail call to the next, and the last makes a tail + // call to the continuation of this call + ssize_t firstFn = -1; + for (size_t i = 0; i < size(); ++i) { + if (!at(i)->to()) { + funcs.push_back(make_pair((AFn*)NULL, at(i))); + } else { + arg = tenv.penv.gensym("a"); + + if (firstFn == -1) + firstFn = i; + + AFn* thisFn = tup(loc, tenv.penv.sym("fn"), + tup(at(i)->loc, arg, 0), + 0); + + if (fn) + fn->push_back(at(i)->cps(tenv, thisFn)); + + funcs.push_back(make_pair(thisFn, arg)); + fn = thisFn; + } + } + + if (firstFn != -1) { + // Call this call's callee in the last argument evaluator + ACall* call = tup(loc, 0); + assert(funcs.size() == size()); + for (size_t i = 0; i < funcs.size(); ++i) + call->push_back(funcs[i].second); + + assert(fn); + fn->push_back(call->cps(tenv, cont)); + return at(firstFn)->cps(tenv, funcs[firstFn].first); + } else { + assert(at(0)->value()); + ACall* ret = tup(loc, 0); + for (size_t i = 0; i < size(); ++i) + ret->push_back(at(i)); + if (!to()) + ret->push_back(cont); + return ret; + } +} + +/** (cps (def x y)) => (y (fn (x) (cont))) */ +AST* +ADef::cps(TEnv& tenv, AST* cont) +{ + AST* val = at(2)->cps(tenv, cont); + ACall* valCall = val->to(); + assert(valCall); + return tup(loc, tenv.penv.sym("def"), sym(), valCall->at(1), 0); +} + +/** (cps (if c t ... e)) => */ +AST* +AIf::cps(TEnv& tenv, AST* cont) +{ + ASymbol* argSym = tenv.penv.gensym("c"); + if (at(1)->value()) { + return tup(loc, tenv.penv.sym("if"), at(1), + at(2)->cps(tenv, cont), + at(3)->cps(tenv, cont), 0); + } else { + AFn* contFn = tup(loc, tenv.penv.sym("fn"), + tup(at(1)->loc, argSym, tenv.penv.gensym("_k"), 0), + tup(loc, tenv.penv.sym("if"), argSym, + at(2)->cps(tenv, cont), + at(3)->cps(tenv, cont), 0)); + return at(1)->cps(tenv, contFn); + } +} + diff --git a/src/gc.cpp b/src/gc.cpp new file mode 100644 index 0000000..3964324 --- /dev/null +++ b/src/gc.cpp @@ -0,0 +1,92 @@ +/* Tuplr: A programming language + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include +#include +#include +#include "tuplr.hpp" + +using namespace std; + +void* +GC::alloc(size_t size, GC::Tag tag) +{ + size += (4 - (size % 4)); // Align to 32-bits + size += sizeof(Object::Header); + void* ret = malloc(size); + ((Object::Header*)ret)->mark = 0; + ((Object::Header*)ret)->tag = tag; + ret = (char*)ret + sizeof(Object::Header); + _heap.push_back((Object*)ret); + return ret; +} + +inline void +mark(const Object* obj) +{ + if (!obj || obj->marked()) + return; + + obj->mark(true); + switch (obj->tag()) { + case GC::TAG_FRAME: + break; + case GC::TAG_AST: + const ATuple* tup = dynamic_cast((AST*)obj); + if (tup) + FOREACH(ATuple::const_iterator, i, *tup) + mark(*i); + break; + } +} + +void +GC::collect(const Roots& roots) +{ + //const size_t oldSize = _heap.size(); + + for (Roots::const_iterator i = roots.begin(); i != roots.end(); ++i) + mark(*i); + + for (Heap::iterator i = _heap.begin(); i != _heap.end();) { + assert((*i)->tag() == GC::TAG_AST || (*i)->tag() == GC::TAG_FRAME); + Heap::iterator next = i; + ++next; + + if ((*i)->marked()) { + (*i)->mark(false); + } else { + switch ((*i)->tag()) { + case GC::TAG_FRAME: + free((char*)(*i) - sizeof(Object::Header)); + _heap.erase(i); + break; + case GC::TAG_AST: + AST* ast = (AST*)*i; + if (!ast->to()) { // FIXME + (ast)->~AST(); + free((char*)(*i) - sizeof(Object::Header)); + _heap.erase(i); + } + break; + } + } + i = next; + } + //std::cerr << "[GC] Collect " << oldSize << " => " << _heap.size() << endl; +} + diff --git a/src/gclib.cpp b/src/gclib.cpp new file mode 100644 index 0000000..8c9f140 --- /dev/null +++ b/src/gclib.cpp @@ -0,0 +1,41 @@ +/* Tuplr: A programming language + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include "tuplr.hpp" +#include +#include +#include + +extern "C" { + +void* +tuplr_gc_allocate(unsigned size, uint8_t tag) +{ + static const size_t COLLECT_SIZE = 8 * 1024 * 1024; // 8 MiB + + static size_t allocated = 0; + allocated += size; + if (allocated > COLLECT_SIZE) { + Object::pool.collect(Object::pool.roots()); + allocated = 0; + } + + return Object::pool.alloc(size, (GC::Tag)tag); +} + +} + diff --git a/src/llvm.cpp b/src/llvm.cpp new file mode 100644 index 0000000..b5e397e --- /dev/null +++ b/src/llvm.cpp @@ -0,0 +1,544 @@ +/* Tuplr: A programming language + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include +#include +#include +#include "llvm/Analysis/Verifier.h" +#include "llvm/Assembly/AsmAnnotationWriter.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" + +using namespace llvm; +using namespace std; +using boost::format; + +static inline Value* llVal(CValue v) { return static_cast(v); } +static inline Function* llFunc(CFunction f) { return static_cast(f); } + +static const Type* +llType(const AType* t) +{ + if (t->kind == AType::PRIM) { + if (t->at(0)->str() == "Nothing") return Type::VoidTy; + if (t->at(0)->str() == "Bool") return Type::Int1Ty; + if (t->at(0)->str() == "Int") return Type::Int32Ty; + if (t->at(0)->str() == "Float") return Type::FloatTy; + throw Error(t->loc, string("Unknown primitive type `") + t->str() + "'"); + /*} else if (t->kind == AType::EXPR && t->at(0)->str() == "Fn") { + AType* retT = t->at(2)->as(); + if (!llType(retT)) + return NULL; + + vector cprot; + const ATuple* prot = t->at(1)->to(); + for (size_t i = 0; i < prot->size(); ++i) { + AType* at = prot->at(i)->to(); + const Type* lt = llType(at); + if (lt) + cprot.push_back(lt); + else + return NULL; + } + + FunctionType* fT = FunctionType::get(llType(retT), cprot, false); + return PointerType::get(fT, 0); + */ + } + return NULL; // non-primitive type +} + + +/*************************************************************************** + * LLVM Engine * + ***************************************************************************/ + +struct LLVMEngine : public Engine { + LLVMEngine() + : module(new Module("tuplr")) + , engine(ExecutionEngine::create(module)) + , emp(module) + , opt(&emp) + { + // Set up optimiser pipeline + const TargetData* target = 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 + + // Declare host provided allocation primitive + std::vector argsT(1, Type::Int32Ty); // unsigned size + argsT.push_back(Type::Int8Ty); // char tag + FunctionType* funcT = FunctionType::get(PointerType::get(Type::Int8Ty, 0), argsT, false); + alloc = Function::Create(funcT, Function::ExternalLinkage, + "tuplr_gc_allocate", module); + } + + CFunction startFunction(CEnv& cenv, + const std::string& name, const AType* retT, const ATuple& argsT, + const vector argNames) + { + Function::LinkageTypes linkage = Function::ExternalLinkage; + + vector cprot; + for (size_t i = 0; i < argsT.size(); ++i) { + AType* at = argsT.at(i)->as(); + THROW_IF(!llType(at), Cursor(), string("parameter has non-concrete type ") + + at->str()) + cprot.push_back(llType(at)); + } + + THROW_IF(!llType(retT), Cursor(), "return has non-concrete type"); + FunctionType* fT = FunctionType::get(llType(retT), cprot, false); + Function* f = Function::Create(fT, linkage, name, module); + + // Note f->getName() may be different from name + // however LLVM chooses to mangle is fine, we keep a pointer + + // Set argument names in generated code + Function::arg_iterator a = f->arg_begin(); + if (!argNames.empty()) + for (size_t i = 0; i != argsT.size(); ++a, ++i) + a->setName(argNames.at(i)); + + BasicBlock* bb = BasicBlock::Create("entry", f); + builder.SetInsertPoint(bb); + + return f; + } + + void finishFunction(CEnv& cenv, CFunction f, const AType* retT, CValue ret) { + if (retT->concrete()) { + Value* retVal = llVal(ret); + builder.CreateRet(retVal); + } else { + builder.CreateRetVoid(); + } + + /*std::cerr << "MODULE {" << endl; + module->dump(); + std::cerr << "}" << endl;*/ + verifyFunction(*static_cast(f)); + if (cenv.args.find("-g") == cenv.args.end()) + opt.run(*static_cast(f)); + } + + void eraseFunction(CEnv& cenv, CFunction f) { + if (f) + llFunc(f)->eraseFromParent(); + } + + void writeModule(CEnv& cenv, std::ostream& os) { + AssemblyAnnotationWriter writer; + module->print(os, &writer); + } + + const string call(CEnv& cenv, CFunction f, AType* retT) { + void* fp = engine->getPointerToFunction(llFunc(f)); + const Type* t = llType(retT); + THROW_IF(!fp, Cursor(), "unable to get function pointer"); + THROW_IF(!t, Cursor(), "function with non-concrete return type called"); + + std::stringstream ss; + if (t == Type::Int32Ty) + ss << ((int32_t (*)())fp)(); + else if (t == Type::FloatTy) + ss << showpoint << ((float (*)())fp)(); + else if (t == Type::Int1Ty) + ss << (((bool (*)())fp)() ? "#t" : "#f"); + else + ss << ((void* (*)())fp)(); + return ss.str(); + } + + Module* module; + ExecutionEngine* engine; + IRBuilder<> builder; + CFunction alloc; + ExistingModuleProvider emp; + FunctionPassManager opt; +}; + +static LLVMEngine* +llEngine(CEnv& cenv) +{ + return reinterpret_cast(cenv.engine()); +} + +/// Shared library entry point +Engine* +tuplr_new_engine() +{ + return new LLVMEngine(); +} + +/// Shared library entry point +void +tuplr_free_engine(Engine* engine) +{ + delete (LLVMEngine*)engine; +} + + +/*************************************************************************** + * Code Generation * + ***************************************************************************/ + +#define LITERAL(CT, NAME, COMPILED) \ +template<> CValue ALiteral::compile(CEnv& cenv) { return (COMPILED); } \ +template<> void \ +ALiteral::constrain(TEnv& tenv, Constraints& c) const { \ + c.constrain(tenv, 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)) + +CValue +ASymbol::compile(CEnv& cenv) +{ + return cenv.vals.ref(this); +} + +void +AFn::lift(CEnv& cenv) +{ + cenv.push(); + for (const_iterator p = prot()->begin(); p != prot()->end(); ++p) + cenv.def((*p)->as(), *p, NULL, NULL); + + // Lift body + for (size_t i = 2; i < size(); ++i) + at(i)->lift(cenv); + + cenv.pop(); + + AType* type = cenv.type(this); + if (impls.find(type) || !type->concrete()) + return; + + AType* protT = type->at(1)->as(); + liftCall(cenv, *protT); +} + +void +AFn::liftCall(CEnv& cenv, const AType& argsT) +{ + TEnv::GenericTypes::const_iterator gt = cenv.tenv.genericTypes.find(this); + assert(gt != cenv.tenv.genericTypes.end()); + AType* genericType = new AType(*gt->second); + AType* thisType = genericType; + Subst argsSubst; + + if (!genericType->concrete()) { + // Build substitution to apply to generic type + assert(argsT.size() == prot()->size()); + ATuple* genericProtT = gt->second->at(1)->as(); + for (size_t i = 0; i < argsT.size(); ++i) { + const AType* genericArgT = genericProtT->at(i)->to(); + AType* callArgT = argsT.at(i)->to(); + assert(genericArgT); + assert(callArgT); + if (callArgT->kind == AType::EXPR) { + assert(genericArgT->kind == AType::EXPR); + assert(callArgT->size() == genericArgT->size()); + for (size_t i = 0; i < callArgT->size(); ++i) { + AType* gT = genericArgT->at(i)->to(); + AType* aT = callArgT->at(i)->to(); + if (gT && aT) + argsSubst.add(gT, aT); + } + } else { + argsSubst.add(genericArgT, callArgT); + } + } + + // Apply substitution to get concrete type for this call + thisType = argsSubst.apply(genericType)->as(); + THROW_IF(!thisType->concrete(), loc, + string("unable to resolve concrete type for function :: ") + + thisType->str() + "\n" + this->str()); + } + + Object::pool.addRoot(thisType); + if (impls.find(thisType)) + return; + + ATuple* protT = thisType->at(1)->as(); + + vector argNames; + for (size_t i = 0; i < prot()->size(); ++i) { + argNames.push_back(prot()->at(i)->str()); + } + + // Write function declaration + const string name = (this->name == "") ? cenv.penv.gensymstr("_fn") : this->name; + Function* f = llFunc(cenv.engine()->startFunction(cenv, name, + thisType->at(thisType->size()-1)->to(), + *protT, argNames)); + + cenv.push(); + Subst oldSubst = cenv.tsubst; + cenv.tsubst = Subst::compose(cenv.tsubst, Subst::compose(argsSubst, subst)); + +//#define EXPLICIT_STACK_FRAMES 1 + +#ifdef EXPLICIT_STACK_FRAMES + vector types; + types.push_back(Type::Int8Ty); + types.push_back(Type::Int8Ty); + size_t s = 16; // stack frame size in bits +#endif + + // Bind argument values in CEnv + vector args; + const_iterator p = prot()->begin(); + size_t i = 0; + for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++p, ++i) { + AType* t = protT->at(i)->as(); + const Type* lt = llType(t); + THROW_IF(!lt, loc, "untyped parameter\n"); + cenv.def((*p)->as(), *p, t, &*a); +#ifdef EXPLICIT_STACK_FRAMES + types.push_back(lt); + s += std::max(lt->getPrimitiveSizeInBits(), unsigned(8)); +#endif + } + + +#ifdef EXPLICIT_STACK_FRAMES + IRBuilder<> builder = llEngine(cenv)->builder; + + // Scan out definitions + for (size_t i = 0; i < size(); ++i) { + ADef* def = at(i)->to(); + if (def) { + const Type* lt = llType(cenv.type(def->at(2))); + THROW_IF(!lt, loc, "untyped definition\n"); + types.push_back(lt); + s += std::max(lt->getPrimitiveSizeInBits(), unsigned(8)); + } + } + + // Create stack frame + StructType* frameT = StructType::get(types, false); + Value* tag = ConstantInt::get(Type::Int8Ty, GC::TAG_FRAME); + Value* frameSize = ConstantInt::get(Type::Int32Ty, s / 8); + Value* frame = builder.CreateCall2(llVal(cenv.alloc), frameSize, tag, "frame"); + Value* framePtr = builder.CreateBitCast(frame, PointerType::get(frameT, 0)); + + // Bind parameter values in stack frame + i = 2; + for (Function::arg_iterator a = f->arg_begin(); a != f->arg_end(); ++a, ++i) { + Value* v = builder.CreateStructGEP(framePtr, i, "arg"); + builder.CreateStore(&*a, v); + } +#endif + + // Write function body + try { + // Define value first for recursion + cenv.precompile(this, f); + impls.push_back(make_pair(thisType, f)); + CValue retVal = NULL; + for (size_t i = 2; i < size(); ++i) + retVal = cenv.compile(at(i)); + cenv.engine()->finishFunction(cenv, f, cenv.type(at(size()-1)), retVal); + } catch (Error& e) { + f->eraseFromParent(); // Error reading body, remove function + cenv.pop(); + throw e; + } + cenv.tsubst = oldSubst; + cenv.pop(); +} + +CValue +AFn::compile(CEnv& cenv) +{ + return NULL; +} + +void +ACall::lift(CEnv& cenv) +{ + AFn* c = cenv.tenv.resolve(at(0))->to(); + AType argsT(loc, NULL); + + // Lift arguments + for (size_t i = 1; i < size(); ++i) { + at(i)->lift(cenv); + argsT.push_back(cenv.type(at(i))); + } + + if (!c) return; // Primitive + + if (c->prot()->size() < size() - 1) + throw Error(loc, (format("too many arguments to function `%1%'") % at(0)->str()).str()); + if (c->prot()->size() > size() - 1) + throw Error(loc, (format("too few arguments to function `%1%'") % at(0)->str()).str()); + + c->liftCall(cenv, argsT); // Lift called closure +} + +CValue +ACall::compile(CEnv& cenv) +{ + AFn* c = cenv.tenv.resolve(at(0))->to(); + + if (!c) return NULL; // Primitive + + AType protT(loc, NULL); + vector types; + for (size_t i = 1; i < size(); ++i) { + protT.push_back(cenv.type(at(i))); + types.push_back(llType(cenv.type(at(i)))); + } + + TEnv::GenericTypes::const_iterator gt = cenv.tenv.genericTypes.find(c); + assert(gt != cenv.tenv.genericTypes.end()); + AType fnT(loc, cenv.penv.sym("Fn"), &protT, cenv.type(this), 0); + Function* f = (Function*)c->impls.find(&fnT); + THROW_IF(!f, loc, (format("callee failed to compile for type %1%") % fnT.str()).str()); + + vector params(size() - 1); + for (size_t i = 0; i < types.size(); ++i) + params[i] = llVal(cenv.compile(at(i+1))); + + return llEngine(cenv)->builder.CreateCall(f, params.begin(), params.end()); +} + +void +ADef::lift(CEnv& cenv) +{ + // Define stub first for recursion + cenv.def(sym(), at(2), cenv.type(at(2)), NULL); + AFn* c = at(2)->to(); + if (c) + c->name = sym()->str(); + at(2)->lift(cenv); +} + +CValue +ADef::compile(CEnv& cenv) +{ + // Define stub first for recursion + cenv.def(sym(), at(2), cenv.type(at(2)), NULL); + CValue val = cenv.compile(at(size() - 1)); + cenv.vals.def(sym(), val); + return val; +} + +CValue +AIf::compile(CEnv& cenv) +{ + typedef vector< pair > Branches; + Function* parent = llEngine(cenv)->builder.GetInsertBlock()->getParent(); + BasicBlock* mergeBB = BasicBlock::Create("endif"); + BasicBlock* nextBB = NULL; + Branches branches; + for (size_t i = 1; i < size() - 1; i += 2) { + Value* condV = llVal(cenv.compile(at(i))); + BasicBlock* thenBB = BasicBlock::Create((format("then%1%") % ((i+1)/2)).str()); + + nextBB = BasicBlock::Create((format("else%1%") % ((i+1)/2)).str()); + + llEngine(cenv)->builder.CreateCondBr(condV, thenBB, nextBB); + + // Emit then block for this condition + parent->getBasicBlockList().push_back(thenBB); + llEngine(cenv)->builder.SetInsertPoint(thenBB); + Value* thenV = llVal(cenv.compile(at(i+1))); + llEngine(cenv)->builder.CreateBr(mergeBB); + branches.push_back(make_pair(thenV, llEngine(cenv)->builder.GetInsertBlock())); + + parent->getBasicBlockList().push_back(nextBB); + llEngine(cenv)->builder.SetInsertPoint(nextBB); + } + + // Emit final else block + llEngine(cenv)->builder.SetInsertPoint(nextBB); + Value* elseV = llVal(cenv.compile(at(size() - 1))); + llEngine(cenv)->builder.CreateBr(mergeBB); + branches.push_back(make_pair(elseV, llEngine(cenv)->builder.GetInsertBlock())); + + // Emit merge block (Phi node) + parent->getBasicBlockList().push_back(mergeBB); + llEngine(cenv)->builder.SetInsertPoint(mergeBB); + PHINode* pn = llEngine(cenv)->builder.CreatePHI(llType(cenv.type(this)), "ifval"); + + FOREACH(Branches::iterator, i, branches) + pn->addIncoming(i->first, i->second); + + return pn; +} + +CValue +APrimitive::compile(CEnv& cenv) +{ + Value* a = llVal(cenv.compile(at(1))); + Value* b = llVal(cenv.compile(at(2))); + bool isFloat = cenv.type(at(1))->str() == "Float"; + const string n = at(0)->to()->str(); + + // Binary arithmetic operations + Instruction::BinaryOps op = (Instruction::BinaryOps)0; + if (n == "+") op = Instruction::Add; + if (n == "-") op = Instruction::Sub; + if (n == "*") op = Instruction::Mul; + if (n == "and") op = Instruction::And; + if (n == "or") op = Instruction::Or; + if (n == "xor") op = Instruction::Xor; + if (n == "/") op = isFloat ? Instruction::FDiv : Instruction::SDiv; + if (n == "%") op = isFloat ? Instruction::FRem : Instruction::SRem; + if (op != 0) { + Value* val = llEngine(cenv)->builder.CreateBinOp(op, a, b); + for (size_t i = 3; i < size(); ++i) + val = llEngine(cenv)->builder.CreateBinOp(op, val, llVal(cenv.compile(at(i)))); + return val; + } + + // Comparison operations + CmpInst::Predicate pred = (CmpInst::Predicate)0; + if (n == "=") pred = isFloat ? CmpInst::FCMP_OEQ : CmpInst::ICMP_EQ ; + if (n == "!=") pred = isFloat ? CmpInst::FCMP_ONE : CmpInst::ICMP_NE ; + if (n == ">") pred = isFloat ? CmpInst::FCMP_OGT : CmpInst::ICMP_SGT; + if (n == ">=") pred = isFloat ? CmpInst::FCMP_OGE : CmpInst::ICMP_SGE; + if (n == "<") pred = isFloat ? CmpInst::FCMP_OLT : CmpInst::ICMP_SLT; + if (n == "<=") pred = isFloat ? CmpInst::FCMP_OLE : CmpInst::ICMP_SLE; + if (pred != 0) { + if (isFloat) + return llEngine(cenv)->builder.CreateFCmp(pred, a, b); + else + return llEngine(cenv)->builder.CreateICmp(pred, a, b); + } + + throw Error(loc, "unknown primitive"); +} + diff --git a/src/tuplr.cpp b/src/tuplr.cpp new file mode 100644 index 0000000..7dd3e9b --- /dev/null +++ b/src/tuplr.cpp @@ -0,0 +1,471 @@ +/* Tuplr: A programming language + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include +#include +#include +#include +#include +#include +#include "tuplr.hpp" + +using namespace std; +using boost::format; + +GC Object::pool; + +template +ostream& +operator<<(ostream& out, const Exp& exp) +{ + switch (exp.type) { + case Exp::ATOM: + out << exp.atom; + break; + case Exp::LIST: + out << "("; + for (size_t i = 0; i != exp.size(); ++i) + out << exp.at(i) << ((i != exp.size() - 1) ? " " : ""); + out << ")"; + break; + } + return out; +} + + +/*************************************************************************** + * Lexer * + ***************************************************************************/ + +inline int +readChar(Cursor& cur, istream& in) +{ + int ch = in.get(); + switch (ch) { + case '\n': ++cur.line; cur.col = 0; break; + default: ++cur.col; + } + return ch; +} + +SExp +readExpression(Cursor& cur, istream& in) +{ +#define PUSH(s, t) { if (t != "") { s.top().push_back(SExp(loc, t)); t = ""; } } +#define YIELD(s, t) { if (s.empty()) { return SExp(loc, t); } else PUSH(s, t) } + stack stk; + string tok; + Cursor loc; // start of tok + while (int c = readChar(cur, in)) { + switch (c) { + case EOF: + THROW_IF(!stk.empty(), cur, "unexpected end of file") + return SExp(cur); + case ';': + while ((c = readChar(cur, in)) != '\n') {} + case '\n': case ' ': case '\t': + if (tok != "") YIELD(stk, tok); + break; + case '"': + loc = cur; + do { tok.push_back(c); } while ((c = readChar(cur, in)) != '"'); + YIELD(stk, tok + '"'); + break; + case '(': + stk.push(SExp(cur)); + break; + case ')': + switch (stk.size()) { + case 0: + throw Error(cur, "unexpected `)'"); + case 1: + PUSH(stk, tok); + return stk.top(); + default: + PUSH(stk, tok); + SExp l = stk.top(); + stk.pop(); + stk.top().push_back(l); + } + break; + case '#': + if (in.peek() == '|') { + while (!(readChar(cur, in) == '|' && readChar(cur, in) == '#')) {} + break; + } + default: + if (tok == "") loc = cur; + tok += c; + } + } + switch (stk.size()) { + case 0: return SExp(loc, tok); + case 1: return stk.top(); + default: throw Error(cur, "missing `)'"); + } + return SExp(cur); +} + + +/*************************************************************************** + * Macro Functions * + ***************************************************************************/ + +inline SExp +macDef(PEnv& penv, const SExp& exp) +{ + THROW_IF(exp.size() < 3, exp.loc, "[MAC] `def' requires at least 2 arguments") + if (exp.at(1).type == SExp::ATOM) { + return exp; + } else { + // (def (f x) y) => (def f (fn (x) y)) + SExp argsExp(exp.loc); + for (size_t i = 1; i < exp.at(1).size(); ++i) + argsExp.push_back(exp.at(1).at(i)); + SExp fnExp(exp.at(2).loc); + fnExp.push_back(SExp(exp.at(2).loc, "fn")); + fnExp.push_back(argsExp); + for (size_t i = 2; i < exp.size(); ++i) + fnExp.push_back(exp.at(i)); + SExp ret(exp.loc); + ret.push_back(exp.at(0)); + ret.push_back(exp.at(1).at(0)); + ret.push_back(fnExp); + return ret; + } +} + + +/*************************************************************************** + * Parser Functions * + ***************************************************************************/ + +template +inline AST* +parseCall(PEnv& penv, const SExp& exp, void* arg) +{ + return new C(exp, penv.parseTuple(exp)); +} + +template +inline AST* +parseLiteral(PEnv& penv, const SExp& exp, void* arg) +{ + return new ALiteral(*reinterpret_cast(arg), exp.loc); +} + +inline AST* +parseFn(PEnv& penv, const SExp& exp, void* arg) +{ + if (exp.size() < 2) + throw Error(exp.loc, "Missing function parameters and body"); + else if (exp.size() < 3) + throw Error(exp.loc, "Missing function body"); + SExp::const_iterator a = exp.begin(); ++a; + AFn* ret = tup(exp.loc, penv.sym("fn"), new ATuple(penv.parseTuple(*a++)), 0); + while (a != exp.end()) + ret->push_back(penv.parse(*a++)); + return ret; +} + + +/*************************************************************************** + * Standard Definitions * + ***************************************************************************/ + +void +initLang(PEnv& penv, TEnv& tenv) +{ + // Types + tenv.def(penv.sym("Nothing"), make_pair((AST*)0, new AType(penv.sym("Nothing")))); + tenv.def(penv.sym("Bool"), make_pair((AST*)0, new AType(penv.sym("Bool")))); + tenv.def(penv.sym("Int"), make_pair((AST*)0, new AType(penv.sym("Int")))); + tenv.def(penv.sym("Float"), make_pair((AST*)0, new AType(penv.sym("Float")))); + + // Literals + static bool trueVal = true; + static bool falseVal = false; + penv.reg(false, "#t", PEnv::Handler(parseLiteral, &trueVal)); + penv.reg(false, "#f", PEnv::Handler(parseLiteral, &falseVal)); + + // Macros + penv.defmac("def", macDef); + + // Special forms + penv.reg(true, "fn", PEnv::Handler(parseFn)); + penv.reg(true, "if", PEnv::Handler(parseCall)); + penv.reg(true, "def", PEnv::Handler(parseCall)); + + // Numeric primitives + penv.reg(true, "+", PEnv::Handler(parseCall)); + penv.reg(true, "-", PEnv::Handler(parseCall)); + penv.reg(true, "*", PEnv::Handler(parseCall)); + penv.reg(true, "/", PEnv::Handler(parseCall)); + penv.reg(true, "%", PEnv::Handler(parseCall)); + penv.reg(true, "and", PEnv::Handler(parseCall)); + penv.reg(true, "or", PEnv::Handler(parseCall)); + penv.reg(true, "xor", PEnv::Handler(parseCall)); + penv.reg(true, "=", PEnv::Handler(parseCall)); + penv.reg(true, "!=", PEnv::Handler(parseCall)); + penv.reg(true, ">", PEnv::Handler(parseCall)); + penv.reg(true, ">=", PEnv::Handler(parseCall)); + penv.reg(true, "<", PEnv::Handler(parseCall)); + penv.reg(true, "<=", PEnv::Handler(parseCall)); +} + + +/*************************************************************************** + * EVAL/REPL * + ***************************************************************************/ + +int +eval(CEnv& cenv, const string& name, istream& is) +{ + AST* result = NULL; + AType* resultType = NULL; + list< pair > exprs; + Cursor cursor(name); + try { + while (true) { + SExp exp = readExpression(cursor, is); + if (exp.type == SExp::LIST && exp.empty()) + break; + + result = cenv.penv.parse(exp); // Parse input + Constraints c; + result->constrain(cenv.tenv, c); // Constrain types + cenv.tsubst = Subst::compose(cenv.tsubst, TEnv::unify(c)); // Solve type constraints + resultType = cenv.type(result); + result->lift(cenv); // Lift functions + exprs.push_back(make_pair(exp, result)); + + // Add definitions as GC roots + if (result->to()) + cenv.lock(result); + + // Add types in type substition as GC roots + for (Subst::iterator i = cenv.tsubst.begin(); i != cenv.tsubst.end(); ++i) { + Object::pool.addRoot(i->first); + Object::pool.addRoot(i->second); + } + } + + // Print CPS form + CValue val = NULL; + /*for (list< pair >::const_iterator i = exprs.begin(); i != exprs.end(); ++i) { + cout << "; CPS" << endl; + pprint(cout, i->second->cps(cenv.tenv, cenv.penv.sym("cont"))); + }*/ + + if (resultType->concrete()) { + // Create function for top-level of program + CFunction f = cenv.engine()->startFunction(cenv, "main", resultType, ATuple(cursor)); + + // Compile all expressions into it + for (list< pair >::const_iterator i = exprs.begin(); i != exprs.end(); ++i) + val = cenv.compile(i->second); + + // Finish and call it + cenv.engine()->finishFunction(cenv, f, resultType, val); + cenv.out << cenv.engine()->call(cenv, f, resultType); + } + cenv.out << " : " << resultType << endl; + + Object::pool.collect(Object::pool.roots()); + + if (cenv.args.find("-d") != cenv.args.end()) + cenv.engine()->writeModule(cenv, cenv.out); + + } catch (Error& e) { + cenv.err << e.what() << endl; + return 1; + } + return 0; +} + +int +repl(CEnv& cenv) +{ + while (1) { + cenv.out << "() "; + cenv.out.flush(); + Cursor cursor("(stdin)"); + + try { + SExp exp = readExpression(cursor, std::cin); + if (exp.type == SExp::LIST && exp.empty()) + break; + + AST* body = cenv.penv.parse(exp); // Parse input + Constraints c; + body->constrain(cenv.tenv, c); // Constrain types + + Subst oldSubst = cenv.tsubst; + cenv.tsubst = Subst::compose(cenv.tsubst, TEnv::unify(c)); // Solve type constraints + + AType* bodyT = cenv.type(body); + THROW_IF(!bodyT, cursor, "call to untyped body") + + body->lift(cenv); + + CFunction f = NULL; + try { + // Create anonymous function to insert code into + f = cenv.engine()->startFunction(cenv, cenv.penv.gensymstr("_repl"), bodyT, ATuple(cursor)); + CValue retVal = cenv.compile(body); + cenv.engine()->finishFunction(cenv, f, bodyT, retVal); + cenv.out << cenv.engine()->call(cenv, f, bodyT); + } catch (Error& e) { + ADef* def = body->to(); + if (def) + cenv.out << def->sym(); + else + cenv.out << "?"; + cenv.engine()->eraseFunction(cenv, f); + } + cenv.out << " : " << cenv.type(body) << endl; + + // Add definitions as GC roots + if (body->to()) + cenv.lock(body); + + Object::pool.collect(Object::pool.roots()); + + cenv.tsubst = oldSubst; + if (cenv.args.find("-d") != cenv.args.end()) + cenv.engine()->writeModule(cenv, cenv.out); + + } catch (Error& e) { + cenv.err << e.what() << endl; + } + } + return 0; +} + + +/*************************************************************************** + * MAIN * + ***************************************************************************/ + +int +print_usage(char* name, bool error) +{ + ostream& os = error ? cerr : cout; + os << "Usage: " << name << " [OPTION]... [FILE]..." << endl; + os << "Evaluate and/or compile Tuplr code" << endl; + os << endl; + os << " -h Display this help and exit" << endl; + os << " -r Enter REPL after evaluating files" << endl; + os << " -p Pretty-print input only" << endl; + os << " -g Debug (disable optimisation)" << endl; + os << " -d Dump assembly output" << endl; + os << " -e EXPRESSION Evaluate EXPRESSION" << endl; + os << " -o FILE Write output to FILE" << endl; + return error ? 1 : 0; +} + +int +main(int argc, char** argv) +{ + PEnv penv; + TEnv tenv(penv); + initLang(penv, tenv); + + Engine* engine = tuplr_new_engine(); + CEnv* cenv = new CEnv(penv, tenv, engine); + + cenv->push(); + Object::pool.lock(); + + map args; + list files; + for (int i = 1; i < argc; ++i) { + if (!strncmp(argv[i], "-h", 3)) { + return print_usage(argv[0], false); + } else if (argv[i][0] != '-') { + files.push_back(argv[i]); + } else if (!strncmp(argv[i], "-r", 3) + || !strncmp(argv[i], "-p", 3) + || !strncmp(argv[i], "-g", 3) + || !strncmp(argv[i], "-d", 3)) { + args.insert(make_pair(argv[i], "")); + } else if (i == argc-1 || argv[i+1][0] == '-') { + return print_usage(argv[0], true); + } else { + args.insert(make_pair(argv[i], argv[i+1])); + ++i; + } + } + + cenv->args = args; + + int ret = 0; + + string output; + map::const_iterator a = args.find("-o"); + if (a != args.end()) + output = a->second; + + a = args.find("-p"); + if (a != args.end()) { + ifstream is(files.front().c_str()); + if (is.good()) { + Cursor loc; + SExp exp = readExpression(loc, is); + AST* ast = penv.parse(exp); + pprint(cout, ast); + } + return 0; + } + + a = args.find("-e"); + if (a != args.end()) { + istringstream is(a->second); + ret = eval(*cenv, "(command line)", is); + } + + for (list::iterator f = files.begin(); f != files.end(); ++f) { + ifstream is(f->c_str()); + if (is.good()) { + ret = ret | eval(*cenv, *f, is); + } else { + cerr << argv[0] << ": " << *f << ": " << strerror(errno) << endl; + ++ret; + } + is.close(); + } + + if (args.find("-r") != args.end() || (files.empty() && args.find("-e") == args.end())) + ret = repl(*cenv); + + if (output != "") { + ofstream os(output.c_str()); + if (os.good()) { + cenv->engine()->writeModule(*cenv, os); + } else { + cerr << argv[0] << ": " << a->second << ": " << strerror(errno) << endl; + ++ret; + } + os.close(); + } + + delete cenv; + tuplr_free_engine(engine); + + return ret; +} + diff --git a/src/tuplr.hpp b/src/tuplr.hpp new file mode 100644 index 0000000..5275dfd --- /dev/null +++ b/src/tuplr.hpp @@ -0,0 +1,654 @@ +/* Tuplr: A programming language + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#ifndef TUPLR_HPP +#define TUPLR_HPP + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define FOREACH(IT, i, c) for (IT i = (c).begin(); i != (c).end(); ++i) +#define THROW_IF(cond, error, ...) { if (cond) throw Error(error, __VA_ARGS__); } + +using namespace std; +using boost::format; + + +/*************************************************************************** + * Basic Utility Classes * + ***************************************************************************/ + +/// Location in textual code +struct Cursor { + Cursor(const string& n="", unsigned l=1, unsigned c=0) : name(n), line(l), col(c) {} + operator bool() const { return !(line == 1 && col == 0); } + string str() const { return (format("%1%:%2%:%3%") % name % line % col).str(); } + string name; + unsigned line; + unsigned col; +}; + +/// Compiler error +struct Error { + Error(Cursor c, const string& m) : loc(c), msg(m) {} + const string what() const { return (loc ? loc.str() + ": " : "") + "error: " + msg; } + Cursor loc; + string msg; +}; + +/// Expression ::= Atom | (SubExp*) +template +struct Exp : public std::vector< Exp > { + Exp(Cursor c) : type(LIST), loc(c) {} + Exp(Cursor c, const Atom& a) : type(ATOM), loc(c), atom(a) {} + enum { ATOM, LIST } type; + Cursor loc; + Atom atom; +}; + +template +extern ostream& operator<<(ostream& out, const Exp& exp); + +/// Lexical Address +struct LAddr { + LAddr(unsigned u=0, unsigned o=0) : up(u), over(o) {} + operator bool() const { return !(up == 0 && over == 0); } + unsigned up, over; +}; + +/// Generic Lexical Environment +template +struct Env : public list< vector< pair > > { + typedef vector< pair > Frame; + Env() : list(1) {} + virtual void push(Frame f=Frame()) { list::push_front(f); } + virtual void pop() { assert(!this->empty()); list::pop_front(); } + const V& def(const K& k, const V& v) { + for (typename Frame::iterator b = this->begin()->begin(); b != this->begin()->end(); ++b) + if (b->first == k) + return (b->second = v); + this->front().push_back(make_pair(k, v)); + return v; + } + V* ref(const K& key) { + for (typename Env::iterator f = this->begin(); f != this->end(); ++f) + for (typename Frame::iterator b = f->begin(); b != f->end(); ++b) + if (b->first == key) + return &b->second; + return NULL; + } + LAddr lookup(const K& key) const { + unsigned up = 0; + for (typename Env::const_iterator f = this->begin(); f != this->end(); ++f, ++up) + for (unsigned over = 0; over < f->size(); ++over) + if ((*f)[over].first == key) + return LAddr(up + 1, over + 1); + return LAddr(); + } + V& deref(LAddr addr) { + assert(addr); + typename Env::iterator f = this->begin(); + for (unsigned u = 1; u < addr.up; ++u, ++f) { assert(f != this->end()); } + assert(f->size() > addr.over - 1); + return (*f)[addr.over - 1].second; + } +}; + + +/*************************************************************************** + * Lexer: Text (istream) -> S-Expressions (SExp) * + ***************************************************************************/ + +typedef Exp SExp; ///< Textual S-Expression + +SExp readExpression(Cursor& cur, std::istream& in); + + +/*************************************************************************** + * Backend Types * + ***************************************************************************/ + +typedef void* CValue; ///< Compiled value (opaque) +typedef void* CFunction; ///< Compiled function (opaque) + + +/*************************************************************************** + * Garbage Collector * + ***************************************************************************/ + +struct Object; ///< Object (AST nodes and runtime data) + +struct GC { + enum Tag { + TAG_AST = 2, ///< Abstract syntax tree node + TAG_FRAME = 4 ///< Stack frame + }; + typedef std::list Roots; + typedef std::list Heap; + void* alloc(size_t size, Tag tag); + void collect(const Roots& roots); + void addRoot(const Object* obj) { if (obj) _roots.push_back(obj); } + void lock() { _roots.insert(_roots.end(), _heap.begin(), _heap.end()); } + const Roots& roots() const { return _roots; } +private: + Heap _heap; + Roots _roots; +}; + +/// Dynamic (garbage-collected) object +struct Object { + struct Header { + uint8_t mark; + uint8_t tag; + }; + + /// Always allocated with pool.alloc, so this - sizeof(Header) is a valid Header*. + inline Header* header() const { return (Header*)((char*)this - sizeof(Header)); } + + inline bool marked() const { return header()->mark != 0; } + inline void mark(bool b) const { header()->mark = 1; } + inline GC::Tag tag() const { return (GC::Tag)header()->tag; } + + static void* operator new(size_t size) { return pool.alloc(size, GC::TAG_AST); } + static void operator delete(void* ptr) {} + static GC pool; +}; + + +/*************************************************************************** + * Abstract Syntax Tree * + ***************************************************************************/ + +struct Constraint; ///< Type Constraint +struct TEnv; ///< Type-Time Environment +struct Constraints; ///< Type Constraints +struct Subst; ///< Type substitutions +struct CEnv; ///< Compile-Time Environment + +struct AST; +extern ostream& operator<<(ostream& out, const AST* ast); + +/// Base class for all AST nodes +struct AST : public Object { + AST(Cursor c=Cursor()) : loc(c) {} + virtual ~AST() {} + virtual bool value() const { return true; } + virtual bool operator==(const AST& o) const = 0; + virtual bool contains(const AST* child) const { return false; } + virtual void constrain(TEnv& tenv, Constraints& c) const {} + virtual AST* cps(TEnv& tenv, AST* cont); + virtual void lift(CEnv& cenv) {} + virtual CValue compile(CEnv& cenv) = 0; + string str() const { ostringstream ss; ss << this; return ss.str(); } + template T to() { return dynamic_cast(this); } + template T to() const { return dynamic_cast(this); } + template T as() { + T t = dynamic_cast(this); + if (!t) throw Error(loc, "internal error: bad cast"); + return t; + } + Cursor loc; +}; + +template +static T* tup(Cursor c, AST* ast, ...) +{ + va_list args; + va_start(args, ast); + T* ret = new T(c, ast, args); + va_end(args); + return ret; +} + +/// Literal value +template +struct ALiteral : public AST { + ALiteral(VT v, Cursor c) : AST(c), val(v) {} + bool operator==(const AST& rhs) const { + const ALiteral* r = rhs.to*>(); + return (r && (val == r->val)); + } + void constrain(TEnv& tenv, Constraints& c) const; + CValue compile(CEnv& cenv); + const VT val; +}; + +/// Symbol, e.g. "a" +struct ASymbol : public AST { + bool operator==(const AST& rhs) const { return this == &rhs; } + void constrain(TEnv& tenv, Constraints& c) const; + CValue compile(CEnv& cenv); + mutable LAddr addr; + const string cppstr; +private: + friend class PEnv; + ASymbol(const string& s, Cursor c) : AST(c), cppstr(s) {} +}; + +/// Tuple (heterogeneous sequence of fixed length), e.g. "(a b c)" +struct ATuple : public AST, public vector { + ATuple(Cursor c, const vector& v=vector()) : AST(c), vector(v) {} + ATuple(Cursor c, AST* ast, va_list args) : AST(c) { + if (!ast) return; + push_back(ast); + for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*)) + push_back(a); + } + bool value() const { return false; } + bool operator==(const AST& rhs) const { + const ATuple* rt = rhs.to(); + if (!rt || rt->size() != size()) return false; + const_iterator l = begin(); + FOREACH(const_iterator, r, *rt) + if (!(*(*l++) == *(*r))) + return false; + return true; + } + bool contains(AST* child) const { + if (*this == *child) return true; + FOREACH(const_iterator, p, *this) + if (**p == *child || (*p)->contains(child)) + return true; + return false; + } + void constrain(TEnv& tenv, Constraints& c) const; + void lift(CEnv& cenv) { FOREACH(iterator, t, *this) (*t)->lift(cenv); } + + CValue compile(CEnv& cenv) { throw Error(loc, "tuple compiled"); } +}; + +/// Type Expression, e.g. "Int", "(Fn (Int Int) Float)" +struct AType : public ATuple { + AType(ASymbol* s) : ATuple(s->loc), kind(PRIM), id(0) { push_back(s); } + AType(Cursor c, unsigned i, LAddr a) : ATuple(c), kind(VAR), id(i) {} + AType(Cursor c, AST* ast, ...) : ATuple(c), kind(EXPR), id(0) { + if (!ast) return; + va_list args; + va_start(args, ast); + push_back(ast); + for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*)) + push_back(a); + va_end(args); + } + AType(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args), kind(EXPR), id(0) {} + CValue compile(CEnv& cenv) { return NULL; } + bool var() const { return kind == VAR; } + bool concrete() const { + switch (kind) { + case VAR: return false; + case PRIM: return at(0)->str() != "Nothing"; + case EXPR: + FOREACH(const_iterator, t, *this) { + AType* kid = (*t)->to(); + if (kid && !kid->concrete()) + return false; + } + } + return true; + } + bool operator==(const AST& rhs) const { + const AType* rt = rhs.to(); + if (!rt || 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 ATuple::operator==(rhs); + } + return false; // never reached + } + enum { VAR, PRIM, EXPR } kind; + unsigned id; +}; + +/// Type substitution +struct Subst : public list< pair > { + Subst(AType* s=0, AType* t=0) { if (s && t) { assert(s != t); push_back(make_pair(s, t)); } } + static Subst compose(const Subst& delta, const Subst& gamma); + void add(const AType* from, AType* to) { push_back(make_pair(from, to)); } + const_iterator find(const AType* t) const { + for (const_iterator j = begin(); j != end(); ++j) + if (*j->first == *t) + return j; + return end(); + } + AST* apply(AST* ast) const { + AType* in = ast->to(); + if (!in) return ast; + if (in->kind == AType::EXPR) { + AType* out = tup(in->loc, NULL); + for (size_t i = 0; i < in->size(); ++i) + out->push_back(apply(in->at(i))); + return out; + } else { + const_iterator i = find(in); + if (i != end()) { + AST* out = i->second; + AType* outT = out->to(); + if (outT && outT->kind == AType::EXPR && !outT->concrete()) + out = apply(out); + return out; + } else { + return in; + } + } + } +}; + +inline ostream& operator<<(ostream& out, const Subst& s) { + for (Subst::const_iterator i = s.begin(); i != s.end(); ++i) + out << i->first << " => " << i->second << endl; + return out; +} + +/// Fn (first-class function with captured lexical bindings) +struct AFn : public ATuple { + AFn(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args) {} + bool operator==(const AST& rhs) const { return this == &rhs; } + void constrain(TEnv& tenv, Constraints& c) const; + AST* cps(TEnv& tenv, AST* cont); + void lift(CEnv& cenv); + void liftCall(CEnv& cenv, const AType& argsT); + CValue compile(CEnv& cenv); + ATuple* prot() const { return at(1)->to(); } + /// System level implementations of this (polymorphic) fn + struct Impls : public list< pair > { + CFunction find(AType* type) const { + for (const_iterator f = begin(); f != end(); ++f) + if (*f->first == *type) + return f->second; + return NULL; + } + }; + Impls impls; + mutable Subst subst; + string name; +}; + +/// Function call/application, e.g. "(func arg1 arg2)" +struct ACall : public ATuple { + ACall(const SExp& e, const ATuple& t) : ATuple(e.loc, t) {} + ACall(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args) {} + void constrain(TEnv& tenv, Constraints& c) const; + AST* cps(TEnv& tenv, AST* cont); + void lift(CEnv& cenv); + CValue compile(CEnv& cenv); +}; + +/// Definition special form, e.g. "(def x 2)" +struct ADef : public ACall { + ADef(const SExp& e, const ATuple& t) : ACall(e, t) {} + ADef(Cursor c, AST* ast, va_list args) : ACall(c, ast, args) {} + ASymbol* sym() const { + ASymbol* sym = at(1)->to(); + if (!sym) { + ATuple* tup = at(1)->to(); + if (tup && !tup->empty()) + return tup->at(0)->to(); + } + return sym; + } + void constrain(TEnv& tenv, Constraints& c) const; + AST* cps(TEnv& tenv, AST* cont); + void lift(CEnv& cenv); + CValue compile(CEnv& cenv); +}; + +/// Conditional special form, e.g. "(if cond thenexp elseexp)" +struct AIf : public ACall { + AIf(const SExp& e, const ATuple& t) : ACall(e, t) {} + AIf(Cursor c, AST* ast, va_list args) : ACall(c, ast, args) {} + void constrain(TEnv& tenv, Constraints& c) const; + AST* cps(TEnv& tenv, AST* cont); + CValue compile(CEnv& cenv); +}; + +/// Primitive (builtin arithmetic function), e.g. "(+ 2 3)" +struct APrimitive : public ACall { + APrimitive(const SExp& e, const ATuple& t) : ACall(e, t) {} + bool value() const { + for (size_t i = 1; i < size(); ++i) + if (!at(i)->value()) + return false;; + return true; + } + void constrain(TEnv& tenv, Constraints& c) const; + AST* cps(TEnv& tenv, AST* cont); + CValue compile(CEnv& cenv); +}; + + +/*************************************************************************** + * Parser: S-Expressions (SExp) -> AST Nodes (AST) * + ***************************************************************************/ + +/// Parse Time Environment (really just a symbol table) +struct PEnv : private map { + PEnv() : symID(0) {} + typedef AST* (*PF)(PEnv&, const SExp&, void*); ///< Parse Function + typedef SExp (*MF)(PEnv&, const SExp&); ///< Macro Function + struct Handler { Handler(PF f, void* a=0) : func(f), arg(a) {} PF func; void* arg; }; + map aHandlers; ///< Atom parse functions + map lHandlers; ///< List parse functions + map macros; ///< Macro functions + void reg(bool list, const string& s, const Handler& h) { + (list ? lHandlers : aHandlers).insert(make_pair(sym(s)->str(), h)); + } + const Handler* handler(bool list, const string& s) const { + const map& handlers = list ? lHandlers : aHandlers; + map::const_iterator i = handlers.find(s); + return (i != handlers.end()) ? &i->second : NULL; + } + void defmac(const string& s, const MF f) { + macros.insert(make_pair(s, f)); + } + MF mac(const string& s) const { + map::const_iterator i = macros.find(s); + return (i != macros.end()) ? i->second : NULL; + } + string gensymstr(const char* s="_") { return (format("%s%d") % s % symID++).str(); } + ASymbol* gensym(const char* s="_") { return sym(gensymstr(s)); } + ASymbol* sym(const string& s, Cursor c=Cursor()) { + const const_iterator i = find(s); + if (i != end()) { + return i->second; + } else { + ASymbol* sym = new ASymbol(s, c); + insert(make_pair(s, sym)); + return sym; + } + } + ATuple parseTuple(const SExp& e) { + ATuple ret(e.loc, vector(e.size())); + size_t n = 0; + FOREACH(SExp::const_iterator, i, e) + ret[n++] = parse(*i); + return ret; + } + AST* parse(const SExp& exp) { + if (exp.type == SExp::LIST) { + if (exp.empty()) throw Error(exp.loc, "call to empty list"); + if (exp.front().type == SExp::ATOM) { + MF mf = mac(exp.front().atom); + SExp expanded = (mf ? mf(*this, exp) : exp); + + const PEnv::Handler* h = handler(true, expanded.front().atom); + if (h) + return h->func(*this, expanded, h->arg); + } + return new ACall(exp, parseTuple(exp)); // Parse as regular call + } else if (isdigit(exp.atom[0])) { + if (exp.atom.find('.') == string::npos) + return new ALiteral(strtol(exp.atom.c_str(), NULL, 10), exp.loc); + else + return new ALiteral(strtod(exp.atom.c_str(), NULL), exp.loc); + } else { + const PEnv::Handler* h = handler(false, exp.atom); + if (h) + return h->func(*this, exp, h->arg); + } + return sym(exp.atom, exp.loc); + } + unsigned symID; +}; + + +/*************************************************************************** + * Typing * + ***************************************************************************/ + +struct Constraint : public pair { + Constraint(AType* a, AType* b, Cursor c) : pair(a, b), loc(c) {} + Cursor loc; +}; + +struct Constraints : public list { + void constrain(TEnv& tenv, const AST* o, AType* t); +}; + +inline ostream& operator<<(ostream& out, const Constraints& c) { + for (Constraints::const_iterator i = c.begin(); i != c.end(); ++i) + out << i->first << " : " << i->second << endl; + return out; +} + +/// Type-Time Environment +struct TEnv : public Env< const ASymbol*, pair > { + TEnv(PEnv& p) : penv(p), varID(1) {} + AType* fresh(const ASymbol* sym) { + assert(sym); + AType* ret = new AType(sym->loc, varID++, LAddr()); + def(sym, make_pair((AST*)NULL, ret)); + return ret; + } + AType* var(const AST* ast=0) { + const ASymbol* sym = ast->to(); + if (sym) + return deref(lookup(sym)).second; + + Vars::iterator v = vars.find(ast); + if (v != vars.end()) + return v->second; + + AType* ret = new AType(ast ? ast->loc : Cursor(), varID++, LAddr()); + if (ast) + vars[ast] = ret; + + return ret; + } + AType* named(const string& name) { + return ref(penv.sym(name))->second; + } + AST* resolve(AST* ast) { + ASymbol* sym = ast->to(); + return (sym && sym->addr) ? ref(sym)->first : ast; + } + + static Subst unify(const Constraints& c); + + typedef map Vars; + typedef map GenericTypes; + Vars vars; + GenericTypes genericTypes; + PEnv& penv; + unsigned varID; +}; + + +/*************************************************************************** + * Code Generation * + ***************************************************************************/ + +struct Engine { + virtual CFunction startFunction(CEnv& cenv, const std::string& name, + const AType* retT, const ATuple& argsT, + const vector argNames=vector()) = 0; + + virtual void finishFunction(CEnv& cenv, CFunction f, const AType* retT, CValue ret) = 0; + virtual void eraseFunction(CEnv& cenv, CFunction f) = 0; + virtual void writeModule(CEnv& cenv, std::ostream& os) = 0; + + virtual const string call(CEnv& cenv, CFunction f, AType* retT) = 0; +}; + +Engine* tuplr_new_engine(); +void tuplr_free_engine(Engine* engine); + +/// Compile-Time Environment +struct CEnv { + CEnv(PEnv& p, TEnv& t, Engine* e, ostream& os=std::cout, ostream& es=std::cerr) + : out(os), err(es), penv(p), tenv(t), _engine(e) + {} + + ~CEnv() { Object::pool.collect(GC::Roots()); } + + typedef Env Vals; + + Engine* engine() { return _engine; } + void push() { tenv.push(); vals.push(); } + void pop() { tenv.pop(); vals.pop(); } + void precompile(AST* obj, CValue value) { vals.def(obj, value); } + CValue compile(AST* obj) { + CValue* v = vals.ref(obj); + return (v && *v) ? *v : vals.def(obj, obj->compile(*this)); + } + void lock(AST* ast) { Object::pool.addRoot(ast); Object::pool.addRoot(type(ast)); } + AType* type(AST* ast, const Subst& subst = Subst()) const { + ASymbol* sym = ast->to(); + if (sym) + return sym->addr ? tenv.deref(sym->addr).second : NULL; + return tsubst.apply(subst.apply(tenv.vars[ast]))->to(); + } + void def(ASymbol* sym, AST* c, AType* t, CValue v) { + tenv.def(sym, make_pair(c, t)); + vals.def(sym, v); + } + + ostream& out; + ostream& err; + PEnv& penv; + TEnv& tenv; + Vals vals; + + Subst tsubst; + + map args; + +private: + Engine* _engine; +}; + + +/*************************************************************************** + * EVAL/REPL/MAIN * + ***************************************************************************/ + +void pprint(std::ostream& out, const AST* ast); +void initLang(PEnv& penv, TEnv& tenv); +int eval(CEnv& cenv, const string& name, istream& is); +int repl(CEnv& cenv); + +#endif // TUPLR_HPP + diff --git a/src/typing.cpp b/src/typing.cpp new file mode 100644 index 0000000..5791fdc --- /dev/null +++ b/src/typing.cpp @@ -0,0 +1,232 @@ +/* Tuplr Type Inferencing + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include +#include "tuplr.hpp" + +void +Constraints::constrain(TEnv& tenv, const AST* o, AType* t) +{ + assert(!o->to()); + push_back(Constraint(tenv.var(o), t, o->loc)); +} + + +/*************************************************************************** + * AST Type Constraints * + ***************************************************************************/ + +void +ASymbol::constrain(TEnv& tenv, Constraints& c) const +{ + addr = tenv.lookup(this); + if (!addr) + throw Error(loc, (format("undefined symbol `%1%'") % cppstr).str()); + c.push_back(Constraint(tenv.var(this), tenv.deref(addr).second, loc)); +} + +void +ATuple::constrain(TEnv& tenv, Constraints& c) const +{ + AType* t = tup(loc, NULL); + FOREACH(const_iterator, p, *this) { + (*p)->constrain(tenv, c); + t->push_back(tenv.var(*p)); + } + c.push_back(Constraint(tenv.var(this), t, loc)); +} + +void +AFn::constrain(TEnv& tenv, Constraints& c) const +{ + const AType* genericType; + TEnv::GenericTypes::const_iterator gt = tenv.genericTypes.find(this); + if (gt != tenv.genericTypes.end()) { + genericType = gt->second; + } else { + set defined; + TEnv::Frame frame; + + // Add parameters to environment frame + for (size_t i = 0; i < prot()->size(); ++i) { + ASymbol* sym = prot()->at(i)->to(); + if (!sym) + throw Error(prot()->at(i)->loc, "parameter name is not a symbol"); + if (defined.find(sym) != defined.end()) + throw Error(sym->loc, (format("duplicate parameter `%1%'") % sym->str()).str()); + defined.insert(sym); + frame.push_back(make_pair(sym, make_pair((AST*)NULL, (AType*)NULL))); + } + + // Add internal definitions to environment frame + size_t e = 2; + for (; e < size(); ++e) { + AST* exp = at(e); + ADef* def = exp->to(); + if (def) { + ASymbol* sym = def->sym(); + if (defined.find(sym) != defined.end()) + throw Error(def->loc, (format("`%1%' defined twice") % sym->str()).str()); + defined.insert(def->sym()); + frame.push_back(make_pair(def->sym(), make_pair(def->at(2), (AType*)NULL))); + } + } + + tenv.push(frame); + + Constraints cp; + cp.push_back(Constraint(tenv.var(this), tenv.var(), loc)); + + AType* protT = tup(loc, NULL); + for (size_t i = 0; i < prot()->size(); ++i) { + AType* tvar = tenv.fresh(prot()->at(i)->to()); + protT->push_back(tvar); + assert(frame[i].first == prot()->at(i)); + frame[i].second.first = prot()->at(i); + frame[i].second.second = tvar; + } + c.push_back(Constraint(tenv.var(at(1)), protT, at(1)->loc)); + + for (size_t i = 2; i < size(); ++i) + at(i)->constrain(tenv, cp); + + AType* bodyT = tenv.var(at(e-1)); + Subst tsubst = TEnv::unify(cp); + genericType = tup(loc, tenv.penv.sym("Fn"), + tsubst.apply(protT), tsubst.apply(bodyT), 0); + tenv.genericTypes.insert(make_pair(this, genericType)); + Object::pool.addRoot(genericType); + + tenv.pop(); + subst = tsubst; + } + + AType* t = new AType(*genericType); // FIXME: deep copy + c.constrain(tenv, this, t); +} + +void +ACall::constrain(TEnv& tenv, Constraints& c) const +{ + at(0)->constrain(tenv, c); + for (size_t i = 1; i < size(); ++i) + at(i)->constrain(tenv, c); + + AST* callee = tenv.resolve(at(0)); + AFn* closure = callee->to(); + if (closure) { + if (size() - 1 != closure->prot()->size()) + throw Error(loc, "incorrect number of arguments"); + TEnv::GenericTypes::iterator gt = tenv.genericTypes.find(closure); + if (gt != tenv.genericTypes.end()) { + for (size_t i = 1; i < size(); ++i) + c.constrain(tenv, at(i), gt->second->at(1)->as()->at(i-1)->as()); + AType* retT = tenv.var(this); + c.constrain(tenv, at(0), tup(at(0)->loc, tenv.penv.sym("Fn"), tenv.var(), retT, 0)); + c.constrain(tenv, this, retT); + return; + } + } + AType* argsT = tup(loc, 0); + for (size_t i = 1; i < size(); ++i) + argsT->push_back(tenv.var(at(i))); + AType* retT = tenv.var(); + c.constrain(tenv, at(0), tup(at(0)->loc, tenv.penv.sym("Fn"), argsT, retT, 0)); + c.constrain(tenv, this, retT); +} + +void +ADef::constrain(TEnv& tenv, Constraints& c) const +{ + THROW_IF(size() != 3, loc, "`def' requires exactly 2 arguments"); + const ASymbol* sym = this->sym(); + THROW_IF(!sym, loc, "`def' has no symbol") + + AType* tvar = tenv.var(at(2)); + tenv.def(sym, make_pair(at(2), tvar)); + at(2)->constrain(tenv, c); + c.constrain(tenv, this, tvar); +} + +void +AIf::constrain(TEnv& tenv, Constraints& c) const +{ + THROW_IF(size() < 4, loc, "`if' requires at least 3 arguments"); + THROW_IF(size() % 2 != 0, loc, "`if' missing final else clause") + for (size_t i = 1; i < size(); ++i) + at(i)->constrain(tenv, c); + AType* retT = tenv.var(this); + for (size_t i = 1; i < size(); i += 2) { + if (i == size() - 1) { + c.constrain(tenv, at(i), retT); + } else { + c.constrain(tenv, at(i), tenv.named("Bool")); + c.constrain(tenv, at(i+1), retT); + } + } +} + +void +APrimitive::constrain(TEnv& tenv, Constraints& c) const +{ + const string n = at(0)->to()->str(); + enum { ARITHMETIC, BINARY, LOGICAL, COMPARISON } type; + if (n == "+" || n == "-" || n == "*" || n == "/") + type = ARITHMETIC; + else if (n == "%") + type = BINARY; + else if (n == "and" || n == "or" || n == "xor") + type = LOGICAL; + else if (n == "=" || n == "!=" || n == ">" || n == ">=" || n == "<" || n == "<=") + type = COMPARISON; + else + throw Error(loc, (format("unknown primitive `%1%'") % n).str()); + + for (size_t i = 1; i < size(); ++i) + at(i)->constrain(tenv, c); + + switch (type) { + case ARITHMETIC: + if (size() < 3) + throw Error(loc, (format("`%1%' requires at least 2 arguments") % n).str()); + for (size_t i = 1; i < size(); ++i) + c.constrain(tenv, at(i), tenv.var(this)); + break; + case BINARY: + if (size() != 3) + throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str()); + c.constrain(tenv, at(1), tenv.var(this)); + c.constrain(tenv, at(2), tenv.var(this)); + break; + case LOGICAL: + if (size() != 3) + throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str()); + c.constrain(tenv, this, tenv.named("Bool")); + c.constrain(tenv, at(1), tenv.named("Bool")); + c.constrain(tenv, at(2), tenv.named("Bool")); + break; + case COMPARISON: + if (size() != 3) + throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str()); + c.constrain(tenv, this, tenv.named("Bool")); + c.constrain(tenv, at(1), tenv.var(at(2))); + break; + default: + throw Error(loc, (format("unknown primitive `%1%'") % n).str()); + } +} + diff --git a/src/unify.cpp b/src/unify.cpp new file mode 100644 index 0000000..2a8e6a0 --- /dev/null +++ b/src/unify.cpp @@ -0,0 +1,94 @@ +/* Tuplr Unification + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include +#include "tuplr.hpp" + +/*************************************************************************** + * Type Inference/Substitution * + ***************************************************************************/ + +static void +substitute(ATuple* tup, const 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 if (tup->at(i) != to) + substitute(tup->at(i)->to(), from, to); +} + +Subst +Subst::compose(const Subst& delta, const Subst& gamma) // TAPL 22.1.1 +{ + Subst r; + for (Subst::const_iterator g = gamma.begin(); g != gamma.end(); ++g) { + Subst::const_iterator d = delta.find(g->second); + r.add(g->first, ((d != delta.end()) ? d : g)->second); + } + for (Subst::const_iterator d = delta.begin(); d != delta.end(); ++d) { + if (gamma.find(d->first) == gamma.end()) + r.add(d->first, d->second); + } + return r; +} + +void +substConstraints(Constraints& constraints, AType* s, AType* t) +{ + for (Constraints::iterator c = constraints.begin(); c != constraints.end();) { + 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; + } +} + +Subst +TEnv::unify(const Constraints& constraints) // TAPL 22.4 +{ + if (constraints.empty()) return Subst(); + 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 Subst::compose(unify(cp), Subst(s, t)); + } else if (t->var() && !s->contains(t)) { + substConstraints(cp, t, s); + return Subst::compose(unify(cp), Subst(t, s)); + } else if (s->kind == AType::EXPR && s->kind == t->kind && s->size() == t->size()) { + for (size_t i = 0; i < s->size(); ++i) { + AType* si = s->at(i)->to(); + AType* ti = t->at(i)->to(); + if (si && ti) + cp.push_back(Constraint(si, ti, si->loc)); + } + return unify(cp); + } else { + throw Error(s->loc ? s->loc : t->loc, + (format("type is `%1%' but should be `%2%'") % s->str() % t->str()).str()); + } +} + diff --git a/src/write.cpp b/src/write.cpp new file mode 100644 index 0000000..04e3401 --- /dev/null +++ b/src/write.cpp @@ -0,0 +1,97 @@ +/* Tuplr Serialisation + * Copyright (C) 2008-2009 David Robillard + * + * 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 . + */ + +#include "tuplr.hpp" + +ostream& +operator<<(ostream& out, const AST* ast) +{ + const ALiteral* flit = ast->to*>(); + if (flit) + return out << showpoint << flit->val; + + const ALiteral* ilit = ast->to*>(); + if (ilit) + return out << ilit->val; + + const ALiteral* blit = ast->to*>(); + if (blit) + return out << (blit->val ? "#t" : "#f"); + + const ASymbol* sym = ast->to(); + if (sym) + return out << sym->cppstr; + + const AType* type = ast->to(); + if (type) { + switch (type->kind) { + case AType::VAR: return out << "?" << type->id; + case AType::PRIM: return out << type->at(0); + case AType::EXPR: break; // will catch Tuple case below + } + } + + const ATuple* tup = ast->to(); + if (tup) { + out << "("; + for (size_t i = 0; i != tup->size(); ++i) + out << tup->at(i) << ((i != tup->size() - 1) ? " " : ""); + return out << ")"; + } + + return out << "?"; +} + +void +pprint_internal(ostream& out, const AST* ast, unsigned indent) +{ + const ATuple* tup = ast->to(); + if (tup && tup->size() > 0) { + const string head = tup->at(0)->str(); + ASymbol* headSym = tup->at(0)->to(); + out << "("; + pprint_internal(out, tup->at(0), indent); + unsigned child_indent = indent; + if (tup->size() > 1) { + out << " "; + if (headSym && headSym->cppstr == "fn") { + out << tup->at(1); + child_indent = indent + 4; + } else { + child_indent += head.length() + 1; + pprint_internal(out, tup->at(1), child_indent); + } + } + for (size_t i = 2; i < tup->size(); ++i) { + out << endl << string().insert(0, child_indent, ' '); + pprint_internal(out, tup->at(i), child_indent); + } + out << ")"; + if (headSym && headSym->cppstr == "fn") + out << endl << string().insert(0, indent + 4, ' '); + } else { + out << ast; + } +} + +void +pprint(ostream& out, const AST* ast) +{ + pprint_internal(out, ast, 0); + out << endl; +} + diff --git a/tuplr.cpp b/tuplr.cpp deleted file mode 100644 index 7dd3e9b..0000000 --- a/tuplr.cpp +++ /dev/null @@ -1,471 +0,0 @@ -/* Tuplr: A programming language - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include -#include -#include -#include -#include -#include -#include "tuplr.hpp" - -using namespace std; -using boost::format; - -GC Object::pool; - -template -ostream& -operator<<(ostream& out, const Exp& exp) -{ - switch (exp.type) { - case Exp::ATOM: - out << exp.atom; - break; - case Exp::LIST: - out << "("; - for (size_t i = 0; i != exp.size(); ++i) - out << exp.at(i) << ((i != exp.size() - 1) ? " " : ""); - out << ")"; - break; - } - return out; -} - - -/*************************************************************************** - * Lexer * - ***************************************************************************/ - -inline int -readChar(Cursor& cur, istream& in) -{ - int ch = in.get(); - switch (ch) { - case '\n': ++cur.line; cur.col = 0; break; - default: ++cur.col; - } - return ch; -} - -SExp -readExpression(Cursor& cur, istream& in) -{ -#define PUSH(s, t) { if (t != "") { s.top().push_back(SExp(loc, t)); t = ""; } } -#define YIELD(s, t) { if (s.empty()) { return SExp(loc, t); } else PUSH(s, t) } - stack stk; - string tok; - Cursor loc; // start of tok - while (int c = readChar(cur, in)) { - switch (c) { - case EOF: - THROW_IF(!stk.empty(), cur, "unexpected end of file") - return SExp(cur); - case ';': - while ((c = readChar(cur, in)) != '\n') {} - case '\n': case ' ': case '\t': - if (tok != "") YIELD(stk, tok); - break; - case '"': - loc = cur; - do { tok.push_back(c); } while ((c = readChar(cur, in)) != '"'); - YIELD(stk, tok + '"'); - break; - case '(': - stk.push(SExp(cur)); - break; - case ')': - switch (stk.size()) { - case 0: - throw Error(cur, "unexpected `)'"); - case 1: - PUSH(stk, tok); - return stk.top(); - default: - PUSH(stk, tok); - SExp l = stk.top(); - stk.pop(); - stk.top().push_back(l); - } - break; - case '#': - if (in.peek() == '|') { - while (!(readChar(cur, in) == '|' && readChar(cur, in) == '#')) {} - break; - } - default: - if (tok == "") loc = cur; - tok += c; - } - } - switch (stk.size()) { - case 0: return SExp(loc, tok); - case 1: return stk.top(); - default: throw Error(cur, "missing `)'"); - } - return SExp(cur); -} - - -/*************************************************************************** - * Macro Functions * - ***************************************************************************/ - -inline SExp -macDef(PEnv& penv, const SExp& exp) -{ - THROW_IF(exp.size() < 3, exp.loc, "[MAC] `def' requires at least 2 arguments") - if (exp.at(1).type == SExp::ATOM) { - return exp; - } else { - // (def (f x) y) => (def f (fn (x) y)) - SExp argsExp(exp.loc); - for (size_t i = 1; i < exp.at(1).size(); ++i) - argsExp.push_back(exp.at(1).at(i)); - SExp fnExp(exp.at(2).loc); - fnExp.push_back(SExp(exp.at(2).loc, "fn")); - fnExp.push_back(argsExp); - for (size_t i = 2; i < exp.size(); ++i) - fnExp.push_back(exp.at(i)); - SExp ret(exp.loc); - ret.push_back(exp.at(0)); - ret.push_back(exp.at(1).at(0)); - ret.push_back(fnExp); - return ret; - } -} - - -/*************************************************************************** - * Parser Functions * - ***************************************************************************/ - -template -inline AST* -parseCall(PEnv& penv, const SExp& exp, void* arg) -{ - return new C(exp, penv.parseTuple(exp)); -} - -template -inline AST* -parseLiteral(PEnv& penv, const SExp& exp, void* arg) -{ - return new ALiteral(*reinterpret_cast(arg), exp.loc); -} - -inline AST* -parseFn(PEnv& penv, const SExp& exp, void* arg) -{ - if (exp.size() < 2) - throw Error(exp.loc, "Missing function parameters and body"); - else if (exp.size() < 3) - throw Error(exp.loc, "Missing function body"); - SExp::const_iterator a = exp.begin(); ++a; - AFn* ret = tup(exp.loc, penv.sym("fn"), new ATuple(penv.parseTuple(*a++)), 0); - while (a != exp.end()) - ret->push_back(penv.parse(*a++)); - return ret; -} - - -/*************************************************************************** - * Standard Definitions * - ***************************************************************************/ - -void -initLang(PEnv& penv, TEnv& tenv) -{ - // Types - tenv.def(penv.sym("Nothing"), make_pair((AST*)0, new AType(penv.sym("Nothing")))); - tenv.def(penv.sym("Bool"), make_pair((AST*)0, new AType(penv.sym("Bool")))); - tenv.def(penv.sym("Int"), make_pair((AST*)0, new AType(penv.sym("Int")))); - tenv.def(penv.sym("Float"), make_pair((AST*)0, new AType(penv.sym("Float")))); - - // Literals - static bool trueVal = true; - static bool falseVal = false; - penv.reg(false, "#t", PEnv::Handler(parseLiteral, &trueVal)); - penv.reg(false, "#f", PEnv::Handler(parseLiteral, &falseVal)); - - // Macros - penv.defmac("def", macDef); - - // Special forms - penv.reg(true, "fn", PEnv::Handler(parseFn)); - penv.reg(true, "if", PEnv::Handler(parseCall)); - penv.reg(true, "def", PEnv::Handler(parseCall)); - - // Numeric primitives - penv.reg(true, "+", PEnv::Handler(parseCall)); - penv.reg(true, "-", PEnv::Handler(parseCall)); - penv.reg(true, "*", PEnv::Handler(parseCall)); - penv.reg(true, "/", PEnv::Handler(parseCall)); - penv.reg(true, "%", PEnv::Handler(parseCall)); - penv.reg(true, "and", PEnv::Handler(parseCall)); - penv.reg(true, "or", PEnv::Handler(parseCall)); - penv.reg(true, "xor", PEnv::Handler(parseCall)); - penv.reg(true, "=", PEnv::Handler(parseCall)); - penv.reg(true, "!=", PEnv::Handler(parseCall)); - penv.reg(true, ">", PEnv::Handler(parseCall)); - penv.reg(true, ">=", PEnv::Handler(parseCall)); - penv.reg(true, "<", PEnv::Handler(parseCall)); - penv.reg(true, "<=", PEnv::Handler(parseCall)); -} - - -/*************************************************************************** - * EVAL/REPL * - ***************************************************************************/ - -int -eval(CEnv& cenv, const string& name, istream& is) -{ - AST* result = NULL; - AType* resultType = NULL; - list< pair > exprs; - Cursor cursor(name); - try { - while (true) { - SExp exp = readExpression(cursor, is); - if (exp.type == SExp::LIST && exp.empty()) - break; - - result = cenv.penv.parse(exp); // Parse input - Constraints c; - result->constrain(cenv.tenv, c); // Constrain types - cenv.tsubst = Subst::compose(cenv.tsubst, TEnv::unify(c)); // Solve type constraints - resultType = cenv.type(result); - result->lift(cenv); // Lift functions - exprs.push_back(make_pair(exp, result)); - - // Add definitions as GC roots - if (result->to()) - cenv.lock(result); - - // Add types in type substition as GC roots - for (Subst::iterator i = cenv.tsubst.begin(); i != cenv.tsubst.end(); ++i) { - Object::pool.addRoot(i->first); - Object::pool.addRoot(i->second); - } - } - - // Print CPS form - CValue val = NULL; - /*for (list< pair >::const_iterator i = exprs.begin(); i != exprs.end(); ++i) { - cout << "; CPS" << endl; - pprint(cout, i->second->cps(cenv.tenv, cenv.penv.sym("cont"))); - }*/ - - if (resultType->concrete()) { - // Create function for top-level of program - CFunction f = cenv.engine()->startFunction(cenv, "main", resultType, ATuple(cursor)); - - // Compile all expressions into it - for (list< pair >::const_iterator i = exprs.begin(); i != exprs.end(); ++i) - val = cenv.compile(i->second); - - // Finish and call it - cenv.engine()->finishFunction(cenv, f, resultType, val); - cenv.out << cenv.engine()->call(cenv, f, resultType); - } - cenv.out << " : " << resultType << endl; - - Object::pool.collect(Object::pool.roots()); - - if (cenv.args.find("-d") != cenv.args.end()) - cenv.engine()->writeModule(cenv, cenv.out); - - } catch (Error& e) { - cenv.err << e.what() << endl; - return 1; - } - return 0; -} - -int -repl(CEnv& cenv) -{ - while (1) { - cenv.out << "() "; - cenv.out.flush(); - Cursor cursor("(stdin)"); - - try { - SExp exp = readExpression(cursor, std::cin); - if (exp.type == SExp::LIST && exp.empty()) - break; - - AST* body = cenv.penv.parse(exp); // Parse input - Constraints c; - body->constrain(cenv.tenv, c); // Constrain types - - Subst oldSubst = cenv.tsubst; - cenv.tsubst = Subst::compose(cenv.tsubst, TEnv::unify(c)); // Solve type constraints - - AType* bodyT = cenv.type(body); - THROW_IF(!bodyT, cursor, "call to untyped body") - - body->lift(cenv); - - CFunction f = NULL; - try { - // Create anonymous function to insert code into - f = cenv.engine()->startFunction(cenv, cenv.penv.gensymstr("_repl"), bodyT, ATuple(cursor)); - CValue retVal = cenv.compile(body); - cenv.engine()->finishFunction(cenv, f, bodyT, retVal); - cenv.out << cenv.engine()->call(cenv, f, bodyT); - } catch (Error& e) { - ADef* def = body->to(); - if (def) - cenv.out << def->sym(); - else - cenv.out << "?"; - cenv.engine()->eraseFunction(cenv, f); - } - cenv.out << " : " << cenv.type(body) << endl; - - // Add definitions as GC roots - if (body->to()) - cenv.lock(body); - - Object::pool.collect(Object::pool.roots()); - - cenv.tsubst = oldSubst; - if (cenv.args.find("-d") != cenv.args.end()) - cenv.engine()->writeModule(cenv, cenv.out); - - } catch (Error& e) { - cenv.err << e.what() << endl; - } - } - return 0; -} - - -/*************************************************************************** - * MAIN * - ***************************************************************************/ - -int -print_usage(char* name, bool error) -{ - ostream& os = error ? cerr : cout; - os << "Usage: " << name << " [OPTION]... [FILE]..." << endl; - os << "Evaluate and/or compile Tuplr code" << endl; - os << endl; - os << " -h Display this help and exit" << endl; - os << " -r Enter REPL after evaluating files" << endl; - os << " -p Pretty-print input only" << endl; - os << " -g Debug (disable optimisation)" << endl; - os << " -d Dump assembly output" << endl; - os << " -e EXPRESSION Evaluate EXPRESSION" << endl; - os << " -o FILE Write output to FILE" << endl; - return error ? 1 : 0; -} - -int -main(int argc, char** argv) -{ - PEnv penv; - TEnv tenv(penv); - initLang(penv, tenv); - - Engine* engine = tuplr_new_engine(); - CEnv* cenv = new CEnv(penv, tenv, engine); - - cenv->push(); - Object::pool.lock(); - - map args; - list files; - for (int i = 1; i < argc; ++i) { - if (!strncmp(argv[i], "-h", 3)) { - return print_usage(argv[0], false); - } else if (argv[i][0] != '-') { - files.push_back(argv[i]); - } else if (!strncmp(argv[i], "-r", 3) - || !strncmp(argv[i], "-p", 3) - || !strncmp(argv[i], "-g", 3) - || !strncmp(argv[i], "-d", 3)) { - args.insert(make_pair(argv[i], "")); - } else if (i == argc-1 || argv[i+1][0] == '-') { - return print_usage(argv[0], true); - } else { - args.insert(make_pair(argv[i], argv[i+1])); - ++i; - } - } - - cenv->args = args; - - int ret = 0; - - string output; - map::const_iterator a = args.find("-o"); - if (a != args.end()) - output = a->second; - - a = args.find("-p"); - if (a != args.end()) { - ifstream is(files.front().c_str()); - if (is.good()) { - Cursor loc; - SExp exp = readExpression(loc, is); - AST* ast = penv.parse(exp); - pprint(cout, ast); - } - return 0; - } - - a = args.find("-e"); - if (a != args.end()) { - istringstream is(a->second); - ret = eval(*cenv, "(command line)", is); - } - - for (list::iterator f = files.begin(); f != files.end(); ++f) { - ifstream is(f->c_str()); - if (is.good()) { - ret = ret | eval(*cenv, *f, is); - } else { - cerr << argv[0] << ": " << *f << ": " << strerror(errno) << endl; - ++ret; - } - is.close(); - } - - if (args.find("-r") != args.end() || (files.empty() && args.find("-e") == args.end())) - ret = repl(*cenv); - - if (output != "") { - ofstream os(output.c_str()); - if (os.good()) { - cenv->engine()->writeModule(*cenv, os); - } else { - cerr << argv[0] << ": " << a->second << ": " << strerror(errno) << endl; - ++ret; - } - os.close(); - } - - delete cenv; - tuplr_free_engine(engine); - - return ret; -} - diff --git a/tuplr.hpp b/tuplr.hpp deleted file mode 100644 index 5275dfd..0000000 --- a/tuplr.hpp +++ /dev/null @@ -1,654 +0,0 @@ -/* Tuplr: A programming language - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#ifndef TUPLR_HPP -#define TUPLR_HPP - -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#define FOREACH(IT, i, c) for (IT i = (c).begin(); i != (c).end(); ++i) -#define THROW_IF(cond, error, ...) { if (cond) throw Error(error, __VA_ARGS__); } - -using namespace std; -using boost::format; - - -/*************************************************************************** - * Basic Utility Classes * - ***************************************************************************/ - -/// Location in textual code -struct Cursor { - Cursor(const string& n="", unsigned l=1, unsigned c=0) : name(n), line(l), col(c) {} - operator bool() const { return !(line == 1 && col == 0); } - string str() const { return (format("%1%:%2%:%3%") % name % line % col).str(); } - string name; - unsigned line; - unsigned col; -}; - -/// Compiler error -struct Error { - Error(Cursor c, const string& m) : loc(c), msg(m) {} - const string what() const { return (loc ? loc.str() + ": " : "") + "error: " + msg; } - Cursor loc; - string msg; -}; - -/// Expression ::= Atom | (SubExp*) -template -struct Exp : public std::vector< Exp > { - Exp(Cursor c) : type(LIST), loc(c) {} - Exp(Cursor c, const Atom& a) : type(ATOM), loc(c), atom(a) {} - enum { ATOM, LIST } type; - Cursor loc; - Atom atom; -}; - -template -extern ostream& operator<<(ostream& out, const Exp& exp); - -/// Lexical Address -struct LAddr { - LAddr(unsigned u=0, unsigned o=0) : up(u), over(o) {} - operator bool() const { return !(up == 0 && over == 0); } - unsigned up, over; -}; - -/// Generic Lexical Environment -template -struct Env : public list< vector< pair > > { - typedef vector< pair > Frame; - Env() : list(1) {} - virtual void push(Frame f=Frame()) { list::push_front(f); } - virtual void pop() { assert(!this->empty()); list::pop_front(); } - const V& def(const K& k, const V& v) { - for (typename Frame::iterator b = this->begin()->begin(); b != this->begin()->end(); ++b) - if (b->first == k) - return (b->second = v); - this->front().push_back(make_pair(k, v)); - return v; - } - V* ref(const K& key) { - for (typename Env::iterator f = this->begin(); f != this->end(); ++f) - for (typename Frame::iterator b = f->begin(); b != f->end(); ++b) - if (b->first == key) - return &b->second; - return NULL; - } - LAddr lookup(const K& key) const { - unsigned up = 0; - for (typename Env::const_iterator f = this->begin(); f != this->end(); ++f, ++up) - for (unsigned over = 0; over < f->size(); ++over) - if ((*f)[over].first == key) - return LAddr(up + 1, over + 1); - return LAddr(); - } - V& deref(LAddr addr) { - assert(addr); - typename Env::iterator f = this->begin(); - for (unsigned u = 1; u < addr.up; ++u, ++f) { assert(f != this->end()); } - assert(f->size() > addr.over - 1); - return (*f)[addr.over - 1].second; - } -}; - - -/*************************************************************************** - * Lexer: Text (istream) -> S-Expressions (SExp) * - ***************************************************************************/ - -typedef Exp SExp; ///< Textual S-Expression - -SExp readExpression(Cursor& cur, std::istream& in); - - -/*************************************************************************** - * Backend Types * - ***************************************************************************/ - -typedef void* CValue; ///< Compiled value (opaque) -typedef void* CFunction; ///< Compiled function (opaque) - - -/*************************************************************************** - * Garbage Collector * - ***************************************************************************/ - -struct Object; ///< Object (AST nodes and runtime data) - -struct GC { - enum Tag { - TAG_AST = 2, ///< Abstract syntax tree node - TAG_FRAME = 4 ///< Stack frame - }; - typedef std::list Roots; - typedef std::list Heap; - void* alloc(size_t size, Tag tag); - void collect(const Roots& roots); - void addRoot(const Object* obj) { if (obj) _roots.push_back(obj); } - void lock() { _roots.insert(_roots.end(), _heap.begin(), _heap.end()); } - const Roots& roots() const { return _roots; } -private: - Heap _heap; - Roots _roots; -}; - -/// Dynamic (garbage-collected) object -struct Object { - struct Header { - uint8_t mark; - uint8_t tag; - }; - - /// Always allocated with pool.alloc, so this - sizeof(Header) is a valid Header*. - inline Header* header() const { return (Header*)((char*)this - sizeof(Header)); } - - inline bool marked() const { return header()->mark != 0; } - inline void mark(bool b) const { header()->mark = 1; } - inline GC::Tag tag() const { return (GC::Tag)header()->tag; } - - static void* operator new(size_t size) { return pool.alloc(size, GC::TAG_AST); } - static void operator delete(void* ptr) {} - static GC pool; -}; - - -/*************************************************************************** - * Abstract Syntax Tree * - ***************************************************************************/ - -struct Constraint; ///< Type Constraint -struct TEnv; ///< Type-Time Environment -struct Constraints; ///< Type Constraints -struct Subst; ///< Type substitutions -struct CEnv; ///< Compile-Time Environment - -struct AST; -extern ostream& operator<<(ostream& out, const AST* ast); - -/// Base class for all AST nodes -struct AST : public Object { - AST(Cursor c=Cursor()) : loc(c) {} - virtual ~AST() {} - virtual bool value() const { return true; } - virtual bool operator==(const AST& o) const = 0; - virtual bool contains(const AST* child) const { return false; } - virtual void constrain(TEnv& tenv, Constraints& c) const {} - virtual AST* cps(TEnv& tenv, AST* cont); - virtual void lift(CEnv& cenv) {} - virtual CValue compile(CEnv& cenv) = 0; - string str() const { ostringstream ss; ss << this; return ss.str(); } - template T to() { return dynamic_cast(this); } - template T to() const { return dynamic_cast(this); } - template T as() { - T t = dynamic_cast(this); - if (!t) throw Error(loc, "internal error: bad cast"); - return t; - } - Cursor loc; -}; - -template -static T* tup(Cursor c, AST* ast, ...) -{ - va_list args; - va_start(args, ast); - T* ret = new T(c, ast, args); - va_end(args); - return ret; -} - -/// Literal value -template -struct ALiteral : public AST { - ALiteral(VT v, Cursor c) : AST(c), val(v) {} - bool operator==(const AST& rhs) const { - const ALiteral* r = rhs.to*>(); - return (r && (val == r->val)); - } - void constrain(TEnv& tenv, Constraints& c) const; - CValue compile(CEnv& cenv); - const VT val; -}; - -/// Symbol, e.g. "a" -struct ASymbol : public AST { - bool operator==(const AST& rhs) const { return this == &rhs; } - void constrain(TEnv& tenv, Constraints& c) const; - CValue compile(CEnv& cenv); - mutable LAddr addr; - const string cppstr; -private: - friend class PEnv; - ASymbol(const string& s, Cursor c) : AST(c), cppstr(s) {} -}; - -/// Tuple (heterogeneous sequence of fixed length), e.g. "(a b c)" -struct ATuple : public AST, public vector { - ATuple(Cursor c, const vector& v=vector()) : AST(c), vector(v) {} - ATuple(Cursor c, AST* ast, va_list args) : AST(c) { - if (!ast) return; - push_back(ast); - for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*)) - push_back(a); - } - bool value() const { return false; } - bool operator==(const AST& rhs) const { - const ATuple* rt = rhs.to(); - if (!rt || rt->size() != size()) return false; - const_iterator l = begin(); - FOREACH(const_iterator, r, *rt) - if (!(*(*l++) == *(*r))) - return false; - return true; - } - bool contains(AST* child) const { - if (*this == *child) return true; - FOREACH(const_iterator, p, *this) - if (**p == *child || (*p)->contains(child)) - return true; - return false; - } - void constrain(TEnv& tenv, Constraints& c) const; - void lift(CEnv& cenv) { FOREACH(iterator, t, *this) (*t)->lift(cenv); } - - CValue compile(CEnv& cenv) { throw Error(loc, "tuple compiled"); } -}; - -/// Type Expression, e.g. "Int", "(Fn (Int Int) Float)" -struct AType : public ATuple { - AType(ASymbol* s) : ATuple(s->loc), kind(PRIM), id(0) { push_back(s); } - AType(Cursor c, unsigned i, LAddr a) : ATuple(c), kind(VAR), id(i) {} - AType(Cursor c, AST* ast, ...) : ATuple(c), kind(EXPR), id(0) { - if (!ast) return; - va_list args; - va_start(args, ast); - push_back(ast); - for (AST* a = va_arg(args, AST*); a; a = va_arg(args, AST*)) - push_back(a); - va_end(args); - } - AType(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args), kind(EXPR), id(0) {} - CValue compile(CEnv& cenv) { return NULL; } - bool var() const { return kind == VAR; } - bool concrete() const { - switch (kind) { - case VAR: return false; - case PRIM: return at(0)->str() != "Nothing"; - case EXPR: - FOREACH(const_iterator, t, *this) { - AType* kid = (*t)->to(); - if (kid && !kid->concrete()) - return false; - } - } - return true; - } - bool operator==(const AST& rhs) const { - const AType* rt = rhs.to(); - if (!rt || 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 ATuple::operator==(rhs); - } - return false; // never reached - } - enum { VAR, PRIM, EXPR } kind; - unsigned id; -}; - -/// Type substitution -struct Subst : public list< pair > { - Subst(AType* s=0, AType* t=0) { if (s && t) { assert(s != t); push_back(make_pair(s, t)); } } - static Subst compose(const Subst& delta, const Subst& gamma); - void add(const AType* from, AType* to) { push_back(make_pair(from, to)); } - const_iterator find(const AType* t) const { - for (const_iterator j = begin(); j != end(); ++j) - if (*j->first == *t) - return j; - return end(); - } - AST* apply(AST* ast) const { - AType* in = ast->to(); - if (!in) return ast; - if (in->kind == AType::EXPR) { - AType* out = tup(in->loc, NULL); - for (size_t i = 0; i < in->size(); ++i) - out->push_back(apply(in->at(i))); - return out; - } else { - const_iterator i = find(in); - if (i != end()) { - AST* out = i->second; - AType* outT = out->to(); - if (outT && outT->kind == AType::EXPR && !outT->concrete()) - out = apply(out); - return out; - } else { - return in; - } - } - } -}; - -inline ostream& operator<<(ostream& out, const Subst& s) { - for (Subst::const_iterator i = s.begin(); i != s.end(); ++i) - out << i->first << " => " << i->second << endl; - return out; -} - -/// Fn (first-class function with captured lexical bindings) -struct AFn : public ATuple { - AFn(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args) {} - bool operator==(const AST& rhs) const { return this == &rhs; } - void constrain(TEnv& tenv, Constraints& c) const; - AST* cps(TEnv& tenv, AST* cont); - void lift(CEnv& cenv); - void liftCall(CEnv& cenv, const AType& argsT); - CValue compile(CEnv& cenv); - ATuple* prot() const { return at(1)->to(); } - /// System level implementations of this (polymorphic) fn - struct Impls : public list< pair > { - CFunction find(AType* type) const { - for (const_iterator f = begin(); f != end(); ++f) - if (*f->first == *type) - return f->second; - return NULL; - } - }; - Impls impls; - mutable Subst subst; - string name; -}; - -/// Function call/application, e.g. "(func arg1 arg2)" -struct ACall : public ATuple { - ACall(const SExp& e, const ATuple& t) : ATuple(e.loc, t) {} - ACall(Cursor c, AST* ast, va_list args) : ATuple(c, ast, args) {} - void constrain(TEnv& tenv, Constraints& c) const; - AST* cps(TEnv& tenv, AST* cont); - void lift(CEnv& cenv); - CValue compile(CEnv& cenv); -}; - -/// Definition special form, e.g. "(def x 2)" -struct ADef : public ACall { - ADef(const SExp& e, const ATuple& t) : ACall(e, t) {} - ADef(Cursor c, AST* ast, va_list args) : ACall(c, ast, args) {} - ASymbol* sym() const { - ASymbol* sym = at(1)->to(); - if (!sym) { - ATuple* tup = at(1)->to(); - if (tup && !tup->empty()) - return tup->at(0)->to(); - } - return sym; - } - void constrain(TEnv& tenv, Constraints& c) const; - AST* cps(TEnv& tenv, AST* cont); - void lift(CEnv& cenv); - CValue compile(CEnv& cenv); -}; - -/// Conditional special form, e.g. "(if cond thenexp elseexp)" -struct AIf : public ACall { - AIf(const SExp& e, const ATuple& t) : ACall(e, t) {} - AIf(Cursor c, AST* ast, va_list args) : ACall(c, ast, args) {} - void constrain(TEnv& tenv, Constraints& c) const; - AST* cps(TEnv& tenv, AST* cont); - CValue compile(CEnv& cenv); -}; - -/// Primitive (builtin arithmetic function), e.g. "(+ 2 3)" -struct APrimitive : public ACall { - APrimitive(const SExp& e, const ATuple& t) : ACall(e, t) {} - bool value() const { - for (size_t i = 1; i < size(); ++i) - if (!at(i)->value()) - return false;; - return true; - } - void constrain(TEnv& tenv, Constraints& c) const; - AST* cps(TEnv& tenv, AST* cont); - CValue compile(CEnv& cenv); -}; - - -/*************************************************************************** - * Parser: S-Expressions (SExp) -> AST Nodes (AST) * - ***************************************************************************/ - -/// Parse Time Environment (really just a symbol table) -struct PEnv : private map { - PEnv() : symID(0) {} - typedef AST* (*PF)(PEnv&, const SExp&, void*); ///< Parse Function - typedef SExp (*MF)(PEnv&, const SExp&); ///< Macro Function - struct Handler { Handler(PF f, void* a=0) : func(f), arg(a) {} PF func; void* arg; }; - map aHandlers; ///< Atom parse functions - map lHandlers; ///< List parse functions - map macros; ///< Macro functions - void reg(bool list, const string& s, const Handler& h) { - (list ? lHandlers : aHandlers).insert(make_pair(sym(s)->str(), h)); - } - const Handler* handler(bool list, const string& s) const { - const map& handlers = list ? lHandlers : aHandlers; - map::const_iterator i = handlers.find(s); - return (i != handlers.end()) ? &i->second : NULL; - } - void defmac(const string& s, const MF f) { - macros.insert(make_pair(s, f)); - } - MF mac(const string& s) const { - map::const_iterator i = macros.find(s); - return (i != macros.end()) ? i->second : NULL; - } - string gensymstr(const char* s="_") { return (format("%s%d") % s % symID++).str(); } - ASymbol* gensym(const char* s="_") { return sym(gensymstr(s)); } - ASymbol* sym(const string& s, Cursor c=Cursor()) { - const const_iterator i = find(s); - if (i != end()) { - return i->second; - } else { - ASymbol* sym = new ASymbol(s, c); - insert(make_pair(s, sym)); - return sym; - } - } - ATuple parseTuple(const SExp& e) { - ATuple ret(e.loc, vector(e.size())); - size_t n = 0; - FOREACH(SExp::const_iterator, i, e) - ret[n++] = parse(*i); - return ret; - } - AST* parse(const SExp& exp) { - if (exp.type == SExp::LIST) { - if (exp.empty()) throw Error(exp.loc, "call to empty list"); - if (exp.front().type == SExp::ATOM) { - MF mf = mac(exp.front().atom); - SExp expanded = (mf ? mf(*this, exp) : exp); - - const PEnv::Handler* h = handler(true, expanded.front().atom); - if (h) - return h->func(*this, expanded, h->arg); - } - return new ACall(exp, parseTuple(exp)); // Parse as regular call - } else if (isdigit(exp.atom[0])) { - if (exp.atom.find('.') == string::npos) - return new ALiteral(strtol(exp.atom.c_str(), NULL, 10), exp.loc); - else - return new ALiteral(strtod(exp.atom.c_str(), NULL), exp.loc); - } else { - const PEnv::Handler* h = handler(false, exp.atom); - if (h) - return h->func(*this, exp, h->arg); - } - return sym(exp.atom, exp.loc); - } - unsigned symID; -}; - - -/*************************************************************************** - * Typing * - ***************************************************************************/ - -struct Constraint : public pair { - Constraint(AType* a, AType* b, Cursor c) : pair(a, b), loc(c) {} - Cursor loc; -}; - -struct Constraints : public list { - void constrain(TEnv& tenv, const AST* o, AType* t); -}; - -inline ostream& operator<<(ostream& out, const Constraints& c) { - for (Constraints::const_iterator i = c.begin(); i != c.end(); ++i) - out << i->first << " : " << i->second << endl; - return out; -} - -/// Type-Time Environment -struct TEnv : public Env< const ASymbol*, pair > { - TEnv(PEnv& p) : penv(p), varID(1) {} - AType* fresh(const ASymbol* sym) { - assert(sym); - AType* ret = new AType(sym->loc, varID++, LAddr()); - def(sym, make_pair((AST*)NULL, ret)); - return ret; - } - AType* var(const AST* ast=0) { - const ASymbol* sym = ast->to(); - if (sym) - return deref(lookup(sym)).second; - - Vars::iterator v = vars.find(ast); - if (v != vars.end()) - return v->second; - - AType* ret = new AType(ast ? ast->loc : Cursor(), varID++, LAddr()); - if (ast) - vars[ast] = ret; - - return ret; - } - AType* named(const string& name) { - return ref(penv.sym(name))->second; - } - AST* resolve(AST* ast) { - ASymbol* sym = ast->to(); - return (sym && sym->addr) ? ref(sym)->first : ast; - } - - static Subst unify(const Constraints& c); - - typedef map Vars; - typedef map GenericTypes; - Vars vars; - GenericTypes genericTypes; - PEnv& penv; - unsigned varID; -}; - - -/*************************************************************************** - * Code Generation * - ***************************************************************************/ - -struct Engine { - virtual CFunction startFunction(CEnv& cenv, const std::string& name, - const AType* retT, const ATuple& argsT, - const vector argNames=vector()) = 0; - - virtual void finishFunction(CEnv& cenv, CFunction f, const AType* retT, CValue ret) = 0; - virtual void eraseFunction(CEnv& cenv, CFunction f) = 0; - virtual void writeModule(CEnv& cenv, std::ostream& os) = 0; - - virtual const string call(CEnv& cenv, CFunction f, AType* retT) = 0; -}; - -Engine* tuplr_new_engine(); -void tuplr_free_engine(Engine* engine); - -/// Compile-Time Environment -struct CEnv { - CEnv(PEnv& p, TEnv& t, Engine* e, ostream& os=std::cout, ostream& es=std::cerr) - : out(os), err(es), penv(p), tenv(t), _engine(e) - {} - - ~CEnv() { Object::pool.collect(GC::Roots()); } - - typedef Env Vals; - - Engine* engine() { return _engine; } - void push() { tenv.push(); vals.push(); } - void pop() { tenv.pop(); vals.pop(); } - void precompile(AST* obj, CValue value) { vals.def(obj, value); } - CValue compile(AST* obj) { - CValue* v = vals.ref(obj); - return (v && *v) ? *v : vals.def(obj, obj->compile(*this)); - } - void lock(AST* ast) { Object::pool.addRoot(ast); Object::pool.addRoot(type(ast)); } - AType* type(AST* ast, const Subst& subst = Subst()) const { - ASymbol* sym = ast->to(); - if (sym) - return sym->addr ? tenv.deref(sym->addr).second : NULL; - return tsubst.apply(subst.apply(tenv.vars[ast]))->to(); - } - void def(ASymbol* sym, AST* c, AType* t, CValue v) { - tenv.def(sym, make_pair(c, t)); - vals.def(sym, v); - } - - ostream& out; - ostream& err; - PEnv& penv; - TEnv& tenv; - Vals vals; - - Subst tsubst; - - map args; - -private: - Engine* _engine; -}; - - -/*************************************************************************** - * EVAL/REPL/MAIN * - ***************************************************************************/ - -void pprint(std::ostream& out, const AST* ast); -void initLang(PEnv& penv, TEnv& tenv); -int eval(CEnv& cenv, const string& name, istream& is); -int repl(CEnv& cenv); - -#endif // TUPLR_HPP - diff --git a/typing.cpp b/typing.cpp deleted file mode 100644 index 5791fdc..0000000 --- a/typing.cpp +++ /dev/null @@ -1,232 +0,0 @@ -/* Tuplr Type Inferencing - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include -#include "tuplr.hpp" - -void -Constraints::constrain(TEnv& tenv, const AST* o, AType* t) -{ - assert(!o->to()); - push_back(Constraint(tenv.var(o), t, o->loc)); -} - - -/*************************************************************************** - * AST Type Constraints * - ***************************************************************************/ - -void -ASymbol::constrain(TEnv& tenv, Constraints& c) const -{ - addr = tenv.lookup(this); - if (!addr) - throw Error(loc, (format("undefined symbol `%1%'") % cppstr).str()); - c.push_back(Constraint(tenv.var(this), tenv.deref(addr).second, loc)); -} - -void -ATuple::constrain(TEnv& tenv, Constraints& c) const -{ - AType* t = tup(loc, NULL); - FOREACH(const_iterator, p, *this) { - (*p)->constrain(tenv, c); - t->push_back(tenv.var(*p)); - } - c.push_back(Constraint(tenv.var(this), t, loc)); -} - -void -AFn::constrain(TEnv& tenv, Constraints& c) const -{ - const AType* genericType; - TEnv::GenericTypes::const_iterator gt = tenv.genericTypes.find(this); - if (gt != tenv.genericTypes.end()) { - genericType = gt->second; - } else { - set defined; - TEnv::Frame frame; - - // Add parameters to environment frame - for (size_t i = 0; i < prot()->size(); ++i) { - ASymbol* sym = prot()->at(i)->to(); - if (!sym) - throw Error(prot()->at(i)->loc, "parameter name is not a symbol"); - if (defined.find(sym) != defined.end()) - throw Error(sym->loc, (format("duplicate parameter `%1%'") % sym->str()).str()); - defined.insert(sym); - frame.push_back(make_pair(sym, make_pair((AST*)NULL, (AType*)NULL))); - } - - // Add internal definitions to environment frame - size_t e = 2; - for (; e < size(); ++e) { - AST* exp = at(e); - ADef* def = exp->to(); - if (def) { - ASymbol* sym = def->sym(); - if (defined.find(sym) != defined.end()) - throw Error(def->loc, (format("`%1%' defined twice") % sym->str()).str()); - defined.insert(def->sym()); - frame.push_back(make_pair(def->sym(), make_pair(def->at(2), (AType*)NULL))); - } - } - - tenv.push(frame); - - Constraints cp; - cp.push_back(Constraint(tenv.var(this), tenv.var(), loc)); - - AType* protT = tup(loc, NULL); - for (size_t i = 0; i < prot()->size(); ++i) { - AType* tvar = tenv.fresh(prot()->at(i)->to()); - protT->push_back(tvar); - assert(frame[i].first == prot()->at(i)); - frame[i].second.first = prot()->at(i); - frame[i].second.second = tvar; - } - c.push_back(Constraint(tenv.var(at(1)), protT, at(1)->loc)); - - for (size_t i = 2; i < size(); ++i) - at(i)->constrain(tenv, cp); - - AType* bodyT = tenv.var(at(e-1)); - Subst tsubst = TEnv::unify(cp); - genericType = tup(loc, tenv.penv.sym("Fn"), - tsubst.apply(protT), tsubst.apply(bodyT), 0); - tenv.genericTypes.insert(make_pair(this, genericType)); - Object::pool.addRoot(genericType); - - tenv.pop(); - subst = tsubst; - } - - AType* t = new AType(*genericType); // FIXME: deep copy - c.constrain(tenv, this, t); -} - -void -ACall::constrain(TEnv& tenv, Constraints& c) const -{ - at(0)->constrain(tenv, c); - for (size_t i = 1; i < size(); ++i) - at(i)->constrain(tenv, c); - - AST* callee = tenv.resolve(at(0)); - AFn* closure = callee->to(); - if (closure) { - if (size() - 1 != closure->prot()->size()) - throw Error(loc, "incorrect number of arguments"); - TEnv::GenericTypes::iterator gt = tenv.genericTypes.find(closure); - if (gt != tenv.genericTypes.end()) { - for (size_t i = 1; i < size(); ++i) - c.constrain(tenv, at(i), gt->second->at(1)->as()->at(i-1)->as()); - AType* retT = tenv.var(this); - c.constrain(tenv, at(0), tup(at(0)->loc, tenv.penv.sym("Fn"), tenv.var(), retT, 0)); - c.constrain(tenv, this, retT); - return; - } - } - AType* argsT = tup(loc, 0); - for (size_t i = 1; i < size(); ++i) - argsT->push_back(tenv.var(at(i))); - AType* retT = tenv.var(); - c.constrain(tenv, at(0), tup(at(0)->loc, tenv.penv.sym("Fn"), argsT, retT, 0)); - c.constrain(tenv, this, retT); -} - -void -ADef::constrain(TEnv& tenv, Constraints& c) const -{ - THROW_IF(size() != 3, loc, "`def' requires exactly 2 arguments"); - const ASymbol* sym = this->sym(); - THROW_IF(!sym, loc, "`def' has no symbol") - - AType* tvar = tenv.var(at(2)); - tenv.def(sym, make_pair(at(2), tvar)); - at(2)->constrain(tenv, c); - c.constrain(tenv, this, tvar); -} - -void -AIf::constrain(TEnv& tenv, Constraints& c) const -{ - THROW_IF(size() < 4, loc, "`if' requires at least 3 arguments"); - THROW_IF(size() % 2 != 0, loc, "`if' missing final else clause") - for (size_t i = 1; i < size(); ++i) - at(i)->constrain(tenv, c); - AType* retT = tenv.var(this); - for (size_t i = 1; i < size(); i += 2) { - if (i == size() - 1) { - c.constrain(tenv, at(i), retT); - } else { - c.constrain(tenv, at(i), tenv.named("Bool")); - c.constrain(tenv, at(i+1), retT); - } - } -} - -void -APrimitive::constrain(TEnv& tenv, Constraints& c) const -{ - const string n = at(0)->to()->str(); - enum { ARITHMETIC, BINARY, LOGICAL, COMPARISON } type; - if (n == "+" || n == "-" || n == "*" || n == "/") - type = ARITHMETIC; - else if (n == "%") - type = BINARY; - else if (n == "and" || n == "or" || n == "xor") - type = LOGICAL; - else if (n == "=" || n == "!=" || n == ">" || n == ">=" || n == "<" || n == "<=") - type = COMPARISON; - else - throw Error(loc, (format("unknown primitive `%1%'") % n).str()); - - for (size_t i = 1; i < size(); ++i) - at(i)->constrain(tenv, c); - - switch (type) { - case ARITHMETIC: - if (size() < 3) - throw Error(loc, (format("`%1%' requires at least 2 arguments") % n).str()); - for (size_t i = 1; i < size(); ++i) - c.constrain(tenv, at(i), tenv.var(this)); - break; - case BINARY: - if (size() != 3) - throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str()); - c.constrain(tenv, at(1), tenv.var(this)); - c.constrain(tenv, at(2), tenv.var(this)); - break; - case LOGICAL: - if (size() != 3) - throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str()); - c.constrain(tenv, this, tenv.named("Bool")); - c.constrain(tenv, at(1), tenv.named("Bool")); - c.constrain(tenv, at(2), tenv.named("Bool")); - break; - case COMPARISON: - if (size() != 3) - throw Error(loc, (format("`%1%' requires exactly 2 arguments") % n).str()); - c.constrain(tenv, this, tenv.named("Bool")); - c.constrain(tenv, at(1), tenv.var(at(2))); - break; - default: - throw Error(loc, (format("unknown primitive `%1%'") % n).str()); - } -} - diff --git a/unify.cpp b/unify.cpp deleted file mode 100644 index 2a8e6a0..0000000 --- a/unify.cpp +++ /dev/null @@ -1,94 +0,0 @@ -/* Tuplr Unification - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include -#include "tuplr.hpp" - -/*************************************************************************** - * Type Inference/Substitution * - ***************************************************************************/ - -static void -substitute(ATuple* tup, const 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 if (tup->at(i) != to) - substitute(tup->at(i)->to(), from, to); -} - -Subst -Subst::compose(const Subst& delta, const Subst& gamma) // TAPL 22.1.1 -{ - Subst r; - for (Subst::const_iterator g = gamma.begin(); g != gamma.end(); ++g) { - Subst::const_iterator d = delta.find(g->second); - r.add(g->first, ((d != delta.end()) ? d : g)->second); - } - for (Subst::const_iterator d = delta.begin(); d != delta.end(); ++d) { - if (gamma.find(d->first) == gamma.end()) - r.add(d->first, d->second); - } - return r; -} - -void -substConstraints(Constraints& constraints, AType* s, AType* t) -{ - for (Constraints::iterator c = constraints.begin(); c != constraints.end();) { - 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; - } -} - -Subst -TEnv::unify(const Constraints& constraints) // TAPL 22.4 -{ - if (constraints.empty()) return Subst(); - 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 Subst::compose(unify(cp), Subst(s, t)); - } else if (t->var() && !s->contains(t)) { - substConstraints(cp, t, s); - return Subst::compose(unify(cp), Subst(t, s)); - } else if (s->kind == AType::EXPR && s->kind == t->kind && s->size() == t->size()) { - for (size_t i = 0; i < s->size(); ++i) { - AType* si = s->at(i)->to(); - AType* ti = t->at(i)->to(); - if (si && ti) - cp.push_back(Constraint(si, ti, si->loc)); - } - return unify(cp); - } else { - throw Error(s->loc ? s->loc : t->loc, - (format("type is `%1%' but should be `%2%'") % s->str() % t->str()).str()); - } -} - diff --git a/write.cpp b/write.cpp deleted file mode 100644 index 04e3401..0000000 --- a/write.cpp +++ /dev/null @@ -1,97 +0,0 @@ -/* Tuplr Serialisation - * Copyright (C) 2008-2009 David Robillard - * - * 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 . - */ - -#include "tuplr.hpp" - -ostream& -operator<<(ostream& out, const AST* ast) -{ - const ALiteral* flit = ast->to*>(); - if (flit) - return out << showpoint << flit->val; - - const ALiteral* ilit = ast->to*>(); - if (ilit) - return out << ilit->val; - - const ALiteral* blit = ast->to*>(); - if (blit) - return out << (blit->val ? "#t" : "#f"); - - const ASymbol* sym = ast->to(); - if (sym) - return out << sym->cppstr; - - const AType* type = ast->to(); - if (type) { - switch (type->kind) { - case AType::VAR: return out << "?" << type->id; - case AType::PRIM: return out << type->at(0); - case AType::EXPR: break; // will catch Tuple case below - } - } - - const ATuple* tup = ast->to(); - if (tup) { - out << "("; - for (size_t i = 0; i != tup->size(); ++i) - out << tup->at(i) << ((i != tup->size() - 1) ? " " : ""); - return out << ")"; - } - - return out << "?"; -} - -void -pprint_internal(ostream& out, const AST* ast, unsigned indent) -{ - const ATuple* tup = ast->to(); - if (tup && tup->size() > 0) { - const string head = tup->at(0)->str(); - ASymbol* headSym = tup->at(0)->to(); - out << "("; - pprint_internal(out, tup->at(0), indent); - unsigned child_indent = indent; - if (tup->size() > 1) { - out << " "; - if (headSym && headSym->cppstr == "fn") { - out << tup->at(1); - child_indent = indent + 4; - } else { - child_indent += head.length() + 1; - pprint_internal(out, tup->at(1), child_indent); - } - } - for (size_t i = 2; i < tup->size(); ++i) { - out << endl << string().insert(0, child_indent, ' '); - pprint_internal(out, tup->at(i), child_indent); - } - out << ")"; - if (headSym && headSym->cppstr == "fn") - out << endl << string().insert(0, indent + 4, ' '); - } else { - out << ast; - } -} - -void -pprint(ostream& out, const AST* ast) -{ - pprint_internal(out, ast, 0); - out << endl; -} - -- cgit v1.2.1