#include #include #include #include #include "debug.h" #include "code.h" #include "mem.h" #include "desc.h" // For compressing the source code a bit #define follow_thunk(thunk) if (thunk->desc == (Desc*) __FORWARD_PTR__) thunk = thunk->_forward_ptr; #define forward_thunk(thunk, frame_ptr) \ Thunk* dst = get_dst(frame_ptr); \ dst->desc = (Desc*) __FORWARD_PTR__; \ dst->_forward_ptr = thunk; #define arg_from_thunk(descarg, arg) \ if(((FunEntry*) (descarg))->strictness & argmask && !arg->desc->hnf) \ { \ push_a(eval(arg)); \ } \ else \ { \ push_a(arg); \ } \ argmask <<= 1; #define arg_from_code(descarg, arg) \ if(((FunEntry*) (descarg))->strictness & argmask) \ { \ Thunk* phl = alloc_b(); \ phl->desc = (Desc*) __STACK_PLACEHOLDER__; \ push_a(phl); \ exec(arg, frame_ptr, stack_top_a); \ } \ else \ { \ push_a(arg->create_thunk(arg, frame_ptr)); \ } \ argmask <<= 1; struct Thunk* create_thunk_app_static(Code* expr, int frame_ptr) { Thunk* thunk = createF(((AppEntry*) expr)->f); assert(thunk->desc->arity == expr->nr_args); for (int i = 0; i < expr->nr_args; i++) { thunk->_args[i] = ((AppEntry*) expr)->args[i]->create_thunk(((AppEntry*) expr)->args[i], frame_ptr); } return thunk; } struct Thunk* create_thunk_app_dyn(Code* expr, int frame_ptr) { Thunk* basethunk = local(frame_ptr, ((AppEntry*)expr)->var.index); if(!basethunk->desc->hnf) basethunk = eval(basethunk); Desc* slice = get_slice(basethunk->desc->type == FT_SLICE ? ((SliceEntry*) basethunk->desc)->forward_ptr : basethunk->desc, basethunk->desc->arity + expr->nr_args); Thunk* thunk = createF(slice); assert(thunk->desc->arity == basethunk->desc->arity + expr->nr_args); memcpy(&thunk->_args, &basethunk->_args, sizeof(Thunk*) * basethunk->desc->arity); for (int i = 0; i < expr->nr_args; i++) { thunk->_args[basethunk->desc->arity + i] = ((AppEntry*) expr)->args[i]->create_thunk(((AppEntry*) expr)->args[i], frame_ptr); } return thunk; } struct Thunk* create_thunk_var(Code* expr, int frame_ptr) { return local(frame_ptr, ((VarEntry*) expr)->index); } struct Thunk* create_thunk_var_strict(Code* expr, int frame_ptr) { Thunk* arg = local(frame_ptr, ((VarEntry*) expr)->index); if(arg->desc->unboxable) { return createT(arg); } else { return arg; } } struct Thunk* create_thunk_thunk(Code* expr, int frame_ptr) { return &((ThunkEntry*) expr)->thunk; } void set_create_thunk_fun(Code* code) { switch(code->type) { case CT_APP_PRIM1: case CT_APP_PRIM_S: case CT_APP_PRIM2: case CT_APP_PRIM_ST: case CT_APP_PRIM_TS: case CT_APP_PRIM_SS: case CT_APP_PRIM_AT: case CT_APP_PRIM_TA: case CT_APP_PRIM_AS: case CT_APP_PRIM_SA: case CT_APP_FUN: case CT_APP_THUNK: code->create_thunk = create_thunk_app_static; break; case CT_APP_DYN: code->create_thunk = create_thunk_app_dyn; break; case CT_VAR: code->create_thunk = create_thunk_var; break; case CT_VAR_STRICT: code->create_thunk = create_thunk_var_strict; break; case CT_THUNK: code->create_thunk = create_thunk_thunk; break; case CT_SELECT: case CT_IF: code->create_thunk = NULL; break; } } void exec(Code* expr, int frame_ptr, int root_frame_ptr) { int root_frame_ptr_b = stack_top_b; while(1) { assert(expr != NULL); assert(stack_top_a < STACK_SIZE_A); assert(stack_top_b < STACK_SIZE_B); // TODO: check over application // TODO: enforce strictness in ADT/Record switch (expr->type) { case CT_APP_PRIM1: { push_a(alloc_b()); exec(((AppEntry*) expr)->args[0], frame_ptr, stack_top_a); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_S: { push_a(local(frame_ptr, ((VarEntry*) ((AppEntry*) expr)->args[0])->index)); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_ST: { push_a(local(frame_ptr, ((VarEntry*) ((AppEntry*) expr)->args[0])->index)); push_a(&((ThunkEntry*) ((AppEntry*) expr)->args[1])->thunk); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_TS: { push_a(&((ThunkEntry*) ((AppEntry*) expr)->args[0])->thunk); push_a(local(frame_ptr, ((VarEntry*) ((AppEntry*) expr)->args[1])->index)); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_SS: { push_a(local(frame_ptr, ((VarEntry*) ((AppEntry*) expr)->args[0])->index)); push_a(local(frame_ptr, ((VarEntry*) ((AppEntry*) expr)->args[1])->index)); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_TA: { push_a(&((ThunkEntry*) ((AppEntry*) expr)->args[0])->thunk); push_a(alloc_b()); exec(((AppEntry*) expr)->args[1], frame_ptr, stack_top_a); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_AT: { push_a(alloc_b()); exec(((AppEntry*) expr)->args[0], frame_ptr, stack_top_a); push_a(&((ThunkEntry*) ((AppEntry*) expr)->args[1])->thunk); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_AS: { push_a(alloc_b()); exec(((AppEntry*) expr)->args[0], frame_ptr, stack_top_a); push_a(local(frame_ptr, ((VarEntry*) ((AppEntry*) expr)->args[1])->index)); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM_SA: { push_a(local(frame_ptr, ((VarEntry*) ((AppEntry*) expr)->args[0])->index)); push_a(alloc_b()); exec(((AppEntry*) expr)->args[1], frame_ptr, stack_top_a); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_PRIM2: { push_a(alloc_b()); exec(((AppEntry*) expr)->args[0], frame_ptr, stack_top_a); push_a(alloc_b()); exec(((AppEntry*) expr)->args[1], frame_ptr, stack_top_a); ((PrimEntry*) ((AppEntry*) expr)->f)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_FUN: { Desc* slice = ((AppEntry*) expr)->f; int new_frame_ptr = stack_top_a; int argmask = 1; for (int i = 0; i < expr->nr_args; i++) { arg_from_code(slice, ((AppEntry*) expr)->args[i]); } expr = ((FunEntry*) slice)->body; frame_ptr = new_frame_ptr; continue; } case CT_APP_THUNK: { Desc* slice = ((AppEntry*) expr)->f; Thunk* thunk = updateF(get_dst(root_frame_ptr), slice); assert(thunk->desc->arity == expr->nr_args); for (int i = 0; i < expr->nr_args; i++) { thunk->_args[i] = ((AppEntry*) expr)->args[i]->create_thunk(((AppEntry*) expr)->args[i], frame_ptr); } set_return(root_frame_ptr, thunk); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_APP_DYN: { Thunk* basethunk = local(frame_ptr, ((AppEntry*)expr)->var.index); if(!basethunk->desc->hnf) basethunk = eval(basethunk); Desc* slice = get_slice(basethunk->desc->type == FT_SLICE ? ((SliceEntry*) basethunk->desc)->forward_ptr : basethunk->desc, basethunk->desc->arity + expr->nr_args); switch(slice->type) { case FT_PRIM1: case FT_PRIM2: { for (int i = 0; i < basethunk->desc->arity; i++) { if(basethunk->_args[i]->desc->hnf) { push_a(basethunk->_args[i]); } else { push_a(eval(basethunk->_args[i])); } } for (int i = 0; i < expr->nr_args; i++) { push_a(alloc_b()); exec(((AppEntry*) expr)->args[i], frame_ptr, stack_top_a); } ((PrimEntry*) slice)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case FT_FUN: { int new_frame_ptr = stack_top_a; int argmask = 1; for (int i = 0; i < basethunk->desc->arity; i++) { arg_from_thunk(slice, basethunk->_args[i]) } for (int i = 0; i < expr->nr_args; i++) { arg_from_code(slice, ((AppEntry*) expr)->args[i]); } expr = ((FunEntry*) slice)->body; frame_ptr = new_frame_ptr; continue; } case FT_SLICE: case FT_ADT: case FT_RECORD: { Thunk* thunk = updateF(get_dst(root_frame_ptr), slice); assert(thunk->desc->arity == basethunk->desc->arity + expr->nr_args); memcpy(&thunk->_args, &basethunk->_args, sizeof(Thunk*) * basethunk->desc->arity); for (int i = 0; i < expr->nr_args; i++) { thunk->_args[basethunk->desc->arity + i] = ((AppEntry*) expr)->args[i]->create_thunk(((AppEntry*) expr)->args[i], frame_ptr); } set_return(root_frame_ptr, thunk); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case FT_BOXED_LIT: abort("Literal unexpected here"); case FT_CAF: case FT_CAF_REDUCED: not_implemented("CAF"); } } case CT_VAR_STRICT: { Thunk* arg = local(frame_ptr, ((VarEntry*) expr)->index); assert(is_hnf(arg)); if(arg->desc->unboxable) { arg = updateT(get_dst(root_frame_ptr), arg); } else { forward_thunk(arg, root_frame_ptr); } set_return(root_frame_ptr, arg); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_VAR: { Thunk* thunk = local(frame_ptr, ((VarEntry*) expr)->index); follow_thunk(thunk); forward_thunk(thunk, root_frame_ptr); set_return(root_frame_ptr, thunk); switch(thunk->desc->type) { case FT_FUN: { // Destroy stack frame before eval, it is not needed any more // Greatly reduces stack usage destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); frame_ptr = stack_top_a; // Here frame_ptr == root_frame_ptr int argmask = 1; for (int i = 0; i < thunk->desc->arity; i++) { arg_from_thunk(thunk->desc, thunk->_args[i]); } expr = ((FunEntry*) thunk->desc)->body; continue; } case FT_PRIM1: case FT_PRIM2: { for (int i = 0; i < thunk->desc->arity; i++) { push_a(eval(thunk->_args[i])); } ((PrimEntry*) thunk->desc)->exec(root_frame_ptr); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case FT_CAF: case FT_CAF_REDUCED: not_implemented("CAF"); case FT_SLICE: case FT_ADT: case FT_RECORD: case FT_BOXED_LIT: destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } } case CT_THUNK: { Thunk* thunk = &((ThunkEntry*) expr)->thunk; forward_thunk(thunk, root_frame_ptr); set_return(root_frame_ptr, thunk); destroy_stack_frame(root_frame_ptr); destroy_stack_frame_b(root_frame_ptr_b); return; } case CT_SELECT: { Thunk* pattern = alloc_b(); pattern->desc = (Desc*) __STACK_PLACEHOLDER__; push_a(pattern); exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a); pattern = pop_a(); assert(is_hnf(pattern)); assert(pattern->desc->type == FT_ADT); bool handled = false; for (int i = 0; i < expr->nr_cases; i++) { SelectCaseEntry* caseEntry = &((SelectEntry*) expr)->cases[i]; if (caseEntry->type == SC_CONS) { // Pattern match if ((Desc*) caseEntry->cons != pattern->desc) continue; // Put the constructor arguments to the stack if matches for (int i = 0; i < pattern->desc->arity; i++) { push_a(pattern->_args[i]); } } else if(caseEntry->type == SC_DEFAULT) { // accept it } else if (caseEntry->type == SC_LIT) { printf("Exec: Unhandled entry type in CT_SELECT (SC_LIT)"); exit(-1); } // must be SC_DEFAULT now handled = true; expr = caseEntry->body; break; } if(handled) continue; printf("Exec: no select cases matches"); print(pattern, false); exit(-1); } case CT_IF: { push_a(alloc_b()); exec(((IfEntry*) expr)->cond, frame_ptr, stack_top_a); Thunk* cond = pop_a(); if (readB(cond)) { expr = ((IfEntry*) expr)->texpr; continue; } else { expr = ((IfEntry*) expr)->fexpr; continue; } } } } } struct Thunk* eval(Thunk* thunk) { assert(thunk != NULL); follow_thunk(thunk); switch(thunk->desc->type) { case FT_FUN: { push_a(thunk); int frame_ptr = stack_top_a; int argmask = 1; for (int i = 0; i < thunk->desc->arity; i++) { arg_from_thunk(thunk->desc, thunk->_args[i]); } exec(((FunEntry*) thunk->desc)->body, frame_ptr, frame_ptr); thunk = pop_a(); return thunk; } case FT_PRIM1: case FT_PRIM2: { push_a(thunk); int frame_ptr = stack_top_a; for (int i = 0; i < thunk->desc->arity; i++) { if(thunk->_args[i]->desc->hnf) { push_a(thunk->_args[i]); } else { push_a(eval(thunk->_args[i])); } } ((PrimEntry*) thunk->desc)->exec(frame_ptr); stack_top_a = frame_ptr; thunk = pop_a(); return thunk; } case FT_CAF: case FT_CAF_REDUCED: not_implemented("CAF"); case FT_SLICE: case FT_ADT: case FT_RECORD: case FT_BOXED_LIT: return thunk; } }