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/code_gc.o \
|
||||||
vm/primitives.o \
|
vm/primitives.o \
|
||||||
vm/run.o \
|
vm/run.o \
|
||||||
vm/stack.o \
|
vm/callstack.o \
|
||||||
vm/types.o \
|
vm/types.o \
|
||||||
vm/jit.o \
|
vm/quotations.o \
|
||||||
vm/utilities.o
|
vm/utilities.o \
|
||||||
|
vm/errors.o
|
||||||
|
|
||||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
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 "primitives.h"
|
||||||
#include "debug.h"
|
#include "debug.h"
|
||||||
#include "run.h"
|
#include "run.h"
|
||||||
|
#include "errors.h"
|
||||||
#include "bignumint.h"
|
#include "bignumint.h"
|
||||||
#include "bignum.h"
|
#include "bignum.h"
|
||||||
#include "data_gc.h"
|
#include "data_gc.h"
|
||||||
|
|
@ -30,11 +31,11 @@
|
||||||
#include "float_bits.h"
|
#include "float_bits.h"
|
||||||
#include "io.h"
|
#include "io.h"
|
||||||
#include "code_gc.h"
|
#include "code_gc.h"
|
||||||
#include "compiler.h"
|
#include "code_heap.h"
|
||||||
#include "image.h"
|
#include "image.h"
|
||||||
#include "stack.h"
|
#include "callstack.h"
|
||||||
#include "alien.h"
|
#include "alien.h"
|
||||||
#include "jit.h"
|
#include "quotations.h"
|
||||||
#include "factor.h"
|
#include "factor.h"
|
||||||
#include "utilities.h"
|
#include "utilities.h"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -190,5 +190,4 @@ void *primitives[] = {
|
||||||
primitive_tuple_boa,
|
primitive_tuple_boa,
|
||||||
primitive_class_hash,
|
primitive_class_hash,
|
||||||
primitive_callstack_to_array,
|
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;
|
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);
|
DLLEXPORT F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack);
|
||||||
XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);
|
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"
|
#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)
|
XT default_word_xt(F_WORD *word)
|
||||||
|
|
@ -37,11 +274,6 @@ XT default_word_xt(F_WORD *word)
|
||||||
return undefined;
|
return undefined;
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(uncurry)
|
|
||||||
{
|
|
||||||
uncurry(dpop());
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(getenv)
|
DEFINE_PRIMITIVE(getenv)
|
||||||
{
|
{
|
||||||
F_FIXNUM e = untag_fixnum_fast(dpeek());
|
F_FIXNUM e = untag_fixnum_fast(dpeek());
|
||||||
|
|
@ -127,144 +359,6 @@ DEFINE_PRIMITIVE(set_slot)
|
||||||
set_slot(obj,slot,value);
|
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)
|
void enable_word_profiling(F_WORD *word)
|
||||||
{
|
{
|
||||||
if(word->xt == docol)
|
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(d,ds)
|
||||||
DEFPUSHPOP(r,rs)
|
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);
|
XT default_word_xt(F_WORD *word);
|
||||||
|
|
||||||
DECLARE_PRIMITIVE(execute);
|
DECLARE_PRIMITIVE(execute);
|
||||||
DECLARE_PRIMITIVE(call);
|
DECLARE_PRIMITIVE(call);
|
||||||
DECLARE_PRIMITIVE(uncurry);
|
|
||||||
DECLARE_PRIMITIVE(getenv);
|
DECLARE_PRIMITIVE(getenv);
|
||||||
DECLARE_PRIMITIVE(setenv);
|
DECLARE_PRIMITIVE(setenv);
|
||||||
DECLARE_PRIMITIVE(exit);
|
DECLARE_PRIMITIVE(exit);
|
||||||
|
|
@ -162,48 +236,4 @@ DECLARE_PRIMITIVE(tag);
|
||||||
DECLARE_PRIMITIVE(class_hash);
|
DECLARE_PRIMITIVE(class_hash);
|
||||||
DECLARE_PRIMITIVE(slot);
|
DECLARE_PRIMITIVE(slot);
|
||||||
DECLARE_PRIMITIVE(set_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);
|
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)));
|
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 clone(CELL object)
|
||||||
{
|
{
|
||||||
CELL size = object_size(object);
|
CELL size = object_size(object);
|
||||||
|
|
@ -509,11 +493,3 @@ DEFINE_PRIMITIVE(wrapper)
|
||||||
wrapper->object = dpeek();
|
wrapper->object = dpeek();
|
||||||
drepl(tag_object(wrapper));
|
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(byte_array);
|
||||||
DECLARE_PRIMITIVE(bit_array);
|
DECLARE_PRIMITIVE(bit_array);
|
||||||
DECLARE_PRIMITIVE(float_array);
|
DECLARE_PRIMITIVE(float_array);
|
||||||
DECLARE_PRIMITIVE(array_to_quotation);
|
|
||||||
DECLARE_PRIMITIVE(quotation_xt);
|
|
||||||
DECLARE_PRIMITIVE(clone);
|
DECLARE_PRIMITIVE(clone);
|
||||||
DECLARE_PRIMITIVE(tuple_to_array);
|
DECLARE_PRIMITIVE(tuple_to_array);
|
||||||
DECLARE_PRIMITIVE(to_tuple);
|
DECLARE_PRIMITIVE(to_tuple);
|
||||||
|
|
@ -191,11 +189,8 @@ F_WORD *allot_word(CELL vocab, CELL name);
|
||||||
DECLARE_PRIMITIVE(word);
|
DECLARE_PRIMITIVE(word);
|
||||||
DECLARE_PRIMITIVE(update_xt);
|
DECLARE_PRIMITIVE(update_xt);
|
||||||
DECLARE_PRIMITIVE(word_xt);
|
DECLARE_PRIMITIVE(word_xt);
|
||||||
void fixup_word(F_WORD* word);
|
|
||||||
void fixup_quotation(F_QUOTATION *quot);
|
|
||||||
|
|
||||||
DECLARE_PRIMITIVE(wrapper);
|
DECLARE_PRIMITIVE(wrapper);
|
||||||
DECLARE_PRIMITIVE(curry);
|
|
||||||
|
|
||||||
/* Macros to simulate a vector in C */
|
/* Macros to simulate a vector in C */
|
||||||
#define GROWABLE_ARRAY(result) \
|
#define GROWABLE_ARRAY(result) \
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue