VM cleanup
Slava Pestov
parent
88168656dd
commit
d3ae70c53d
7
Makefile
7
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
}
|
||||
|
|
@ -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);
|
||||
|
|
@ -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);
|
||||
}
|
||||
|
|
@ -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);
|
||||
}
|
||||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -190,5 +190,4 @@ void *primitives[] = {
|
|||
primitive_tuple_boa,
|
||||
primitive_class_hash,
|
||||
primitive_callstack_to_array,
|
||||
primitive_array_to_callstack,
|
||||
};
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
}
|
||||
|
|
@ -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);
|
||||
412
vm/run.c
412
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)
|
||||
|
|
|
|||
120
vm/run.h
120
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);
|
||||
|
|
|
|||
483
vm/stack.c
483
vm/stack.c
|
|
@ -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));
|
||||
}
|
||||
93
vm/stack.h
93
vm/stack.h
|
|
@ -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);
|
||||
24
vm/types.c
24
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));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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) \
|
||||
|
|
|
|||
Loading…
Reference in New Issue