Add support for data types.

runtime.c

@@ -35,6 +35,12 @@ struct node_ind {
     struct node_parent* next;
 };
 
+struct node_data {
+    char tag;
+    char ctag;
+    struct node_parent** array;
+};
+
 void stack_init(struct stack* stack) {
     stack->size = 16;
     stack->count = 0;
@@ -46,26 +52,31 @@ void stack_free(struct stack* stack) {
 }
 
 void stack_push(struct stack* stack, struct node_parent* node) {
+    printf("push\n");
     assert(stack->count < stack->size);
     stack->data[stack->count++] = node;
 }
 
 struct node_parent* stack_peek(struct stack* stack, int32_t offset) {
+    printf("peek %d\n", offset);
     assert(offset + 1 <= stack->count);
     return stack->data[stack->count - offset - 1];
 }
 
 struct node_parent* stack_pop(struct stack* stack) {
+    printf("pop\n");
     assert(stack->count > 0);
     return stack->data[--stack->count];
 }
 
 void stack_popn(struct stack* stack, int32_t count) {
+    printf("popn %d\n", count);
     assert(stack->count >= count);
     stack->count -= count;
 }
 
 void stack_update(struct stack* stack, int32_t offset) {
+    printf("update %d\n", offset);
     assert(stack->count >= offset + 2);
     struct node_ind* to_replace = (struct node_ind*) stack->data[stack->count - 1 - 1 - offset];
     to_replace->tag = 3;
@@ -81,6 +92,7 @@ void stack_alloc(struct stack* stack, int32_t count) {
 }
 
 void stack_slide(struct stack* stack, int32_t count) {
+    printf("slide %d\n", count);
     assert(stack->count > count); 
     stack->data[stack->count - 1 - count] = stack->data[stack->count - 1];
     stack->count -= count;
@@ -96,6 +108,7 @@ int32_t stack_size(struct stack* stack) {
 }
 
 struct node_parent* malloc_node_num(int32_t value) {
+    printf("alloc int %d\n", value);
     struct node_num* node = malloc(sizeof(struct node_app));
     node->tag = 0;
     node->value = value;
@@ -103,6 +116,7 @@ struct node_parent* malloc_node_num(int32_t value) {
 }
 
 struct node_parent* malloc_node_app(struct node_parent* left, struct node_parent* right) {
+    printf("alloc app\n");
     struct node_app* node = malloc(sizeof(struct node_app));
     node->tag = 1;
     node->left = left;
@@ -110,6 +124,7 @@ struct node_parent* malloc_node_app(struct node_parent* left, struct node_parent
     return (struct node_parent*) node;
 }
 struct node_parent* malloc_node_global(int32_t arity, void (*function)(struct stack*)) {
+    printf("alloc global %d %p\n", arity, function);
     struct node_global* node = malloc(sizeof(struct node_app));
     node->tag = 2;
     node->arity = arity;
@@ -117,23 +132,34 @@ struct node_parent* malloc_node_global(int32_t arity, void (*function)(struct st
     return (struct node_parent*) node;
 }
 struct node_parent* malloc_node_indirect(struct node_parent* target) {
+    printf("alloc ind\n");
     struct node_ind* node = malloc(sizeof(struct node_app));
     node->tag = 3;
     node->next = target;
     return (struct node_parent*) node;
 }
+struct node_parent* malloc_node_data(char tag, struct node_parent** array) {
+    printf("alloc data %d\n", tag);
+    struct node_data* node = malloc(sizeof(struct node_data));
+    node->tag = 4;
+    node->ctag = tag;
+    node->array = array;
+    return (struct node_parent*) node;
+}
 
 void unwind(struct stack* stack) {
     while(1) {
         assert(stack_size(stack) != 0);
         struct node_parent* node = stack_peek(stack, 0);
-        if(node->tag == 0) {
+        if(node->tag == 0 || node->tag == 4) {
             return;
         } else if(node->tag == 1) {
+            printf("unwind\n");
             stack_push(stack, ((struct node_app*) node)->left);
         } else if(node->tag == 2) {
             struct node_global* global = (struct node_global*) node;
             if(stack->size > global->arity) {
+                printf("making call\n");
                 struct node_parent* root = stack_peek(stack, global->arity);
                 stack_popn(stack, global->arity + 1);
                 stack_push(stack, root);
@@ -142,12 +168,15 @@ void unwind(struct stack* stack) {
                     stack_push(stack, app->right);
                     root = app->left;
                 }
+                printf("calling supercomb\n");
                 global->function(stack);
             } else {
+                printf("underflow\n");
                 stack_popn(stack, stack_size(stack) - 1);
                 return;
             }
         } else if(node->tag == 3) {
+            printf("handling indirection\n");
             struct node_ind* ind = (struct node_ind*) node;
             stack_pop(stack);
             stack_push(stack, ind->next);
@@ -155,9 +184,34 @@ void unwind(struct stack* stack) {
     }
 }
 
+struct node_parent* pack(struct stack* stack, char tag, int count) {
+    printf("pack %d %d\n", tag, count);
+    assert(stack->count >= count);
+    struct node_parent** new_array = malloc(sizeof(struct node_parent*) * count);
+    struct node_parent** current_slot = new_array;
+
+    while(count--) {
+        *current_slot = stack_pop(stack);
+        current_slot++;
+    }
+    
+    return malloc_node_data(tag, new_array);
+}
+
+void split(struct stack* stack, struct node_parent* node, int count) {
+    assert(stack->count > 0);
+    printf("split %d\n", count);
+    struct node_data* data = (struct node_data*) node;
+    while(count > 0) {
+        stack_push(stack, data->array[count - 1]);
+        count--;
+    }
+}
+
 struct node_parent* eval(struct node_parent* start) {
     struct stack new_stack;
     stack_init(&new_stack);
+    printf("eval begin\n");
     stack_push(&new_stack, start);
     unwind(&new_stack);
     struct node_parent* final_node = stack_pop(&new_stack);
@@ -169,4 +223,7 @@ extern void main_supercomb(struct stack* stack);
 
 int main(int argc, char** argv) {
     struct node_parent* result = eval(malloc_node_global(0, main_supercomb));
+    if(result->tag == 0) {
+        printf("integer generated! value: %d\n", ((struct node_num*)result)->value);
+    }
 }

src/ast.cpp

@@ -3,6 +3,10 @@
 #include "error.hpp"
 
 namespace lily {
+    type* ast::typecheck(type_manager& mgr, std::shared_ptr<type_env> env) {
+        return (ast_type = check(mgr, env));
+    }
+
     type* ast_num::check(type_manager& mgr, std::shared_ptr<type_env> env) {
         return mgr.require_type("Int");
     }
@@ -12,8 +16,8 @@ namespace lily {
     }
 
     type* ast_app::check(type_manager& mgr, std::shared_ptr<type_env> env) {
-        type* ltype = left->check(mgr, env);
+        type* ltype = left->typecheck(mgr, env);
-        type* rtype = right->check(mgr, env);
+        type* rtype = right->typecheck(mgr, env);
 
         // We LHS has to be a function, so unify LHS with that.
         type_func* f = mgr.create_type<type_func>(nullptr, nullptr);
@@ -31,8 +35,8 @@ namespace lily {
     }
 
     type* ast_op::check(type_manager& mgr, std::shared_ptr<type_env> env) {
-        type* ltype = left->check(mgr, env);
+        type* ltype = left->typecheck(mgr, env);
-        type* rtype = right->check(mgr, env);
+        type* rtype = right->typecheck(mgr, env);
 
         // We know the thing has to be a nunmber, so we unify with number type.
         type* inttype = mgr.require_type("Int");
@@ -48,9 +52,9 @@ namespace lily {
     type* ast_let::check(type_manager& mgr, std::shared_ptr<type_env> env) {
         if(env->identifier_exists(name))
             throw error("invalid redefinition of variable.");
-        type* etype = expr->check(mgr, env);
+        type* etype = expr->typecheck(mgr, env);
         auto new_env = env->with_type(name, etype);
-        return in->check(mgr, new_env);
+        return in->typecheck(mgr, new_env);
     }
 
     type* ast_letrec::check(type_manager& mgr, std::shared_ptr<type_env> env) {
@@ -58,14 +62,14 @@ namespace lily {
             throw error("invalid redefinition of variable.");
         type* variable_type = mgr.create_type<type_parameter>();
         auto new_env = env->with_type(name, variable_type);
-        type* etype = expr->check(mgr, new_env);
+        type* etype = expr->typecheck(mgr, new_env);
         if(!variable_type->unify_with(etype))
             throw error("incompatible type for variable");
-        return in->check(mgr, new_env);
+        return in->typecheck(mgr, new_env);
     }
 
     type* ast_case::check(type_manager& mgr, std::shared_ptr<type_env> env) {
-        type* ctype = of->check(mgr, env);
+        type* ctype = of->typecheck(mgr, env);
         type* pattern_type = nullptr;
         type* branch_type = nullptr;
         for(auto& branch : branches) {
@@ -82,7 +86,7 @@ namespace lily {
             if(!pattern_type->unify_with(ctype))
                 throw error("pattern type doesn't match case value type");
 
-            type* new_branch_type = branch.expr->check(mgr, new_env);
+            type* new_branch_type = branch.expr->typecheck(mgr, new_env);
             if(!branch_type) {
                 branch_type = new_branch_type;
             } else {
@@ -91,6 +95,8 @@ namespace lily {
             }
         }
 
+        case_type = pattern_type;
+
         return branch_type;
     }
 
@@ -143,6 +149,55 @@ namespace lily {
     }
 
     void ast_case::compile(instruction_manager& mgr, std::vector<instruction*>& into, std::shared_ptr<compile_env> env) {
-        throw error("case expressions unimplemented");
+        type_parameter* param;
+        type* current_type = case_type;
+        while((param = dynamic_cast<type_parameter*>(current_type))) current_type = param->actual_type;
+
+        type_data* data = dynamic_cast<type_data*>(current_type);
+        if(!data) throw error("case expression must be a data type!");
+
+        of->compile(mgr, into, env);
+        into.push_back(mgr.add_instruction<instruction_eval>());
+
+        instruction_jump* ijump = mgr.add_instruction<instruction_jump>();
+        int ccount = data->constructors.size();
+        bool branched[ccount];
+        for(int i = 0; i < ccount; i++) branched[i] = false;
+        for(auto& branch : branches) {
+            auto& pattern = branch.pattern;
+            pattern_var* var_pattern = dynamic_cast<pattern_var*>(pattern.get());
+            if(var_pattern) {
+                auto new_env = std::make_shared<compile_env_var>(var_pattern->name);
+                new_env->set_parent(env);
+                std::vector<instruction*> new_branch;
+                branch.expr->compile(mgr, new_branch, new_env);
+                ijump->instructions.push_back(std::move(new_branch));
+
+                for(int i = 0; i < ccount; i++) {
+                    if(!branched[i]) ijump->const_instructions[i] = ijump->instructions.size() - 1;
+                    branched[i] = true;
+                }
+            } else {
+                pattern_cons* cons_pattern = dynamic_cast<pattern_cons*>(pattern.get());
+                int constructor = std::distance(data->constructors.begin(), data->constructors.find(cons_pattern->name));
+                if(branched[constructor]) throw error("cannot branch on the same constructor twice");
+                branched[constructor] = true;
+
+                int vcount = cons_pattern->vnames.size();
+                for(int i = 0; i < cons_pattern->vnames.size(); i++) {
+                    auto new_env = std::make_shared<compile_env_var>(cons_pattern->vnames[vcount - i - 1]);
+                    new_env->set_parent(env);
+                    env = new_env;
+                }
+
+                std::vector<instruction*> into;
+                into.push_back(mgr.add_instruction<instruction_split>(vcount));
+                branch.expr->compile(mgr, into, env);
+                ijump->instructions.push_back(std::move(into));
+                ijump->const_instructions[constructor] = ijump->instructions.size() - 1;
+            }
+        }
+        for(int i = 0; i < ccount; i++) if(!branched[i]) throw error("non-total case expression");
+        into.push_back(ijump);
     }
 }

src/ast.hpp

@@ -11,9 +11,12 @@ namespace lily {
     class type_env;
 
     struct ast {
+        type* ast_type = nullptr;
+
         virtual ~ast() = default;
         virtual type* check(type_manager& mgr, std::shared_ptr<type_env> env) = 0;
         virtual void compile(instruction_manager& mgr, std::vector<instruction*>& into, std::shared_ptr<compile_env> env) = 0;
+        type* typecheck(type_manager& mgr, std::shared_ptr<type_env> env);
     };
 
     typedef std::unique_ptr<ast> ast_ptr;
@@ -86,6 +89,7 @@ namespace lily {
             ast_ptr expr;
         };
 
+        type* case_type;
         ast_ptr of;
         std::vector<branch> branches;
 

src/gmachine.cpp

@@ -110,7 +110,6 @@ namespace lily {
         llvm::Value* stack = ctx.get_current_function()->arg_begin();
         llvm::Value* new_node = builder.CreateCall(malloc_node_global_func,
                 { get_int8_constant(ctx.get_supercombinator_arity(name)), ctx.get_supercombinator_function(name) }, "temp");
-        // TODO get arity
         builder.CreateCall(stack_push_func, { stack, new_node });
     }
 
@@ -177,14 +176,41 @@ namespace lily {
     }
 
     void instruction_pack::gen_llvm(llvm_context& ctx) {
-        
+        llvm::Value* stack = ctx.get_current_function()->arg_begin();
+        llvm::Value* packed = builder.CreateCall(pack_func, { stack, get_int8_constant(constructor), get_int32_constant(arity) }, "temp");
+        builder.CreateCall(stack_push_func, { stack, packed });
     }
 
     void instruction_split::gen_llvm(llvm_context& ctx) {
-        
+        llvm::Value* stack = ctx.get_current_function()->arg_begin();
+        llvm::Value* popped = builder.CreateCall(stack_pop_func, { stack }, "temp");
+        builder.CreateCall(split_func, { stack, popped, get_int32_constant(arity) });
     }
 
     void instruction_jump::gen_llvm(llvm_context& ctx) {
+        llvm::Value* stack = ctx.get_current_function()->arg_begin();
+        llvm::BasicBlock* safety_block = llvm::BasicBlock::Create(context, "safety", ctx.get_current_function());
+        llvm::Value* top = builder.CreateCall(stack_peek_func, { stack, get_int32_constant(0) }, "temp");
+        llvm::Value* top_data = builder.CreatePointerCast(top, llvm::PointerType::getUnqual(node_data_type), "temp");
+        llvm::Value* top_data_tag_ptr = builder.CreateGEP(top_data, { get_int32_constant(0), get_int32_constant(1) }, "temp");
+        llvm::Value* top_data_tag = builder.CreateLoad(top_data_tag_ptr, "temp");
+        llvm::SwitchInst* swtch = builder.CreateSwitch(top_data_tag, safety_block);
 
+        std::vector<llvm::BasicBlock*> blocks;
+        for(auto& branch : instructions) {
+            llvm::BasicBlock* new_block = llvm::BasicBlock::Create(context, "branch", ctx.get_current_function());
+            builder.SetInsertPoint(new_block);
+            for(auto& i : branch) {
+                i->gen_llvm(ctx);
+            }
+            builder.CreateBr(safety_block);
+            blocks.push_back(new_block);
+        }
+
+        for(auto& pair : const_instructions) {
+            swtch->addCase(get_int8_constant(pair.first), blocks[pair.second]);
+        }
+
+        builder.SetInsertPoint(safety_block);
     }
 }

src/gmachine.hpp

@@ -129,6 +129,7 @@ namespace lily {
 
     struct instruction_jump : instruction {
         std::vector<std::vector<instruction*>> instructions;
+        std::map<int, int> const_instructions;
         std::ostream& to_stream(std::ostream& os);
         void gen_llvm(llvm_context& ctx);
     };

src/llvm.cpp

@@ -36,7 +36,10 @@ namespace lily {
     llvm::Function* malloc_node_app_func;
     llvm::Function* malloc_node_global_func;
     llvm::Function* malloc_node_ind_func;
+    llvm::Function* malloc_node_data_func;
 
+    llvm::Function* pack_func;
+    llvm::Function* split_func;
     llvm::Function* eval_func;
 
     llvm::IntegerType* tag_type;
@@ -46,20 +49,21 @@ namespace lily {
     llvm::StructType* node_app_type;
     llvm::StructType* node_global_type;
     llvm::StructType* node_indirect_type;
+    llvm::StructType* node_data_type;
 
     static void initialize_llvm() {
 
     }
 
-    llvm::Value* get_int32_constant(int value) {
+    llvm::ConstantInt* get_int32_constant(int value) {
         return llvm::ConstantInt::get(context, llvm::APInt(32, value));
     }
 
-    llvm::Value* get_int64_constant(long int value) {
+    llvm::ConstantInt* get_int64_constant(long int value) {
         return llvm::ConstantInt::get(context, llvm::APInt(64, value));
     }
 
-    llvm::Value* get_int8_constant(char value) {
+    llvm::ConstantInt* get_int8_constant(char value) {
         return llvm::ConstantInt::get(context, llvm::APInt(8, value));
     }
 
@@ -137,6 +141,21 @@ namespace lily {
                 llvm::Function::LinkageTypes::ExternalLinkage,
                 "malloc_node_indirect",
                 &module);
+        malloc_node_data_func = llvm::Function::Create(
+                llvm::FunctionType::get(node_pointer_type, { tag_type, llvm::IntegerType::get(context, 32) }, false),
+                llvm::Function::LinkageTypes::ExternalLinkage,
+                "malloc_node_data",
+                &module);
+        pack_func = llvm::Function::Create(
+                llvm::FunctionType::get(node_pointer_type, { stack_pointer_type, tag_type, llvm::IntegerType::get(context, 32) }, false),
+                llvm::Function::LinkageTypes::ExternalLinkage,
+                "pack",
+                &module);
+        split_func = llvm::Function::Create(
+                llvm::FunctionType::get(llvm::Type::getVoidTy(context), { stack_pointer_type, node_pointer_type,  llvm::IntegerType::get(context, 32) }, false),
+                llvm::Function::LinkageTypes::ExternalLinkage,
+                "split",
+                &module);
         eval_func = llvm::Function::Create(
                 llvm::FunctionType::get(node_pointer_type, { node_pointer_type }, false),
                 llvm::Function::LinkageTypes::ExternalLinkage,
@@ -155,6 +174,7 @@ namespace lily {
         node_app_type = llvm::StructType::create(context, "node_app");
         node_global_type = llvm::StructType::create(context, "node_global");
         node_indirect_type = llvm::StructType::create(context, "node_indirect");
+        node_data_type = llvm::StructType::create(context, "node_data");
 
         supercomb_function_type = llvm::FunctionType::get(llvm::Type::getVoidTy(context), { stack_pointer_type }, false);
         supercomb_function_pointer_type = llvm::PointerType::getUnqual(supercomb_function_type);
@@ -165,6 +185,7 @@ namespace lily {
         node_app_type->setBody(tag_type, node_pointer_type, node_pointer_type);
         node_global_type->setBody(tag_type, tag_type, supercomb_function_pointer_type);
         node_indirect_type->setBody(tag_type, node_pointer_type);
+        node_data_type->setBody(tag_type, tag_type, llvm::PointerType::getUnqual(node_pointer_type));
     }
 
     void llvm_generate(const std::string& filename) {

src/llvm.hpp

@@ -32,7 +32,10 @@ namespace lily {
     extern llvm::Function* malloc_node_app_func;
     extern llvm::Function* malloc_node_global_func;
     extern llvm::Function* malloc_node_ind_func;
+    extern llvm::Function* malloc_node_data_func;
     
+    extern llvm::Function* pack_func;
+    extern llvm::Function* split_func;
     extern llvm::Function* eval_func;
 
     extern llvm::IntegerType* tag_type;
@@ -42,10 +45,11 @@ namespace lily {
     extern llvm::StructType* node_app_type;
     extern llvm::StructType* node_global_type;
     extern llvm::StructType* node_indirect_type;
+    extern llvm::StructType* node_data_type;
 
-    llvm::Value* get_int32_constant(int value);
+    llvm::ConstantInt* get_int32_constant(int value);
-    llvm::Value* get_int64_constant(int value);
+    llvm::ConstantInt* get_int64_constant(int value);
-    llvm::Value* get_int8_constant(char value);
+    llvm::ConstantInt* get_int8_constant(char value);
 
     void llvm_init();
     void llvm_generate(const std::string& filename);

src/main.cpp

@@ -8,8 +8,10 @@ int main() {
     try {
 
         lily::program_ptr prog = lily::parse(
-                "defn magic x = { let z = { x * 2 } in  { 326 + z + z } }\n"
+                "data Bool = { False, True }\n"
-                "defn main = { magic 1 + magic 0 }"
+                "defn if c t e = { case not c of { True -> { t } False -> { e } } }\n"
+                "defn not b = { case b of { True -> { False } False -> { True } } }\n"
+                "defn main = { if True 3 2 }"
                 );
         prog->gen_llvm();
     } catch(lily::error& e) {

src/parser.cpp

@@ -287,7 +287,7 @@ namespace lily {
         // Now that we have collected the functions, check their bodies.
         for(auto& pair : functions) {
             type* body_type =
-                pair.second.body->check(type_mgr, function_envs[pair.first]);
+                pair.second.body->typecheck(type_mgr, function_envs[pair.first]);
             if(!function_output_types[pair.first]->unify_with(body_type))
                 throw error("unable to unify function type");
         }
@@ -315,6 +315,7 @@ namespace lily {
 
     void program::compile(instruction_manager& mgr, std::map<std::string, std::vector<instruction*>>& into) {
         register_internal(mgr, into);
+        type_mgr.register_constructor_supercombs(mgr, into);
         for(auto& pair : functions) {
             std::shared_ptr<compile_env> fresh_env = std::make_shared<compile_env_offset>(0);
             size_t count = pair.second.params.size();
@@ -342,7 +343,8 @@ namespace lily {
         compile(mgr, gcode);
 
         for(auto& pair : gcode) {
-            int arity = functions.count(pair.first) ? functions[pair.first].params.size() : 2;
+            int arity = functions.count(pair.first) ? functions[pair.first].params.size() : type_mgr.constructor_arity(pair.first);
+            if(arity == -1) arity = 2;
             ctx.add_supercombinator(pair.first, arity);
         }
 

src/type_manager.cpp

@@ -3,6 +3,7 @@
 #include "error.hpp"
 #include "type.hpp"
 #include "type_checker.hpp"
+#include <vector>
 
 namespace lily {
     type_manager::type_manager() {
@@ -57,4 +58,31 @@ namespace lily {
             }
         }
     }
+
+    void type_manager::register_constructor_supercombs(instruction_manager& mgr, std::map<std::string, std::vector<instruction*>>& into) {
+        for(auto& type_ref : types) {
+            type_data* data_type = dynamic_cast<type_data*>(type_ref.get());
+            if(!data_type) continue;
+
+            for(auto& pair : data_type->constructors) {
+                std::vector<instruction*> is;
+                is.push_back(mgr.add_instruction<instruction_pack>(pair.second->id, pair.second->params.size()));
+                is.push_back(mgr.add_instruction<instruction_update>(0));
+                into[pair.first] = std::move(is);
+            }
+        }
+    }
+
+    int type_manager::constructor_arity(const std::string& name) {
+        for(auto& type_ref : types) {
+            type_data* data_type = dynamic_cast<type_data*>(type_ref.get());
+            if(!data_type) continue;
+
+            for(auto& pair : data_type->constructors) {
+                if(pair.first == name) return pair.second->params.size();
+            }
+        }
+        return -1;
+    }
+
 }

src/type_manager.hpp

@@ -3,6 +3,7 @@
 #include <map>
 #include <vector>
 #include "type.hpp"
+#include "gmachine.hpp"
 
 namespace lily {
     class type_env;
@@ -29,5 +30,7 @@ namespace lily {
             type* require_type(const std::string& name) const;
 
             void register_constructors(std::shared_ptr<type_env> env);
+            void register_constructor_supercombs(instruction_manager& mgr, std::map<std::string, std::vector<instruction*>>& into);
+            int constructor_arity(const std::string& name);
     };
 }