factor/vm/callstack.cpp

231 lines
5.1 KiB
C++
Raw Normal View History

2009-05-02 05:04:19 -04:00
#include "master.hpp"
2009-05-04 02:46:13 -04:00
namespace factor
{
2009-05-04 05:50:24 -04:00
static void check_frame(stack_frame *frame)
2009-05-02 21:01:54 -04:00
{
#ifdef FACTOR_DEBUG
2009-05-04 05:50:24 -04:00
check_code_pointer((cell)frame->xt);
2009-05-02 21:01:54 -04:00
assert(frame->size != 0);
#endif
}
2009-05-04 05:50:24 -04:00
void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
stack_frame *frame = (stack_frame *)bottom - 1;
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
while((cell)frame >= top)
2009-05-02 05:04:19 -04:00
{
iterator(frame);
frame = frame_successor(frame);
2009-05-02 05:04:19 -04:00
}
}
2009-05-04 05:50:24 -04:00
void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
cell top = (cell)FIRST_STACK_FRAME(stack);
cell bottom = top + untag_fixnum(stack->length);
2009-05-02 05:04:19 -04:00
iterate_callstack(top,bottom,iterator);
}
2009-05-04 05:50:24 -04:00
callstack *allot_callstack(cell size)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
callstack *stack = allot<callstack>(callstack_size(size));
stack->length = tag_fixnum(size);
return stack;
2009-05-02 05:04:19 -04:00
}
2009-05-04 05:50:24 -04:00
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
stack_frame *frame = bottom - 1;
2009-05-02 05:04:19 -04:00
while(frame >= top)
frame = frame_successor(frame);
return frame + 1;
}
/* 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. */
2009-05-05 12:33:35 -04:00
stack_frame *capture_start()
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
stack_frame *frame = stack_chain->callstack_bottom - 1;
2009-05-02 05:04:19 -04:00
while(frame >= stack_chain->callstack_top
&& frame_successor(frame) >= stack_chain->callstack_top)
{
frame = frame_successor(frame);
}
return frame + 1;
}
PRIMITIVE(callstack)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
stack_frame *top = capture_start();
stack_frame *bottom = stack_chain->callstack_bottom;
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
fixnum size = (cell)bottom - (cell)top;
2009-05-02 05:04:19 -04:00
if(size < 0)
size = 0;
2009-05-04 05:50:24 -04:00
callstack *stack = allot_callstack(size);
memcpy(FIRST_STACK_FRAME(stack),top,size);
dpush(tag<callstack>(stack));
2009-05-02 05:04:19 -04:00
}
PRIMITIVE(set_callstack)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
callstack *stack = untag_check<callstack>(dpop());
2009-05-02 05:04:19 -04:00
set_callstack(stack_chain->callstack_bottom,
FIRST_STACK_FRAME(stack),
untag_fixnum(stack->length),
2009-05-02 05:04:19 -04:00
memcpy);
/* We cannot return here ... */
critical_error("Bug in set_callstack()",0);
}
2009-05-04 05:50:24 -04:00
code_block *frame_code(stack_frame *frame)
2009-05-02 05:04:19 -04:00
{
2009-05-02 21:01:54 -04:00
check_frame(frame);
2009-05-04 05:50:24 -04:00
return (code_block *)frame->xt - 1;
2009-05-02 05:04:19 -04:00
}
2009-05-04 05:50:24 -04:00
cell frame_type(stack_frame *frame)
2009-05-02 05:04:19 -04:00
{
return frame_code(frame)->type;
2009-05-02 05:04:19 -04:00
}
2009-05-04 05:50:24 -04:00
cell frame_executing(stack_frame *frame)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
code_block *compiled = frame_code(frame);
2009-05-02 05:04:19 -04:00
if(compiled->literals == F || !stack_traces_p())
return F;
else
{
2009-05-04 05:50:24 -04:00
array *literals = untag<array>(compiled->literals);
return array_nth(literals,0);
2009-05-02 05:04:19 -04:00
}
}
2009-05-04 05:50:24 -04:00
stack_frame *frame_successor(stack_frame *frame)
2009-05-02 05:04:19 -04:00
{
2009-05-02 21:01:54 -04:00
check_frame(frame);
2009-05-04 05:50:24 -04:00
return (stack_frame *)((cell)frame - frame->size);
2009-05-02 05:04:19 -04:00
}
2009-05-04 05:50:24 -04:00
cell frame_scan(stack_frame *frame)
2009-05-02 05:04:19 -04:00
{
if(frame_type(frame) == QUOTATION_TYPE)
{
2009-05-04 05:50:24 -04:00
cell quot = frame_executing(frame);
2009-05-02 05:04:19 -04:00
if(quot == F)
return F;
else
{
char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
char *quot_xt = (char *)(frame_code(frame) + 1);
return tag_fixnum(quot_code_offset_to_scan(
2009-05-04 05:50:24 -04:00
quot,(cell)(return_addr - quot_xt)));
2009-05-02 05:04:19 -04:00
}
}
else
return F;
}
/* C doesn't have closures... */
2009-05-04 05:50:24 -04:00
static cell frame_count;
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
void count_stack_frame(stack_frame *frame)
2009-05-02 05:04:19 -04:00
{
frame_count += 2;
}
2009-05-04 05:50:24 -04:00
static cell frame_index;
static array *frames;
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
void stack_frame_to_array(stack_frame *frame)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
set_array_nth(frames,frame_index++,frame_executing(frame));
set_array_nth(frames,frame_index++,frame_scan(frame));
2009-05-02 05:04:19 -04:00
}
PRIMITIVE(callstack_to_array)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
gc_root<callstack> callstack(dpop());
2009-05-02 05:04:19 -04:00
frame_count = 0;
2009-05-02 10:19:09 -04:00
iterate_callstack_object(callstack.untagged(),count_stack_frame);
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
frames = allot_array_internal<array>(frame_count);
2009-05-02 05:04:19 -04:00
frame_index = 0;
2009-05-02 10:19:09 -04:00
iterate_callstack_object(callstack.untagged(),stack_frame_to_array);
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
dpush(tag<array>(frames));
2009-05-02 05:04:19 -04:00
}
2009-05-04 05:50:24 -04:00
stack_frame *innermost_stack_frame(callstack *callstack)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
stack_frame *top = FIRST_STACK_FRAME(callstack);
cell bottom = (cell)top + untag_fixnum(callstack->length);
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
stack_frame *frame = (stack_frame *)bottom - 1;
2009-05-02 05:04:19 -04:00
while(frame >= top && frame_successor(frame) >= top)
frame = frame_successor(frame);
return frame;
}
2009-05-04 05:50:24 -04:00
stack_frame *innermost_stack_frame_quot(callstack *callstack)
{
2009-05-04 05:50:24 -04:00
stack_frame *inner = innermost_stack_frame(callstack);
tagged<quotation>(frame_executing(inner)).untag_check();
return inner;
}
2009-05-02 05:04:19 -04:00
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
PRIMITIVE(innermost_stack_frame_executing)
2009-05-02 05:04:19 -04:00
{
dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
2009-05-02 05:04:19 -04:00
}
PRIMITIVE(innermost_stack_frame_scan)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
2009-05-02 05:04:19 -04:00
}
PRIMITIVE(set_innermost_stack_frame_quot)
2009-05-02 05:04:19 -04:00
{
2009-05-04 05:50:24 -04:00
gc_root<callstack> callstack(dpop());
gc_root<quotation> quot(dpop());
2009-05-02 05:04:19 -04:00
callstack.untag_check();
quot.untag_check();
2009-05-02 05:04:19 -04:00
jit_compile(quot.value(),true);
2009-05-02 05:04:19 -04:00
2009-05-04 05:50:24 -04:00
stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
2009-05-02 05:04:19 -04:00
inner->xt = quot->xt;
FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
}
/* called before entry into Factor code. */
2009-05-04 05:50:24 -04:00
VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
2009-05-04 02:46:13 -04:00
}