vm/callstack.c

   1 #include "master.h"
   2
   3 /* called before entry into Factor code. */
   4 F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
   5 {
   6         stack_chain->callstack_bottom = callstack_bottom;
   7 }
   8
   9 void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
  10 {
  11         F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
  12
  13         while((CELL)frame >= top)
  14         {
  15                 F_STACK_FRAME *next = frame_successor(frame);
  16                 iterator(frame);
  17                 frame = next;
  18         }
  19 }
  20
  21 void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator)
  22 {
  23         CELL top = (CELL)FIRST_STACK_FRAME(stack);
  24         CELL bottom = top + untag_fixnum_fast(stack->length);
  25
  26         iterate_callstack(top,bottom,iterator);
  27 }
  28
  29 F_CALLSTACK *allot_callstack(CELL size)
  30 {
  31         F_CALLSTACK *callstack = allot_object(
  32                 CALLSTACK_TYPE,
  33                 callstack_size(size));
  34         callstack->length = tag_fixnum(size);
  35         return callstack;
  36 }
  37
  38 F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom)
  39 {
  40         F_STACK_FRAME *frame = bottom - 1;
  41
  42         while(frame >= top)
  43                 frame = frame_successor(frame);
  44
  45         return frame + 1;
  46 }
  47
  48 /* We ignore the topmost frame, the one calling 'callstack',
  49 so that set-callstack doesn't get stuck in an infinite loop.
  50
  51 This means that if 'callstack' is called in tail position, we
  52 will have popped a necessary frame... however this word is only
  53 called by continuation implementation, and user code shouldn't
  54 be calling it at all, so we leave it as it is for now. */
  55 F_STACK_FRAME *capture_start(void)
  56 {
  57         F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1;
  58         while(frame >= stack_chain->callstack_top
  59                 && frame_successor(frame) >= stack_chain->callstack_top)
  60         {
  61                 frame = frame_successor(frame);
  62         }
  63         return frame + 1;
  64 }
  65
  66 void primitive_callstack(void)
  67 {
  68         F_STACK_FRAME *top = capture_start();
  69         F_STACK_FRAME *bottom = stack_chain->callstack_bottom;
  70
  71         F_FIXNUM size = (CELL)bottom - (CELL)top;
  72         if(size < 0)
  73                 size = 0;
  74
  75         F_CALLSTACK *callstack = allot_callstack(size);
  76         memcpy(FIRST_STACK_FRAME(callstack),top,size);
  77         dpush(tag_object(callstack));
  78 }
  79
  80 void primitive_set_callstack(void)
  81 {
  82         F_CALLSTACK *stack = untag_callstack(dpop());
  83
  84         set_callstack(stack_chain->callstack_bottom,
  85                 FIRST_STACK_FRAME(stack),
  86                 untag_fixnum_fast(stack->length),
  87                 memcpy);
  88
  89         /* We cannot return here ... */
  90         critical_error("Bug in set_callstack()",0);
  91 }
  92
  93 F_COMPILED *frame_code(F_STACK_FRAME *frame)
  94 {
  95         return (F_COMPILED *)frame->xt - 1;
  96 }
  97
  98 CELL frame_type(F_STACK_FRAME *frame)
  99 {
 100         return frame_code(frame)->type;
 101 }
 102
 103 CELL frame_executing(F_STACK_FRAME *frame)
 104 {
 105         F_COMPILED *compiled = frame_code(frame);
 106         CELL code_start = (CELL)(compiled + 1);
 107         CELL literal_start = code_start + compiled->code_length;
 108
 109         return get(literal_start);
 110 }
 111
 112 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
 113 {
 114         if(frame->size == 0)
 115                 critical_error("Stack frame has zero size",(CELL)frame);
 116         return (F_STACK_FRAME *)((CELL)frame - frame->size);
 117 }
 118
 119 CELL frame_scan(F_STACK_FRAME *frame)
 120 {
 121         if(frame_type(frame) == QUOTATION_TYPE)
 122         {
 123                 CELL quot = frame_executing(frame);
 124                 if(quot == F)
 125                         return F;
 126                 else
 127                 {
 128                         XT return_addr = FRAME_RETURN_ADDRESS(frame);
 129                         XT quot_xt = (XT)(frame_code(frame) + 1);
 130
 131                         return tag_fixnum(quot_code_offset_to_scan(
 132                                 quot,(CELL)(return_addr - quot_xt)));
 133                 }
 134         }
 135         else
 136                 return F;
 137 }
 138
 139 /* C doesn't have closures... */
 140 static CELL frame_count;
 141
 142 void count_stack_frame(F_STACK_FRAME *frame)
 143 {
 144         frame_count += 2;
 145 }
 146
 147 static CELL frame_index;
 148 static F_ARRAY *array;
 149
 150 void stack_frame_to_array(F_STACK_FRAME *frame)
 151 {
 152         set_array_nth(array,frame_index++,frame_executing(frame));
 153         set_array_nth(array,frame_index++,frame_scan(frame));
 154 }
 155
 156 void primitive_callstack_to_array(void)
 157 {
 158         F_CALLSTACK *stack = untag_callstack(dpop());
 159
 160         frame_count = 0;
 161         iterate_callstack_object(stack,count_stack_frame);
 162
 163         REGISTER_UNTAGGED(stack);
 164         array = allot_array_internal(ARRAY_TYPE,frame_count);
 165         UNREGISTER_UNTAGGED(stack);
 166
 167         frame_index = 0;
 168         iterate_callstack_object(stack,stack_frame_to_array);
 169
 170         dpush(tag_object(array));
 171 }
 172
 173 F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
 174 {
 175         F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack);
 176         CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length);
 177
 178         F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
 179
 180         while(frame >= top && frame_successor(frame) >= top)
 181                 frame = frame_successor(frame);
 182
 183         return frame;
 184 }
 185
 186 /* Some primitives implementing a limited form of callstack mutation.
 187 Used by the single stepper. */
 188 void primitive_innermost_stack_frame_quot(void)
 189 {
 190         F_STACK_FRAME *inner = innermost_stack_frame(
 191                 untag_callstack(dpop()));
 192         type_check(QUOTATION_TYPE,frame_executing(inner));
 193
 194         dpush(frame_executing(inner));
 195 }
 196
 197 void primitive_innermost_stack_frame_scan(void)
 198 {
 199         F_STACK_FRAME *inner = innermost_stack_frame(
 200                 untag_callstack(dpop()));
 201         type_check(QUOTATION_TYPE,frame_executing(inner));
 202
 203         dpush(frame_scan(inner));
 204 }
 205
 206 void primitive_set_innermost_stack_frame_quot(void)
 207 {
 208         F_CALLSTACK *callstack = untag_callstack(dpop());
 209         F_QUOTATION *quot = untag_quotation(dpop());
 210
 211         REGISTER_UNTAGGED(callstack);
 212         REGISTER_UNTAGGED(quot);
 213
 214         jit_compile(tag_object(quot),true);
 215
 216         UNREGISTER_UNTAGGED(quot);
 217         UNREGISTER_UNTAGGED(callstack);
 218
 219         F_STACK_FRAME *inner = innermost_stack_frame(callstack);
 220         type_check(QUOTATION_TYPE,frame_executing(inner));
 221
 222         CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt;
 223
 224         inner->xt = quot->xt;
 225
 226         FRAME_RETURN_ADDRESS(inner) = quot->xt + offset;
 227 }