From d3ae70c53d181683ebbaab2c4ff60ae0143fe84b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 2 Oct 2007 17:53:05 -0400 Subject: [PATCH] VM cleanup --- Makefile | 7 +- vm/callstack.c | 183 +++++++++++++ vm/callstack.h | 18 ++ vm/{compiler.c => code_heap.c} | 0 vm/{compiler.h => code_heap.h} | 0 vm/errors.c | 139 ++++++++++ vm/errors.h | 42 +++ vm/master.h | 7 +- vm/primitives.c | 1 - vm/{jit.c => quotations.c} | 49 ++++ vm/{jit.h => quotations.h} | 5 + vm/run.c | 412 +++++++++++++++++----------- vm/run.h | 120 +++++--- vm/stack.c | 483 --------------------------------- vm/stack.h | 93 ------- vm/types.c | 24 -- vm/types.h | 5 - 17 files changed, 772 insertions(+), 816 deletions(-) create mode 100644 vm/callstack.c create mode 100644 vm/callstack.h rename vm/{compiler.c => code_heap.c} (100%) rename vm/{compiler.h => code_heap.h} (100%) create mode 100644 vm/errors.c create mode 100644 vm/errors.h rename vm/{jit.c => quotations.c} (79%) rename vm/{jit.h => quotations.h} (50%) delete mode 100644 vm/stack.c delete mode 100644 vm/stack.h diff --git a/Makefile b/Makefile index c893c8f2e7..4cea362cff 100644 --- a/Makefile +++ b/Makefile @@ -34,10 +34,11 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/code_gc.o \ vm/primitives.o \ vm/run.o \ - vm/stack.o \ + vm/callstack.o \ vm/types.o \ - vm/jit.o \ - vm/utilities.o + vm/quotations.o \ + vm/utilities.o \ + vm/errors.o EXE_OBJS = $(PLAF_EXE_OBJS) diff --git a/vm/callstack.c b/vm/callstack.c new file mode 100644 index 0000000000..2c3328195f --- /dev/null +++ b/vm/callstack.c @@ -0,0 +1,183 @@ +#include "master.h" + +/* called before entry into Factor code. */ +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) +{ + stack_chain->callstack_bottom = callstack_bottom; +} + +void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator) +{ + CELL delta = (bottom - base); + +#ifdef CALLSTACK_UP_P + F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; + #define ITERATING_P (CELL)frame >= top +#else + F_STACK_FRAME *frame = (F_STACK_FRAME *)top; + #define ITERATING_P (CELL)frame < bottom +#endif + + while(ITERATING_P) + { + F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(frame,delta); + iterator(frame); + frame = next; + } +} + +void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator) +{ + CELL top = (CELL)(stack + 1); + CELL bottom = top + untag_fixnum_fast(stack->length); + CELL base = stack->bottom; + + iterate_callstack(top,bottom,base,iterator); +} + +F_CALLSTACK *allot_callstack(CELL size) +{ + F_CALLSTACK *callstack = allot_object( + CALLSTACK_TYPE, + callstack_size(size)); + callstack->length = tag_fixnum(size); + return callstack; +} + +/* We ignore the topmost frame, the one calling 'callstack', +so that set-callstack doesn't get stuck in an infinite loop. + +This means that if 'callstack' is called in tail position, we +will have popped a necessary frame... however this word is only +called by continuation implementation, and user code shouldn't +be calling it at all, so we leave it as it is for now. */ +F_STACK_FRAME *capture_start(void) +{ +#ifdef CALLSTACK_UP_P + F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1; + while(frame >= stack_chain->callstack_top + && FRAME_SUCCESSOR(frame) >= stack_chain->callstack_top) + { + frame = FRAME_SUCCESSOR(frame); + } + return frame + 1; +#else + return FRAME_SUCCESSOR(stack_chain->callstack_top); +#endif +} + +DEFINE_PRIMITIVE(callstack) +{ + F_STACK_FRAME *top = capture_start(); + F_STACK_FRAME *bottom = stack_chain->callstack_bottom; + + F_FIXNUM size = (CELL)bottom - (CELL)top; + if(size < 0) + size = 0; + + F_CALLSTACK *callstack = allot_callstack(size); + callstack->bottom = (CELL)bottom; + memcpy(FIRST_STACK_FRAME(callstack),top,size); + dpush(tag_object(callstack)); +} + +/* If a callstack object was captured at a different base stack height than +we have now, we have to patch up the back-chain pointers. */ +static F_FIXNUM delta; + +void adjust_stack_frame(F_STACK_FRAME *frame) +{ + FRAME_SUCCESSOR(frame) = REBASE_FRAME_SUCCESSOR(frame,delta); +} + +void adjust_callstack(F_CALLSTACK *stack, CELL bottom) +{ + delta = (bottom - stack->bottom); + iterate_callstack_object(stack,adjust_stack_frame); + stack->bottom = bottom; +} + +DEFINE_PRIMITIVE(set_callstack) +{ + F_CALLSTACK *stack = untag_callstack(dpop()); + + CELL bottom = (CELL)stack_chain->callstack_bottom; + + if(stack->bottom != bottom) + adjust_callstack(stack,bottom); + + set_callstack(stack_chain->callstack_bottom, + FIRST_STACK_FRAME(stack), + untag_fixnum_fast(stack->length), + memcpy); + + /* We cannot return here ... */ + critical_error("Bug in set_callstack()",0); +} + +/* C doesn't have closures... */ +static CELL frame_count; +static CELL frame_index; +static F_ARRAY *array; + +void count_stack_frame(F_STACK_FRAME *frame) { + frame_count += 2; +} + +CELL frame_type(F_STACK_FRAME *frame) +{ + return xt_to_compiled(frame->xt)->type; +} + +CELL frame_executing(F_STACK_FRAME *frame) +{ + F_COMPILED *compiled = xt_to_compiled(frame->xt); + CELL code_start = (CELL)(compiled + 1); + CELL literal_start = code_start + + compiled->code_length + + compiled->reloc_length; + + return get(literal_start); +} + +void stack_frame_to_array(F_STACK_FRAME *frame) +{ + CELL offset; + + if(frame_type(frame) == QUOTATION_TYPE) + offset = tag_fixnum(UNAREF(UNTAG(frame->array),frame->scan)); + else + offset = F; + +#ifdef CALLSTACK_UP_P + set_array_nth(array,frame_index++,frame_executing(frame)); + set_array_nth(array,frame_index++,offset); +#else + set_array_nth(array,frame_index--,offset); + set_array_nth(array,frame_index--,frame_executing(frame)); +#endif +} + +DEFINE_PRIMITIVE(callstack_to_array) +{ + F_CALLSTACK *stack = untag_callstack(dpop()); + + frame_count = 0; + iterate_callstack_object(stack,count_stack_frame); + + REGISTER_UNTAGGED(stack); + array = allot_array_internal(ARRAY_TYPE,frame_count); + UNREGISTER_UNTAGGED(stack); + + /* frame_count is equal to the total length now */ + +#ifdef CALLSTACK_UP_P + frame_index = 0; +#else + frame_index = frame_count - 1; +#endif + + iterate_callstack_object(stack,stack_frame_to_array); + + dpush(tag_object(array)); +} diff --git a/vm/callstack.h b/vm/callstack.h new file mode 100644 index 0000000000..b7ddf36426 --- /dev/null +++ b/vm/callstack.h @@ -0,0 +1,18 @@ +F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); + +#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) + +#define REBASE_FRAME_SUCCESSOR(frame,delta) (F_STACK_FRAME *)((CELL)FRAME_SUCCESSOR(frame) + delta) + +typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame); + +void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator); +void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator); +CELL frame_executing(F_STACK_FRAME *frame); +CELL frame_type(F_STACK_FRAME *frame); + +DECLARE_PRIMITIVE(callstack); +DECLARE_PRIMITIVE(set_datastack); +DECLARE_PRIMITIVE(set_retainstack); +DECLARE_PRIMITIVE(set_callstack); +DECLARE_PRIMITIVE(callstack_to_array); diff --git a/vm/compiler.c b/vm/code_heap.c similarity index 100% rename from vm/compiler.c rename to vm/code_heap.c diff --git a/vm/compiler.h b/vm/code_heap.h similarity index 100% rename from vm/compiler.h rename to vm/code_heap.h diff --git a/vm/errors.c b/vm/errors.c new file mode 100644 index 0000000000..88659e4654 --- /dev/null +++ b/vm/errors.c @@ -0,0 +1,139 @@ +#include "master.h" + +void fatal_error(char* msg, CELL tagged) +{ + fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged); + exit(1); +} + +void critical_error(char* msg, CELL tagged) +{ + fprintf(stderr,"You have triggered a bug in Factor. Please report.\n"); + fprintf(stderr,"critical_error: %s %lx\n",msg,tagged); + factorbug(); +} + +void throw_error(CELL error, F_STACK_FRAME *callstack_top) +{ + /* If error was thrown during heap scan, we re-enable the GC */ + gc_off = false; + + /* Reset local roots */ + extra_roots = stack_chain->extra_roots; + + /* If we had an underflow or overflow, stack pointers might be + out of bounds */ + fix_stacks(); + + dpush(error); + + /* If the error handler is set, we rewind any C stack frames and + pass the error to user-space. */ + if(userenv[BREAK_ENV] != F) + { + /* Errors thrown from C code pass NULL for this parameter. + Errors thrown from Factor code, or signal handlers, pass the + actual stack pointer at the time, since the saved pointer is + not necessarily up to date at that point. */ + if(!callstack_top) + callstack_top = stack_chain->callstack_top; + + throw_impl(userenv[BREAK_ENV],callstack_top); + } + /* Error was thrown in early startup before error handler is set, just + crash. */ + else + { + fprintf(stderr,"You have triggered a bug in Factor. Please report.\n"); + fprintf(stderr,"early_error: "); + print_obj(error); + fprintf(stderr,"\n"); + factorbug(); + } +} + +void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, + F_STACK_FRAME *callstack_top) +{ + throw_error(allot_array_4(userenv[ERROR_ENV], + tag_fixnum(error),arg1,arg2),callstack_top); +} + +void type_error(CELL type, CELL tagged) +{ + general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); +} + +void not_implemented_error(void) +{ + general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); +} + +/* This function is called from the undefined function in cpu_*.S */ +F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) +{ + stack_chain->callstack_top = callstack_top; + general_error(ERROR_UNDEFINED_WORD,word,F,NULL); +} + +/* Test if 'fault' is in the guard page at the top or bottom (depending on +offset being 0 or -1) of area+area_size */ +bool in_page(CELL fault, CELL area, CELL area_size, int offset) +{ + int pagesize = getpagesize(); + area += area_size; + area += offset * pagesize; + + return fault >= area && fault <= area + pagesize; +} + +void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) +{ + if(in_page(addr, ds_bot, 0, -1)) + general_error(ERROR_DS_UNDERFLOW,F,F,native_stack); + else if(in_page(addr, ds_bot, ds_size, 0)) + general_error(ERROR_DS_OVERFLOW,F,F,native_stack); + else if(in_page(addr, rs_bot, 0, -1)) + general_error(ERROR_RS_UNDERFLOW,F,F,native_stack); + else if(in_page(addr, rs_bot, rs_size, 0)) + general_error(ERROR_RS_OVERFLOW,F,F,native_stack); + else if(in_page(addr, nursery->end, 0, 0)) + critical_error("allot_object() missed GC check",0); + else if(in_page(addr, extra_roots_region->start, 0, -1)) + critical_error("local root underflow",0); + else if(in_page(addr, extra_roots_region->end, 0, 0)) + critical_error("local root overflow",0); + else + general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); +} + +void signal_error(int signal, F_STACK_FRAME *native_stack) +{ + general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); +} + +void divide_by_zero_error(F_STACK_FRAME *native_stack) +{ + general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack); +} + +void memory_signal_handler_impl(void) +{ + memory_protection_error(signal_fault_addr,signal_callstack_top); +} + +void divide_by_zero_signal_handler_impl(void) +{ + divide_by_zero_error(signal_callstack_top); +} + +void misc_signal_handler_impl(void) +{ + signal_error(signal_number,signal_callstack_top); +} + +DEFINE_PRIMITIVE(throw) +{ + uncurry(dpop()); + throw_impl(dpop(),stack_chain->callstack_top); +} diff --git a/vm/errors.h b/vm/errors.h new file mode 100644 index 0000000000..cef4505a82 --- /dev/null +++ b/vm/errors.h @@ -0,0 +1,42 @@ +/* Runtime errors */ +typedef enum +{ + ERROR_EXPIRED = 0, + ERROR_IO, + ERROR_UNDEFINED_WORD, + ERROR_TYPE, + ERROR_DIVIDE_BY_ZERO, + ERROR_SIGNAL, + ERROR_ARRAY_SIZE, + ERROR_C_STRING, + ERROR_FFI, + ERROR_HEAP_SCAN, + ERROR_UNDEFINED_SYMBOL, + ERROR_DS_UNDERFLOW, + ERROR_DS_OVERFLOW, + ERROR_RS_UNDERFLOW, + ERROR_RS_OVERFLOW, + ERROR_MEMORY, + ERROR_NOT_IMPLEMENTED, +} F_ERRORTYPE; + +void fatal_error(char* msg, CELL tagged); +void critical_error(char* msg, CELL tagged); +DECLARE_PRIMITIVE(die); + +void throw_error(CELL error, F_STACK_FRAME *native_stack); +void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); +void divide_by_zero_error(F_STACK_FRAME *native_stack); +void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack); +void signal_error(int signal, F_STACK_FRAME *native_stack); +void type_error(CELL type, CELL tagged); +void not_implemented_error(void); + +F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); + +DECLARE_PRIMITIVE(throw); + +INLINE void type_check(CELL type, CELL tagged) +{ + if(type_of(tagged) != type) type_error(type,tagged); +} diff --git a/vm/master.h b/vm/master.h index ec98d34360..b50ac97f9d 100644 --- a/vm/master.h +++ b/vm/master.h @@ -22,6 +22,7 @@ #include "primitives.h" #include "debug.h" #include "run.h" +#include "errors.h" #include "bignumint.h" #include "bignum.h" #include "data_gc.h" @@ -30,11 +31,11 @@ #include "float_bits.h" #include "io.h" #include "code_gc.h" -#include "compiler.h" +#include "code_heap.h" #include "image.h" -#include "stack.h" +#include "callstack.h" #include "alien.h" -#include "jit.h" +#include "quotations.h" #include "factor.h" #include "utilities.h" diff --git a/vm/primitives.c b/vm/primitives.c index f94412c727..bc28012680 100644 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -190,5 +190,4 @@ void *primitives[] = { primitive_tuple_boa, primitive_class_hash, primitive_callstack_to_array, - primitive_array_to_callstack, }; diff --git a/vm/jit.c b/vm/quotations.c similarity index 79% rename from vm/jit.c rename to vm/quotations.c index 51fa06ef86..3390754fc8 100644 --- a/vm/jit.c +++ b/vm/quotations.c @@ -178,3 +178,52 @@ XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset) return quot->xt + xt; } + +DEFINE_PRIMITIVE(curry) +{ + F_CURRY *curry = allot_object(CURRY_TYPE,sizeof(F_CURRY)); + curry->quot = dpop(); + curry->obj = dpop(); + dpush(tag_object(curry)); +} + +void uncurry(CELL obj) +{ + F_CURRY *curry; + + switch(type_of(obj)) + { + case QUOTATION_TYPE: + dpush(obj); + break; + case CURRY_TYPE: + curry = untag_object(obj); + dpush(curry->obj); + uncurry(curry->quot); + break; + default: + type_error(QUOTATION_TYPE,obj); + break; + } +} + +DEFINE_PRIMITIVE(uncurry) +{ + uncurry(dpop()); +} + +/* push a new quotation on the stack */ +DEFINE_PRIMITIVE(array_to_quotation) +{ + F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION)); + quot->array = dpeek(); + quot->xt = lazy_jit_compile; + quot->compiled = F; + drepl(tag_object(quot)); +} + +DEFINE_PRIMITIVE(quotation_xt) +{ + F_QUOTATION *quot = untag_quotation(dpeek()); + drepl(allot_cell((CELL)quot->xt)); +} diff --git a/vm/jit.h b/vm/quotations.h similarity index 50% rename from vm/jit.h rename to vm/quotations.h index d1c91b631b..ff9edc8093 100644 --- a/vm/jit.h +++ b/vm/quotations.h @@ -1,2 +1,7 @@ DLLEXPORT F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack); XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset); + +DECLARE_PRIMITIVE(curry); +DECLARE_PRIMITIVE(array_to_quotation); +DECLARE_PRIMITIVE(quotation_xt); +DECLARE_PRIMITIVE(uncurry); diff --git a/vm/run.c b/vm/run.c index d4f95a47f2..b6573c455c 100644 --- a/vm/run.c +++ b/vm/run.c @@ -1,23 +1,260 @@ #include "master.h" -void uncurry(CELL obj) +void reset_datastack(void) { - F_CURRY *curry; + ds = ds_bot - CELLS; +} - switch(type_of(obj)) - { - case QUOTATION_TYPE: - dpush(obj); - break; - case CURRY_TYPE: - curry = untag_object(obj); - dpush(curry->obj); - uncurry(curry->quot); - break; - default: - type_error(QUOTATION_TYPE,obj); - break; - } +void reset_retainstack(void) +{ + rs = rs_bot - CELLS; +} + +#define RESERVED (64 * CELLS) + +void fix_stacks(void) +{ + if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); + if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); +} + +/* called before entry into foreign C code. Note that ds and rs might +be stored in registers, so callbacks must save and restore the correct values */ +void save_stacks(void) +{ + stack_chain->datastack = ds; + stack_chain->retainstack = rs; +} + +/* called on entry into a compiled callback */ +void nest_stacks(void) +{ + F_CONTEXT *new_stacks = safe_malloc(sizeof(F_CONTEXT)); + + new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; + new_stacks->callstack_top = (F_STACK_FRAME *)-1; + + /* note that these register values are not necessarily valid stack + pointers. they are merely saved non-volatile registers, and are + restored in unnest_stacks(). consider this scenario: + - factor code calls C function + - C function saves ds/cs registers (since they're non-volatile) + - C function clobbers them + - C function calls Factor callback + - Factor callback returns + - C function restores registers + - C function returns to Factor code */ + new_stacks->datastack_save = ds; + new_stacks->retainstack_save = rs; + + /* save per-callback userenv */ + new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; + new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; + + new_stacks->datastack_region = alloc_segment(ds_size); + new_stacks->retainstack_region = alloc_segment(rs_size); + + new_stacks->extra_roots = extra_roots; + + new_stacks->next = stack_chain; + stack_chain = new_stacks; + + reset_datastack(); + reset_retainstack(); +} + +/* called when leaving a compiled callback */ +void unnest_stacks(void) +{ + dealloc_segment(stack_chain->datastack_region); + dealloc_segment(stack_chain->retainstack_region); + + ds = stack_chain->datastack_save; + rs = stack_chain->retainstack_save; + + /* restore per-callback userenv */ + userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; + userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; + + extra_roots = stack_chain->extra_roots; + + F_CONTEXT *old_stacks = stack_chain; + stack_chain = old_stacks->next; + free(old_stacks); +} + +/* called on startup */ +void init_stacks(CELL ds_size_, CELL rs_size_) +{ + ds_size = ds_size_; + rs_size = rs_size_; + stack_chain = NULL; +} + +DEFINE_PRIMITIVE(drop) +{ + dpop(); +} + +DEFINE_PRIMITIVE(2drop) +{ + ds -= 2 * CELLS; +} + +DEFINE_PRIMITIVE(3drop) +{ + ds -= 3 * CELLS; +} + +DEFINE_PRIMITIVE(dup) +{ + dpush(dpeek()); +} + +DEFINE_PRIMITIVE(2dup) +{ + CELL top = dpeek(); + CELL next = get(ds - CELLS); + ds += CELLS * 2; + put(ds - CELLS,next); + put(ds,top); +} + +DEFINE_PRIMITIVE(3dup) +{ + CELL c1 = dpeek(); + CELL c2 = get(ds - CELLS); + CELL c3 = get(ds - CELLS * 2); + ds += CELLS * 3; + put (ds,c1); + put (ds - CELLS,c2); + put (ds - CELLS * 2,c3); +} + +DEFINE_PRIMITIVE(rot) +{ + CELL c1 = dpeek(); + CELL c2 = get(ds - CELLS); + CELL c3 = get(ds - CELLS * 2); + put(ds,c3); + put(ds - CELLS,c1); + put(ds - CELLS * 2,c2); +} + +DEFINE_PRIMITIVE(_rot) +{ + CELL c1 = dpeek(); + CELL c2 = get(ds - CELLS); + CELL c3 = get(ds - CELLS * 2); + put(ds,c2); + put(ds - CELLS,c3); + put(ds - CELLS * 2,c1); +} + +DEFINE_PRIMITIVE(dupd) +{ + CELL top = dpeek(); + CELL next = get(ds - CELLS); + put(ds,next); + put(ds - CELLS,next); + dpush(top); +} + +DEFINE_PRIMITIVE(swapd) +{ + CELL top = get(ds - CELLS); + CELL next = get(ds - CELLS * 2); + put(ds - CELLS,next); + put(ds - CELLS * 2,top); +} + +DEFINE_PRIMITIVE(nip) +{ + CELL top = dpop(); + drepl(top); +} + +DEFINE_PRIMITIVE(2nip) +{ + CELL top = dpeek(); + ds -= CELLS * 2; + drepl(top); +} + +DEFINE_PRIMITIVE(tuck) +{ + CELL top = dpeek(); + CELL next = get(ds - CELLS); + put(ds,next); + put(ds - CELLS,top); + dpush(top); +} + +DEFINE_PRIMITIVE(over) +{ + dpush(get(ds - CELLS)); +} + +DEFINE_PRIMITIVE(pick) +{ + dpush(get(ds - CELLS * 2)); +} + +DEFINE_PRIMITIVE(swap) +{ + CELL top = dpeek(); + CELL next = get(ds - CELLS); + put(ds,next); + put(ds - CELLS,top); +} + +DEFINE_PRIMITIVE(to_r) +{ + rpush(dpop()); +} + +DEFINE_PRIMITIVE(from_r) +{ + dpush(rpop()); +} + +void stack_to_array(CELL bottom, CELL top) +{ + F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); + + if(depth < 0) critical_error("depth < 0",0); + + F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); + memcpy(a + 1,(void*)bottom,depth); + dpush(tag_object(a)); +} + +DEFINE_PRIMITIVE(datastack) +{ + stack_to_array(ds_bot,ds); +} + +DEFINE_PRIMITIVE(retainstack) +{ + stack_to_array(rs_bot,rs); +} + +/* returns pointer to top of stack */ +CELL array_to_stack(F_ARRAY *array, CELL bottom) +{ + CELL depth = array_capacity(array) * CELLS; + memcpy((void*)bottom,array + 1,depth); + return bottom + depth - CELLS; +} + +DEFINE_PRIMITIVE(set_datastack) +{ + ds = array_to_stack(untag_array(dpop()),ds_bot); +} + +DEFINE_PRIMITIVE(set_retainstack) +{ + rs = array_to_stack(untag_array(dpop()),rs_bot); } XT default_word_xt(F_WORD *word) @@ -37,11 +274,6 @@ XT default_word_xt(F_WORD *word) return undefined; } -DEFINE_PRIMITIVE(uncurry) -{ - uncurry(dpop()); -} - DEFINE_PRIMITIVE(getenv) { F_FIXNUM e = untag_fixnum_fast(dpeek()); @@ -127,144 +359,6 @@ DEFINE_PRIMITIVE(set_slot) set_slot(obj,slot,value); } -void fatal_error(char* msg, CELL tagged) -{ - fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged); - exit(1); -} - -void critical_error(char* msg, CELL tagged) -{ - fprintf(stderr,"You have triggered a bug in Factor. Please report.\n"); - fprintf(stderr,"critical_error: %s %lx\n",msg,tagged); - factorbug(); -} - -void throw_error(CELL error, F_STACK_FRAME *callstack_top) -{ - /* If error was thrown during heap scan, we re-enable the GC */ - gc_off = false; - - /* Reset local roots */ - extra_roots = stack_chain->extra_roots; - - /* If we had an underflow or overflow, stack pointers might be - out of bounds */ - fix_stacks(); - - dpush(error); - - /* If the error handler is set, we rewind any C stack frames and - pass the error to user-space. */ - if(userenv[BREAK_ENV] != F) - { - /* Errors thrown from C code pass NULL for this parameter. - Errors thrown from Factor code, or signal handlers, pass the - actual stack pointer at the time, since the saved pointer is - not necessarily up to date at that point. */ - if(!callstack_top) - callstack_top = stack_chain->callstack_top; - - throw_impl(userenv[BREAK_ENV],callstack_top); - } - /* Error was thrown in early startup before error handler is set, just - crash. */ - else - { - fprintf(stderr,"You have triggered a bug in Factor. Please report.\n"); - fprintf(stderr,"early_error: "); - print_obj(error); - fprintf(stderr,"\n"); - factorbug(); - } -} - -void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, - F_STACK_FRAME *callstack_top) -{ - throw_error(allot_array_4(userenv[ERROR_ENV], - tag_fixnum(error),arg1,arg2),callstack_top); -} - -void type_error(CELL type, CELL tagged) -{ - general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); -} - -void not_implemented_error(void) -{ - general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); -} - -/* This function is called from the undefined function in cpu_*.S */ -F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) -{ - stack_chain->callstack_top = callstack_top; - general_error(ERROR_UNDEFINED_WORD,word,F,NULL); -} - -/* Test if 'fault' is in the guard page at the top or bottom (depending on -offset being 0 or -1) of area+area_size */ -bool in_page(CELL fault, CELL area, CELL area_size, int offset) -{ - int pagesize = getpagesize(); - area += area_size; - area += offset * pagesize; - - return fault >= area && fault <= area + pagesize; -} - -void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) -{ - if(in_page(addr, ds_bot, 0, -1)) - general_error(ERROR_DS_UNDERFLOW,F,F,native_stack); - else if(in_page(addr, ds_bot, ds_size, 0)) - general_error(ERROR_DS_OVERFLOW,F,F,native_stack); - else if(in_page(addr, rs_bot, 0, -1)) - general_error(ERROR_RS_UNDERFLOW,F,F,native_stack); - else if(in_page(addr, rs_bot, rs_size, 0)) - general_error(ERROR_RS_OVERFLOW,F,F,native_stack); - else if(in_page(addr, nursery->end, 0, 0)) - critical_error("allot_object() missed GC check",0); - else if(in_page(addr, extra_roots_region->start, 0, -1)) - critical_error("local root underflow",0); - else if(in_page(addr, extra_roots_region->end, 0, 0)) - critical_error("local root overflow",0); - else - general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack); -} - -void signal_error(int signal, F_STACK_FRAME *native_stack) -{ - general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); -} - -void divide_by_zero_error(F_STACK_FRAME *native_stack) -{ - general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack); -} - -void memory_signal_handler_impl(void) -{ - memory_protection_error(signal_fault_addr,signal_callstack_top); -} - -void divide_by_zero_signal_handler_impl(void) -{ - divide_by_zero_error(signal_callstack_top); -} - -void misc_signal_handler_impl(void) -{ - signal_error(signal_number,signal_callstack_top); -} - -DEFINE_PRIMITIVE(throw) -{ - uncurry(dpop()); - throw_impl(dpop(),stack_chain->callstack_top); -} - void enable_word_profiling(F_WORD *word) { if(word->xt == docol) diff --git a/vm/run.h b/vm/run.h index 73454989ce..fe3dcce866 100644 --- a/vm/run.h +++ b/vm/run.h @@ -145,11 +145,85 @@ INLINE CELL type_of(CELL tagged) DEFPUSHPOP(d,ds) DEFPUSHPOP(r,rs) +/* Assembly code makes assumptions about the layout of this struct: + - callstack_top field is 0 + - callstack_bottom field is 1 + - datastack field is 2 + - retainstack field is 3 */ +typedef struct _F_CONTEXT { + /* C stack pointer on entry */ + F_STACK_FRAME *callstack_top; + F_STACK_FRAME *callstack_bottom; + + /* current datastack top pointer */ + CELL datastack; + + /* current retain stack top pointer */ + CELL retainstack; + + /* saved contents of ds register on entry to callback */ + CELL datastack_save; + + /* saved contents of rs register on entry to callback */ + CELL retainstack_save; + + /* memory region holding current datastack */ + F_SEGMENT *datastack_region; + + /* memory region holding current retain stack */ + F_SEGMENT *retainstack_region; + + /* saved userenv slots on entry to callback */ + CELL catchstack_save; + CELL current_callback_save; + + /* saved extra_roots pointer on entry to callback */ + CELL extra_roots; + + struct _F_CONTEXT *next; +} F_CONTEXT; + +DLLEXPORT F_CONTEXT *stack_chain; + +CELL ds_size, rs_size; + +#define ds_bot (stack_chain->datastack_region->start) +#define ds_top (stack_chain->datastack_region->end) +#define rs_bot (stack_chain->retainstack_region->start) +#define rs_top (stack_chain->retainstack_region->end) + +void reset_datastack(void); +void reset_retainstack(void); +void fix_stacks(void); +DLLEXPORT void save_stacks(void); +DLLEXPORT void nest_stacks(void); +DLLEXPORT void unnest_stacks(void); +void init_stacks(CELL ds_size, CELL rs_size); +DECLARE_PRIMITIVE(drop); +DECLARE_PRIMITIVE(2drop); +DECLARE_PRIMITIVE(3drop); +DECLARE_PRIMITIVE(dup); +DECLARE_PRIMITIVE(2dup); +DECLARE_PRIMITIVE(3dup); +DECLARE_PRIMITIVE(rot); +DECLARE_PRIMITIVE(_rot); +DECLARE_PRIMITIVE(dupd); +DECLARE_PRIMITIVE(swapd); +DECLARE_PRIMITIVE(nip); +DECLARE_PRIMITIVE(2nip); +DECLARE_PRIMITIVE(tuck); +DECLARE_PRIMITIVE(over); +DECLARE_PRIMITIVE(pick); +DECLARE_PRIMITIVE(swap); +DECLARE_PRIMITIVE(to_r); +DECLARE_PRIMITIVE(from_r); +DECLARE_PRIMITIVE(datastack); +DECLARE_PRIMITIVE(retainstack); + XT default_word_xt(F_WORD *word); DECLARE_PRIMITIVE(execute); DECLARE_PRIMITIVE(call); -DECLARE_PRIMITIVE(uncurry); DECLARE_PRIMITIVE(getenv); DECLARE_PRIMITIVE(setenv); DECLARE_PRIMITIVE(exit); @@ -162,48 +236,4 @@ DECLARE_PRIMITIVE(tag); DECLARE_PRIMITIVE(class_hash); DECLARE_PRIMITIVE(slot); DECLARE_PRIMITIVE(set_slot); - -/* Runtime errors */ -typedef enum -{ - ERROR_EXPIRED = 0, - ERROR_IO, - ERROR_UNDEFINED_WORD, - ERROR_TYPE, - ERROR_DIVIDE_BY_ZERO, - ERROR_SIGNAL, - ERROR_ARRAY_SIZE, - ERROR_C_STRING, - ERROR_FFI, - ERROR_HEAP_SCAN, - ERROR_UNDEFINED_SYMBOL, - ERROR_DS_UNDERFLOW, - ERROR_DS_OVERFLOW, - ERROR_RS_UNDERFLOW, - ERROR_RS_OVERFLOW, - ERROR_MEMORY, - ERROR_NOT_IMPLEMENTED, -} F_ERRORTYPE; - -void fatal_error(char* msg, CELL tagged); -void critical_error(char* msg, CELL tagged); -DECLARE_PRIMITIVE(die); - -void throw_error(CELL error, F_STACK_FRAME *native_stack); -void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); -void divide_by_zero_error(F_STACK_FRAME *native_stack); -void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack); -void signal_error(int signal, F_STACK_FRAME *native_stack); -void type_error(CELL type, CELL tagged); -void not_implemented_error(void); - -F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); - -DECLARE_PRIMITIVE(throw); - -INLINE void type_check(CELL type, CELL tagged) -{ - if(type_of(tagged) != type) type_error(type,tagged); -} - DECLARE_PRIMITIVE(profiling); diff --git a/vm/stack.c b/vm/stack.c deleted file mode 100644 index 9ba4e35bf5..0000000000 --- a/vm/stack.c +++ /dev/null @@ -1,483 +0,0 @@ -#include "master.h" - -void reset_datastack(void) -{ - ds = ds_bot - CELLS; -} - -void reset_retainstack(void) -{ - rs = rs_bot - CELLS; -} - -#define RESERVED (64 * CELLS) - -void fix_stacks(void) -{ - if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); - if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); -} - -/* called before entry into Factor code. */ -F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) -{ - stack_chain->callstack_bottom = callstack_bottom; -} - -/* called before entry into foreign C code. Note that ds and rs might -be stored in registers, so callbacks must save and restore the correct values */ -void save_stacks(void) -{ - stack_chain->datastack = ds; - stack_chain->retainstack = rs; -} - -/* called on entry into a compiled callback */ -void nest_stacks(void) -{ - F_CONTEXT *new_stacks = safe_malloc(sizeof(F_CONTEXT)); - - new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; - new_stacks->callstack_top = (F_STACK_FRAME *)-1; - - /* note that these register values are not necessarily valid stack - pointers. they are merely saved non-volatile registers, and are - restored in unnest_stacks(). consider this scenario: - - factor code calls C function - - C function saves ds/cs registers (since they're non-volatile) - - C function clobbers them - - C function calls Factor callback - - Factor callback returns - - C function restores registers - - C function returns to Factor code */ - new_stacks->datastack_save = ds; - new_stacks->retainstack_save = rs; - - /* save per-callback userenv */ - new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; - new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; - - new_stacks->datastack_region = alloc_segment(ds_size); - new_stacks->retainstack_region = alloc_segment(rs_size); - - new_stacks->extra_roots = extra_roots; - - new_stacks->next = stack_chain; - stack_chain = new_stacks; - - reset_datastack(); - reset_retainstack(); -} - -/* called when leaving a compiled callback */ -void unnest_stacks(void) -{ - dealloc_segment(stack_chain->datastack_region); - dealloc_segment(stack_chain->retainstack_region); - - ds = stack_chain->datastack_save; - rs = stack_chain->retainstack_save; - - /* restore per-callback userenv */ - userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save; - userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save; - - extra_roots = stack_chain->extra_roots; - - F_CONTEXT *old_stacks = stack_chain; - stack_chain = old_stacks->next; - free(old_stacks); -} - -/* called on startup */ -void init_stacks(CELL ds_size_, CELL rs_size_) -{ - ds_size = ds_size_; - rs_size = rs_size_; - stack_chain = NULL; -} - -void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator) -{ - CELL delta = (bottom - base); - -#ifdef CALLSTACK_UP_P - F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; - #define ITERATING_P (CELL)frame >= top -#else - F_STACK_FRAME *frame = (F_STACK_FRAME *)top; - #define ITERATING_P (CELL)frame < bottom -#endif - - while(ITERATING_P) - { - F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(frame,delta); - iterator(frame); - frame = next; - } -} - -void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator) -{ - CELL top = (CELL)(stack + 1); - CELL bottom = top + untag_fixnum_fast(stack->length); - CELL base = stack->bottom; - - iterate_callstack(top,bottom,base,iterator); -} - -DEFINE_PRIMITIVE(drop) -{ - dpop(); -} - -DEFINE_PRIMITIVE(2drop) -{ - ds -= 2 * CELLS; -} - -DEFINE_PRIMITIVE(3drop) -{ - ds -= 3 * CELLS; -} - -DEFINE_PRIMITIVE(dup) -{ - dpush(dpeek()); -} - -DEFINE_PRIMITIVE(2dup) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - ds += CELLS * 2; - put(ds - CELLS,next); - put(ds,top); -} - -DEFINE_PRIMITIVE(3dup) -{ - CELL c1 = dpeek(); - CELL c2 = get(ds - CELLS); - CELL c3 = get(ds - CELLS * 2); - ds += CELLS * 3; - put (ds,c1); - put (ds - CELLS,c2); - put (ds - CELLS * 2,c3); -} - -DEFINE_PRIMITIVE(rot) -{ - CELL c1 = dpeek(); - CELL c2 = get(ds - CELLS); - CELL c3 = get(ds - CELLS * 2); - put(ds,c3); - put(ds - CELLS,c1); - put(ds - CELLS * 2,c2); -} - -DEFINE_PRIMITIVE(_rot) -{ - CELL c1 = dpeek(); - CELL c2 = get(ds - CELLS); - CELL c3 = get(ds - CELLS * 2); - put(ds,c2); - put(ds - CELLS,c3); - put(ds - CELLS * 2,c1); -} - -DEFINE_PRIMITIVE(dupd) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - put(ds,next); - put(ds - CELLS,next); - dpush(top); -} - -DEFINE_PRIMITIVE(swapd) -{ - CELL top = get(ds - CELLS); - CELL next = get(ds - CELLS * 2); - put(ds - CELLS,next); - put(ds - CELLS * 2,top); -} - -DEFINE_PRIMITIVE(nip) -{ - CELL top = dpop(); - drepl(top); -} - -DEFINE_PRIMITIVE(2nip) -{ - CELL top = dpeek(); - ds -= CELLS * 2; - drepl(top); -} - -DEFINE_PRIMITIVE(tuck) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - put(ds,next); - put(ds - CELLS,top); - dpush(top); -} - -DEFINE_PRIMITIVE(over) -{ - dpush(get(ds - CELLS)); -} - -DEFINE_PRIMITIVE(pick) -{ - dpush(get(ds - CELLS * 2)); -} - -DEFINE_PRIMITIVE(swap) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - put(ds,next); - put(ds - CELLS,top); -} - -DEFINE_PRIMITIVE(to_r) -{ - rpush(dpop()); -} - -DEFINE_PRIMITIVE(from_r) -{ - dpush(rpop()); -} - -void stack_to_array(CELL bottom, CELL top) -{ - F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); - - if(depth < 0) critical_error("depth < 0",0); - - F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); - memcpy(a + 1,(void*)bottom,depth); - dpush(tag_object(a)); -} - -DEFINE_PRIMITIVE(datastack) -{ - stack_to_array(ds_bot,ds); -} - -DEFINE_PRIMITIVE(retainstack) -{ - stack_to_array(rs_bot,rs); -} - -/* returns pointer to top of stack */ -CELL array_to_stack(F_ARRAY *array, CELL bottom) -{ - CELL depth = array_capacity(array) * CELLS; - memcpy((void*)bottom,array + 1,depth); - return bottom + depth - CELLS; -} - -DEFINE_PRIMITIVE(set_datastack) -{ - ds = array_to_stack(untag_array(dpop()),ds_bot); -} - -DEFINE_PRIMITIVE(set_retainstack) -{ - rs = array_to_stack(untag_array(dpop()),rs_bot); -} - -F_CALLSTACK *allot_callstack(CELL size) -{ - F_CALLSTACK *callstack = allot_object( - CALLSTACK_TYPE, - callstack_size(size)); - callstack->length = tag_fixnum(size); - return callstack; -} - -/* We ignore the topmost frame, the one calling 'callstack', -so that set-callstack doesn't get stuck in an infinite loop. - -This means that if 'callstack' is called in tail position, we -will have popped a necessary frame... however this word is only -called by continuation implementation, and user code shouldn't -be calling it at all, so we leave it as it is for now. */ -F_STACK_FRAME *capture_start(void) -{ -#ifdef CALLSTACK_UP_P - F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1; - while(frame >= stack_chain->callstack_top - && FRAME_SUCCESSOR(frame) >= stack_chain->callstack_top) - { - frame = FRAME_SUCCESSOR(frame); - } - return frame + 1; -#else - return FRAME_SUCCESSOR(stack_chain->callstack_top); -#endif -} - -DEFINE_PRIMITIVE(callstack) -{ - F_STACK_FRAME *top = capture_start(); - F_STACK_FRAME *bottom = stack_chain->callstack_bottom; - - F_FIXNUM size = (CELL)bottom - (CELL)top; - if(size < 0) - size = 0; - - F_CALLSTACK *callstack = allot_callstack(size); - callstack->bottom = (CELL)bottom; - memcpy(FIRST_STACK_FRAME(callstack),top,size); - dpush(tag_object(callstack)); -} - -/* If a callstack object was captured at a different base stack height than -we have now, we have to patch up the back-chain pointers. */ -static F_FIXNUM delta; - -void adjust_stack_frame(F_STACK_FRAME *frame) -{ - FRAME_SUCCESSOR(frame) = REBASE_FRAME_SUCCESSOR(frame,delta); -} - -void adjust_callstack(F_CALLSTACK *stack, CELL bottom) -{ - delta = (bottom - stack->bottom); - iterate_callstack_object(stack,adjust_stack_frame); - stack->bottom = bottom; -} - -DEFINE_PRIMITIVE(set_callstack) -{ - F_CALLSTACK *stack = untag_callstack(dpop()); - - CELL bottom = (CELL)stack_chain->callstack_bottom; - - if(stack->bottom != bottom) - adjust_callstack(stack,bottom); - - set_callstack(stack_chain->callstack_bottom, - FIRST_STACK_FRAME(stack), - untag_fixnum_fast(stack->length), - memcpy); - - /* We cannot return here ... */ - critical_error("Bug in set_callstack()",0); -} - -/* C doesn't have closures... */ -static CELL frame_count; -static CELL frame_index; -static F_ARRAY *array; - -void count_stack_frame(F_STACK_FRAME *frame) { - frame_count += 2; -} - -CELL frame_type(F_STACK_FRAME *frame) -{ - return xt_to_compiled(frame->xt)->type; -} - -CELL frame_executing(F_STACK_FRAME *frame) -{ - F_COMPILED *compiled = xt_to_compiled(frame->xt); - CELL code_start = (CELL)(compiled + 1); - CELL literal_start = code_start - + compiled->code_length - + compiled->reloc_length; - - return get(literal_start); -} - -void stack_frame_to_array(F_STACK_FRAME *frame) -{ - CELL offset; - - if(frame_type(frame) == QUOTATION_TYPE) - offset = tag_fixnum(UNAREF(UNTAG(frame->array),frame->scan)); - else - offset = F; - -#ifdef CALLSTACK_UP_P - set_array_nth(array,frame_index++,frame_executing(frame)); - set_array_nth(array,frame_index++,offset); -#else - set_array_nth(array,frame_index--,offset); - set_array_nth(array,frame_index--,frame_executing(frame)); -#endif -} - -DEFINE_PRIMITIVE(callstack_to_array) -{ - F_CALLSTACK *stack = untag_callstack(dpop()); - - frame_count = 0; - iterate_callstack_object(stack,count_stack_frame); - - REGISTER_UNTAGGED(stack); - array = allot_array_internal(ARRAY_TYPE,frame_count); - UNREGISTER_UNTAGGED(stack); - - /* frame_count is equal to the total length now */ - -#ifdef CALLSTACK_UP_P - frame_index = 0; -#else - frame_index = frame_count - 1; -#endif - - iterate_callstack_object(stack,stack_frame_to_array); - - dpush(tag_object(array)); -} - -DEFINE_PRIMITIVE(array_to_callstack) -{ - F_ARRAY *array = untag_array(dpop()); - - CELL count = array_capacity(array); - - if(count % 2 == 1) - { - /* malformed array? type checks below will catch it */ - count--; - } - - REGISTER_UNTAGGED(array); - F_CALLSTACK *callstack = allot_callstack(count / 2 * sizeof(F_STACK_FRAME)); - UNREGISTER_UNTAGGED(array); - - F_STACK_FRAME *next = NULL; - F_STACK_FRAME *current = FIRST_STACK_FRAME(callstack); - - while(count > 0) - { - F_FIXNUM offset = to_fixnum(array_nth(array,--count)); - - F_QUOTATION *quot = untag_quotation(array_nth(array,--count)); - - current->array = quot->array; - current->scan = AREF(UNTAG(quot->array),offset); - current->xt = quot->xt; - //current->return_address = quot_offset_to_pc(quot,offset); - - if(next) FRAME_SUCCESSOR(next) = current; - - next = current; - current++; - } - - if(next) FRAME_SUCCESSOR(next) = current; - - callstack->bottom = (CELL)current; - - dpush(tag_object(callstack)); -} diff --git a/vm/stack.h b/vm/stack.h deleted file mode 100644 index 58be5ae52f..0000000000 --- a/vm/stack.h +++ /dev/null @@ -1,93 +0,0 @@ -/* Assembly code makes assumptions about the layout of this struct: - - callstack_top field is 0 - - callstack_bottom field is 1 - - datastack field is 2 - - retainstack field is 3 */ -typedef struct _F_CONTEXT { - /* C stack pointer on entry */ - F_STACK_FRAME *callstack_top; - F_STACK_FRAME *callstack_bottom; - - /* current datastack top pointer */ - CELL datastack; - - /* current retain stack top pointer */ - CELL retainstack; - - /* saved contents of ds register on entry to callback */ - CELL datastack_save; - - /* saved contents of rs register on entry to callback */ - CELL retainstack_save; - - /* memory region holding current datastack */ - F_SEGMENT *datastack_region; - - /* memory region holding current retain stack */ - F_SEGMENT *retainstack_region; - - /* saved userenv slots on entry to callback */ - CELL catchstack_save; - CELL current_callback_save; - - /* saved extra_roots pointer on entry to callback */ - CELL extra_roots; - - struct _F_CONTEXT *next; -} F_CONTEXT; - -DLLEXPORT F_CONTEXT *stack_chain; - -CELL ds_size, rs_size; - -#define ds_bot (stack_chain->datastack_region->start) -#define ds_top (stack_chain->datastack_region->end) -#define rs_bot (stack_chain->retainstack_region->start) -#define rs_top (stack_chain->retainstack_region->end) - -void reset_datastack(void); -void reset_retainstack(void); -void fix_stacks(void); -F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); -DLLEXPORT void save_stacks(void); -DLLEXPORT void nest_stacks(void); -DLLEXPORT void unnest_stacks(void); -void init_stacks(CELL ds_size, CELL rs_size); - -#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) - -#define REBASE_FRAME_SUCCESSOR(frame,delta) (F_STACK_FRAME *)((CELL)FRAME_SUCCESSOR(frame) + delta) - -typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame); - -void iterate_callstack(CELL top, CELL bottom, CELL base, CALLSTACK_ITER iterator); -void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator); -CELL frame_executing(F_STACK_FRAME *frame); -CELL frame_type(F_STACK_FRAME *frame); - -DECLARE_PRIMITIVE(drop); -DECLARE_PRIMITIVE(2drop); -DECLARE_PRIMITIVE(3drop); -DECLARE_PRIMITIVE(dup); -DECLARE_PRIMITIVE(2dup); -DECLARE_PRIMITIVE(3dup); -DECLARE_PRIMITIVE(rot); -DECLARE_PRIMITIVE(_rot); -DECLARE_PRIMITIVE(dupd); -DECLARE_PRIMITIVE(swapd); -DECLARE_PRIMITIVE(nip); -DECLARE_PRIMITIVE(2nip); -DECLARE_PRIMITIVE(tuck); -DECLARE_PRIMITIVE(over); -DECLARE_PRIMITIVE(pick); -DECLARE_PRIMITIVE(swap); -DECLARE_PRIMITIVE(to_r); -DECLARE_PRIMITIVE(from_r); -DECLARE_PRIMITIVE(datastack); -DECLARE_PRIMITIVE(retainstack); -DECLARE_PRIMITIVE(callstack); -DECLARE_PRIMITIVE(set_datastack); -DECLARE_PRIMITIVE(set_retainstack); -DECLARE_PRIMITIVE(set_callstack); -DECLARE_PRIMITIVE(callstack_to_array); -DECLARE_PRIMITIVE(array_to_callstack); diff --git a/vm/types.c b/vm/types.c index d6cb96508a..a62dfb3125 100644 --- a/vm/types.c +++ b/vm/types.c @@ -126,22 +126,6 @@ DEFINE_PRIMITIVE(float_array) dpush(tag_object(allot_float_array(size,initial))); } -/* push a new quotation on the stack */ -DEFINE_PRIMITIVE(array_to_quotation) -{ - F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION)); - quot->array = dpeek(); - quot->xt = lazy_jit_compile; - quot->compiled = F; - drepl(tag_object(quot)); -} - -DEFINE_PRIMITIVE(quotation_xt) -{ - F_QUOTATION *quot = untag_quotation(dpeek()); - drepl(allot_cell((CELL)quot->xt)); -} - CELL clone(CELL object) { CELL size = object_size(object); @@ -509,11 +493,3 @@ DEFINE_PRIMITIVE(wrapper) wrapper->object = dpeek(); drepl(tag_object(wrapper)); } - -DEFINE_PRIMITIVE(curry) -{ - F_CURRY *curry = allot_object(CURRY_TYPE,sizeof(F_CURRY)); - curry->quot = dpop(); - curry->obj = dpop(); - dpush(tag_object(curry)); -} diff --git a/vm/types.h b/vm/types.h index 478b6fdb3d..0d6f006cce 100644 --- a/vm/types.h +++ b/vm/types.h @@ -137,8 +137,6 @@ DECLARE_PRIMITIVE(tuple_boa); DECLARE_PRIMITIVE(byte_array); DECLARE_PRIMITIVE(bit_array); DECLARE_PRIMITIVE(float_array); -DECLARE_PRIMITIVE(array_to_quotation); -DECLARE_PRIMITIVE(quotation_xt); DECLARE_PRIMITIVE(clone); DECLARE_PRIMITIVE(tuple_to_array); DECLARE_PRIMITIVE(to_tuple); @@ -191,11 +189,8 @@ F_WORD *allot_word(CELL vocab, CELL name); DECLARE_PRIMITIVE(word); DECLARE_PRIMITIVE(update_xt); DECLARE_PRIMITIVE(word_xt); -void fixup_word(F_WORD* word); -void fixup_quotation(F_QUOTATION *quot); DECLARE_PRIMITIVE(wrapper); -DECLARE_PRIMITIVE(curry); /* Macros to simulate a vector in C */ #define GROWABLE_ARRAY(result) \