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))
114 cell quot = frame_executing(frame);
119 char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
120 char *quot_xt = (char *)(frame_code(frame) + 1);
122 return tag_fixnum(quot_code_offset_to_scan(
123 quot,(cell)(return_addr - quot_xt)));
129 critical_error("Bad frame type",frame_type(frame));
137 struct stack_frame_accumulator {
138 growable_array frames;
140 void operator()(stack_frame *frame)
142 gc_root<object> executing(frame_executing(frame));
143 gc_root<object> scan(frame_scan(frame));
145 frames.add(executing.value());
146 frames.add(scan.value());
152 PRIMITIVE(callstack_to_array)
154 gc_root<callstack> callstack(dpop());
156 stack_frame_accumulator accum;
157 iterate_callstack_object(callstack.untagged(),accum);
160 dpush(accum.frames.elements.value());
163 stack_frame *innermost_stack_frame(callstack *stack)
165 stack_frame *top = stack->top();
166 stack_frame *bottom = stack->bottom();
167 stack_frame *frame = bottom - 1;
169 while(frame >= top && frame_successor(frame) >= top)
170 frame = frame_successor(frame);
175 stack_frame *innermost_stack_frame_quot(callstack *callstack)
177 stack_frame *inner = innermost_stack_frame(callstack);
178 tagged<quotation>(frame_executing(inner)).untag_check();
182 /* Some primitives implementing a limited form of callstack mutation.
183 Used by the single stepper. */
184 PRIMITIVE(innermost_stack_frame_executing)
186 dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
189 PRIMITIVE(innermost_stack_frame_scan)
191 dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
194 PRIMITIVE(set_innermost_stack_frame_quot)
196 gc_root<callstack> callstack(dpop());
197 gc_root<quotation> quot(dpop());
199 callstack.untag_check();
202 jit_compile(quot.value(),true);
204 stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
205 cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
206 inner->xt = quot->xt;
207 FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
210 /* called before entry into Factor code. */
211 VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
213 stack_chain->callstack_bottom = callstack_bottom;