6 static void check_frame(stack_frame *frame)
9 check_code_pointer((cell)frame->xt);
10 assert(frame->size != 0);
14 callstack *allot_callstack(cell size)
16 callstack *stack = allot<callstack>(callstack_size(size));
17 stack->length = tag_fixnum(size);
21 stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom)
23 stack_frame *frame = bottom - 1;
26 frame = frame_successor(frame);
31 /* We ignore the topmost frame, the one calling 'callstack',
32 so that set-callstack doesn't get stuck in an infinite loop.
34 This means that if 'callstack' is called in tail position, we
35 will have popped a necessary frame... however this word is only
36 called by continuation implementation, and user code shouldn't
37 be calling it at all, so we leave it as it is for now. */
38 stack_frame *capture_start()
40 stack_frame *frame = stack_chain->callstack_bottom - 1;
41 while(frame >= stack_chain->callstack_top
42 && frame_successor(frame) >= stack_chain->callstack_top)
44 frame = frame_successor(frame);
51 stack_frame *top = capture_start();
52 stack_frame *bottom = stack_chain->callstack_bottom;
54 fixnum size = (cell)bottom - (cell)top;
58 callstack *stack = allot_callstack(size);
59 memcpy(stack->top(),top,size);
60 dpush(tag<callstack>(stack));
63 PRIMITIVE(set_callstack)
65 callstack *stack = untag_check<callstack>(dpop());
67 set_callstack(stack_chain->callstack_bottom,
69 untag_fixnum(stack->length),
72 /* We cannot return here ... */
73 critical_error("Bug in set_callstack()",0);
76 code_block *frame_code(stack_frame *frame)
79 return (code_block *)frame->xt - 1;
82 cell frame_type(stack_frame *frame)
84 return frame_code(frame)->type;
87 cell frame_executing(stack_frame *frame)
89 code_block *compiled = frame_code(frame);
90 if(compiled->literals == F || !stack_traces_p())
94 array *literals = untag<array>(compiled->literals);
95 cell executing = array_nth(literals,0);
96 check_data_pointer((object *)executing);
101 stack_frame *frame_successor(stack_frame *frame)
104 return (stack_frame *)((cell)frame - frame->size);
107 /* Allocates memory */
108 cell frame_scan(stack_frame *frame)
110 switch(frame_type(frame))
113 cell quot = frame_executing(frame);
118 char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
119 char *quot_xt = (char *)(frame_code(frame) + 1);
121 return tag_fixnum(quot_code_offset_to_scan(
122 quot,(cell)(return_addr - quot_xt)));
127 critical_error("Bad frame type",frame_type(frame));
135 struct stack_frame_accumulator {
136 growable_array frames;
138 void operator()(stack_frame *frame)
140 gc_root<object> executing(frame_executing(frame));
141 gc_root<object> scan(frame_scan(frame));
143 frames.add(executing.value());
144 frames.add(scan.value());
150 PRIMITIVE(callstack_to_array)
152 gc_root<callstack> callstack(dpop());
154 stack_frame_accumulator accum;
155 iterate_callstack_object(callstack.untagged(),accum);
158 dpush(accum.frames.elements.value());
161 stack_frame *innermost_stack_frame(callstack *stack)
163 stack_frame *top = stack->top();
164 stack_frame *bottom = stack->bottom();
165 stack_frame *frame = bottom - 1;
167 while(frame >= top && frame_successor(frame) >= top)
168 frame = frame_successor(frame);
173 stack_frame *innermost_stack_frame_quot(callstack *callstack)
175 stack_frame *inner = innermost_stack_frame(callstack);
176 tagged<quotation>(frame_executing(inner)).untag_check();
180 /* Some primitives implementing a limited form of callstack mutation.
181 Used by the single stepper. */
182 PRIMITIVE(innermost_stack_frame_executing)
184 dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
187 PRIMITIVE(innermost_stack_frame_scan)
189 dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
192 PRIMITIVE(set_innermost_stack_frame_quot)
194 gc_root<callstack> callstack(dpop());
195 gc_root<quotation> quot(dpop());
197 callstack.untag_check();
200 jit_compile(quot.value(),true);
202 stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
203 cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
204 inner->xt = quot->xt;
205 FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
208 /* called before entry into Factor code. */
209 VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
211 stack_chain->callstack_bottom = callstack_bottom;