#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 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->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; 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()); } bool stack_to_array(CELL bottom, CELL top) { F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); if(depth < 0) return false; else { F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); memcpy(a + 1,(void*)bottom,depth); dpush(tag_object(a)); return true; } } DEFINE_PRIMITIVE(datastack) { if(!stack_to_array(ds_bot,ds)) general_error(ERROR_DS_UNDERFLOW,F,F,NULL); } DEFINE_PRIMITIVE(retainstack) { if(!stack_to_array(rs_bot,rs)) general_error(ERROR_RS_UNDERFLOW,F,F,NULL); } /* 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); } DEFINE_PRIMITIVE(getenv) { F_FIXNUM e = untag_fixnum_fast(dpeek()); drepl(userenv[e]); } DEFINE_PRIMITIVE(setenv) { F_FIXNUM e = untag_fixnum_fast(dpop()); CELL value = dpop(); userenv[e] = value; } DEFINE_PRIMITIVE(exit) { exit(to_fixnum(dpop())); } DEFINE_PRIMITIVE(os_env) { char *name = unbox_char_string(); char *value = getenv(name); if(value == NULL) dpush(F); else box_char_string(value); } DEFINE_PRIMITIVE(eq) { CELL lhs = dpop(); CELL rhs = dpeek(); drepl((lhs == rhs) ? T : F); } DEFINE_PRIMITIVE(millis) { box_unsigned_8(current_millis()); } DEFINE_PRIMITIVE(sleep) { sleep_millis(to_cell(dpop())); } DEFINE_PRIMITIVE(type) { drepl(tag_fixnum(type_of(dpeek()))); } DEFINE_PRIMITIVE(tag) { drepl(tag_fixnum(TAG(dpeek()))); } DEFINE_PRIMITIVE(class_hash) { CELL obj = dpeek(); CELL tag = TAG(obj); if(tag == TUPLE_TYPE) { F_WORD *class = untag_object(get(SLOT(obj,2))); drepl(class->hashcode); } else if(tag == OBJECT_TYPE) drepl(get(UNTAG(obj))); else drepl(tag_fixnum(tag)); } DEFINE_PRIMITIVE(slot) { F_FIXNUM slot = untag_fixnum_fast(dpop()); CELL obj = dpop(); dpush(get(SLOT(obj,slot))); } DEFINE_PRIMITIVE(set_slot) { F_FIXNUM slot = untag_fixnum_fast(dpop()); CELL obj = dpop(); CELL value = dpop(); set_slot(obj,slot,value); }