-#include "factor.h"
+#include "master.h"
void reset_datastack(void)
{
rs = rs_bot - CELLS;
}
-void reset_callstack(void)
+#define RESERVED (64 * CELLS)
+
+void fix_stacks(void)
{
- cs = cs_bot - CELLS;
+ if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
+ if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
}
-void fix_stacks(void)
+/* called before entry into Factor code. */
+void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
{
- if(STACK_UNDERFLOW(ds,stack_chain->data_region))
- reset_datastack();
- if(STACK_OVERFLOW(ds,stack_chain->data_region))
- reset_datastack();
- if(STACK_UNDERFLOW(rs,stack_chain->retain_region))
- reset_retainstack();
- if(STACK_OVERFLOW(rs,stack_chain->retain_region))
- reset_retainstack();
- if(STACK_UNDERFLOW(cs,stack_chain->call_region))
- reset_callstack();
- if(STACK_OVERFLOW(cs,stack_chain->call_region))
- reset_callstack();
-}
-
-/* called before entry into foreign C code. Note that ds, rs and cs might
+ 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->data = ds;
- stack_chain->retain = rs;
- stack_chain->call = cs;
+ 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 callback returns
- C function restores registers
- C function returns to Factor code */
- new_stacks->data_save = ds;
- new_stacks->retain_save = rs;
- new_stacks->call_save = cs;
- new_stacks->cards_offset = cards_offset;
+ new_stacks->datastack_save = ds;
+ new_stacks->retainstack_save = rs;
- new_stacks->callframe = callframe;
- new_stacks->callframe_scan = callframe_scan;
- new_stacks->callframe_end = callframe_end;
- new_stacks->catch_save = userenv[CATCHSTACK_ENV];
+ /* save per-callback userenv */
+ new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
+ new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
- new_stacks->data_region = alloc_segment(ds_size);
- new_stacks->retain_region = alloc_segment(rs_size);
- new_stacks->call_region = alloc_segment(cs_size);
+ 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;
- callframe = F;
- callframe_scan = callframe_end = 0;
reset_datastack();
reset_retainstack();
- reset_callstack();
- update_cards_offset();
}
/* called when leaving a compiled callback */
void unnest_stacks(void)
{
- dealloc_segment(stack_chain->data_region);
- dealloc_segment(stack_chain->retain_region);
- dealloc_segment(stack_chain->call_region);
+ dealloc_segment(stack_chain->datastack_region);
+ dealloc_segment(stack_chain->retainstack_region);
- ds = stack_chain->data_save;
- rs = stack_chain->retain_save;
- cs = stack_chain->call_save;
- cards_offset = stack_chain->cards_offset;
+ ds = stack_chain->datastack_save;
+ rs = stack_chain->retainstack_save;
- callframe = stack_chain->callframe;
- callframe_scan = stack_chain->callframe_scan;
- callframe_end = stack_chain->callframe_end;
- userenv[CATCHSTACK_ENV] = stack_chain->catch_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;
}
/* called on startup */
-void init_stacks(CELL ds_size_, CELL rs_size_, CELL cs_size_)
+void init_stacks(CELL ds_size_, CELL rs_size_)
{
ds_size = ds_size_;
rs_size = rs_size_;
- cs_size = cs_size_;
stack_chain = NULL;
- nest_stacks();
}
-void primitive_drop(void)
+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 = (F_STACK_FRAME *)((CELL)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();
}
-void primitive_2drop(void)
+DEFINE_PRIMITIVE(2drop)
{
ds -= 2 * CELLS;
}
-void primitive_3drop(void)
+DEFINE_PRIMITIVE(3drop)
{
ds -= 3 * CELLS;
}
-void primitive_dup(void)
+DEFINE_PRIMITIVE(dup)
{
dpush(dpeek());
}
-void primitive_2dup(void)
+DEFINE_PRIMITIVE(2dup)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
put(ds,top);
}
-void primitive_3dup(void)
+DEFINE_PRIMITIVE(3dup)
{
CELL c1 = dpeek();
CELL c2 = get(ds - CELLS);
put (ds - CELLS * 2,c3);
}
-void primitive_rot(void)
+DEFINE_PRIMITIVE(rot)
{
CELL c1 = dpeek();
CELL c2 = get(ds - CELLS);
put(ds - CELLS * 2,c2);
}
-void primitive__rot(void)
+DEFINE_PRIMITIVE(_rot)
{
CELL c1 = dpeek();
CELL c2 = get(ds - CELLS);
put(ds - CELLS * 2,c1);
}
-void primitive_dupd(void)
+DEFINE_PRIMITIVE(dupd)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
dpush(top);
}
-void primitive_swapd(void)
+DEFINE_PRIMITIVE(swapd)
{
CELL top = get(ds - CELLS);
CELL next = get(ds - CELLS * 2);
put(ds - CELLS * 2,top);
}
-void primitive_nip(void)
+DEFINE_PRIMITIVE(nip)
{
CELL top = dpop();
drepl(top);
}
-void primitive_2nip(void)
+DEFINE_PRIMITIVE(2nip)
{
CELL top = dpeek();
ds -= CELLS * 2;
drepl(top);
}
-void primitive_tuck(void)
+DEFINE_PRIMITIVE(tuck)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
dpush(top);
}
-void primitive_over(void)
+DEFINE_PRIMITIVE(over)
{
dpush(get(ds - CELLS));
}
-void primitive_pick(void)
+DEFINE_PRIMITIVE(pick)
{
dpush(get(ds - CELLS * 2));
}
-void primitive_swap(void)
+DEFINE_PRIMITIVE(swap)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
put(ds - CELLS,top);
}
-void primitive_to_r(void)
+DEFINE_PRIMITIVE(to_r)
{
rpush(dpop());
}
-void primitive_from_r(void)
+DEFINE_PRIMITIVE(from_r)
{
dpush(rpop());
}
-void stack_to_vector(CELL bottom, CELL top)
+void stack_to_array(CELL bottom, CELL top)
{
- F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS) / CELLS;
- if(depth < 0)
- depth = 0;
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth);
- memcpy(a + 1,(void*)bottom,depth * CELLS);
+ 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));
- primitive_array_to_vector();
}
-void primitive_datastack(void)
+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)
{
- stack_to_vector(ds_bot,ds);
+ CELL depth = array_capacity(array) * CELLS;
+ memcpy((void*)bottom,array + 1,depth);
+ return bottom + depth - CELLS;
}
-void primitive_retainstack(void)
+DEFINE_PRIMITIVE(set_datastack)
{
- stack_to_vector(rs_bot,rs);
+ ds = array_to_stack(untag_array(dpop()),ds_bot);
}
-void primitive_callstack(void)
+DEFINE_PRIMITIVE(set_retainstack)
{
- CELL depth = (cs - cs_bot + CELLS) / CELLS - 3;
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth);
- CELL i;
- CELL ptr = cs_bot;
-
- for(i = 0; i < depth; i += 3, ptr += 3 * CELLS)
+ 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)
{
- CELL quot = get(ptr);
- CELL untagged = UNTAG(quot);
- CELL position = UNAREF(untagged,get(ptr + CELLS));
- CELL end = UNAREF(untagged,get(ptr + CELLS * 2));
- set_array_nth(a,i,quot);
- set_array_nth(a,i + 1,tag_fixnum(position));
- set_array_nth(a,i + 2,tag_fixnum(end));
+ frame = FRAME_SUCCESSOR(frame);
}
+ return frame + 1;
+#else
+ return FRAME_SUCCESSOR(stack_chain->callstack_top);
+#endif
+}
- dpush(tag_object(a));
- primitive_array_to_vector();
+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));
}
-/* returns pointer to top of stack */
-CELL vector_to_stack(F_VECTOR* vector, CELL bottom)
+/* 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) = (F_STACK_FRAME *)((CELL)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)
{
- CELL start = bottom;
- CELL len = untag_fixnum_fast(vector->top) * CELLS;
- memcpy((void*)start,untag_array_fast(vector->array) + 1,len);
- return start + len - CELLS;
+ return xt_to_compiled(frame->xt)->type;
}
-void primitive_set_datastack(void)
+CELL frame_executing(F_STACK_FRAME *frame)
{
- ds = vector_to_stack(untag_vector(dpop()),ds_bot);
+ 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 primitive_set_retainstack(void)
+void stack_frame_to_array(F_STACK_FRAME *frame)
{
- rs = vector_to_stack(untag_vector(dpop()),rs_bot);
+ CELL offset;
+
+ if(frame_type(frame) == QUOTATION_TYPE)
+ offset = tag_fixnum(UNAREF(UNTAG(frame->array),frame->scan));
+ else
+ offset = F;
+
+#ifdef CALLSTACK_UP_P
+ #define I(n) (n)
+#else
+ #define I(n) (array_capacity(array) - (n) - 1)
+#endif
+
+ set_array_nth(array,I(frame_index++),frame_executing(frame));
+ set_array_nth(array,I(frame_index++),offset);
}
-void primitive_set_callstack(void)
+DEFINE_PRIMITIVE(callstack_to_array)
{
- F_VECTOR *v = untag_vector(dpop());
- F_ARRAY *a = untag_array_fast(v->array);
+ F_CALLSTACK *stack = untag_callstack(dpop());
+
+ frame_count = 0;
+ iterate_callstack_object(stack,count_stack_frame);
- CELL depth = untag_fixnum_fast(v->top);
- depth -= (depth % 3);
+ REGISTER_UNTAGGED(stack);
+ array = allot_array_internal(ARRAY_TYPE,frame_count);
+ UNREGISTER_UNTAGGED(stack);
- CELL i, ptr;
- for(i = 0, ptr = cs_bot; i < depth; i += 3, ptr += 3 * CELLS)
+ /* frame_count is equal to the total length now */
+
+ frame_index = 0;
+ 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)
{
- CELL quot = get(AREF(a,i));
- type_check(QUOTATION_TYPE,quot);
+ /* malformed array? type checks below will catch it */
+ count--;
+ }
- F_ARRAY *untagged = (F_ARRAY*)UNTAG(quot);
- CELL length = array_capacity(untagged);
+ REGISTER_UNTAGGED(array);
+ F_CALLSTACK *callstack = allot_callstack(count / 2 * sizeof(F_STACK_FRAME));
+ UNREGISTER_UNTAGGED(array);
- F_FIXNUM position = to_fixnum(get(AREF(a,i + 1)));
- F_FIXNUM end = to_fixnum(get(AREF(a,i + 2)));
+ 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));
- if(end < 0) end = 0;
- if(end > length) end = length;
- if(position < 0) position = 0;
- if(position > end) position = end;
+ F_QUOTATION *quot = untag_quotation(array_nth(array,--count));
- put(ptr,quot);
- put(ptr + CELLS,AREF(untagged,position));
- put(ptr + CELLS * 2,AREF(untagged,end));
+ 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++;
}
- cs = cs_bot + depth * CELLS - CELLS;
+ if(next) FRAME_SUCCESSOR(next) = current;
+
+ callstack->bottom = (CELL)current;
+
+ dpush(tag_object(callstack));
}
projects / factor.git / blobdiff