#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); \ if(dst != NULL) \ { \ dst->desc = (Desc*) __FORWARD_PTR__; \ dst->_forward_ptr = thunk; \ } #define arg_from_thunk(desc, arg) \ if(((FunEntry*) (desc))->strictness & argmask) \ { \ 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, stack_top_b); \ } \ else \ { \ push_a(create_thunk(arg, frame_ptr)); \ } \ argmask <<= 1; struct Thunk* create_thunk(Code* expr, int frame_ptr) { assert(expr != NULL); // TODO: check over application // TODO: enforce strictness in ADT/Record switch (expr->type) { case CT_APP: { 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] = create_thunk(((AppEntry*) expr)->args[i], frame_ptr); } return thunk; } case CT_APP_DYN: { Thunk* basethunk = local(frame_ptr, ((AppEntry*)expr)->var.index); if(!((AppEntry*)expr)->var.base.strict) 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); for (int i = 0; i < basethunk->desc->arity; i++) { thunk->_args[i] = basethunk->_args[i]; } for (int i = 0; i < expr->nr_args; i++) { thunk->_args[basethunk->desc->arity + i] = create_thunk(((AppEntry*) expr)->args[i], frame_ptr); } return thunk; } case CT_VAR: return local(frame_ptr, ((VarEntry*) expr)->index); case CT_VAR_STRICT: { Thunk* arg = local(frame_ptr, ((VarEntry*) expr)->index); if(arg->desc->unboxable) { return createT(arg); } else { return arg; } } case CT_THUNK: return &((ThunkEntry*) expr)->thunk; case CT_SELECT: case CT_IF: // Only here to avoid intervalum check at switch abort("Unexpected code type"); } } void exec(Code* expr, int frame_ptr, int root_frame_ptr, int root_frame_ptr_b) { while(1) { assert(expr != NULL); assert(stack_top_a < STACK_SIZE_A); // TODO: check over application // TODO: enforce strictness in ADT/Record switch (expr->type) { case CT_APP: { Desc* slice = ((AppEntry*) expr)->f; switch (slice->type) { case FT_PRIM: { for (int i = 0; i < expr->nr_args; i++) { push_a(alloc_b()); exec(((AppEntry*) expr)->args[i], frame_ptr, stack_top_a, stack_top_b); } ((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 < 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 == expr->nr_args); for (int i = 0; i < expr->nr_args; i++) { thunk->_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_APP_DYN: { Thunk* basethunk = local(frame_ptr, ((AppEntry*)expr)->var.index); if(!((AppEntry*)expr)->var.base.strict) 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_PRIM: { for (int i = 0; i < basethunk->desc->arity; i++) { 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, stack_top_b); } ((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); for (int i = 0; i < basethunk->desc->arity; i++) { thunk->_args[i] = basethunk->_args[i]; } for (int i = 0; i < expr->nr_args; i++) { thunk->_args[basethunk->desc->arity + 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_PRIM: { 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: { push_a(NULL); exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a, stack_top_b); Thunk* 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_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, stack_top_b); 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, stack_top_b); thunk = pop_a(); return thunk; } case FT_PRIM: { push_a(thunk); int frame_ptr = stack_top_a; for (int i = 0; i < thunk->desc->arity; i++) { 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; } }