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_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
  94 {
  95         return (F_CODE_BLOCK *)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_CODE_BLOCK *compiled = frame_code(frame);
 106         if(compiled->literals == F)
 107                 return F;
 108         else
 109         {
 110                 F_ARRAY *array = untag_object(compiled->literals);
 111                 return array_nth(array,0);
 112         }
 113 }
 114
 115 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
 116 {
 117         if(frame->size == 0)
 118                 critical_error("Stack frame has zero size",(CELL)frame);
 119         return (F_STACK_FRAME *)((CELL)frame - frame->size);
 120 }
 121
 122 CELL frame_scan(F_STACK_FRAME *frame)
 123 {
 124         if(frame_type(frame) == QUOTATION_TYPE)
 125         {
 126                 CELL quot = frame_executing(frame);
 127                 if(quot == F)
 128                         return F;
 129                 else
 130                 {
 131                         XT return_addr = FRAME_RETURN_ADDRESS(frame);
 132                         XT quot_xt = (XT)(frame_code(frame) + 1);
 133
 134                         return tag_fixnum(quot_code_offset_to_scan(
 135                                 quot,(CELL)(return_addr - quot_xt)));
 136                 }
 137         }
 138         else
 139                 return F;
 140 }
 141
 142 /* C doesn't have closures... */
 143 static CELL frame_count;
 144
 145 void count_stack_frame(F_STACK_FRAME *frame)
 146 {
 147         frame_count += 2;
 148 }
 149
 150 static CELL frame_index;
 151 static F_ARRAY *array;
 152
 153 void stack_frame_to_array(F_STACK_FRAME *frame)
 154 {
 155         set_array_nth(array,frame_index++,frame_executing(frame));
 156         set_array_nth(array,frame_index++,frame_scan(frame));
 157 }
 158
 159 void primitive_callstack_to_array(void)
 160 {
 161         F_CALLSTACK *stack = untag_callstack(dpop());
 162
 163         frame_count = 0;
 164         iterate_callstack_object(stack,count_stack_frame);
 165
 166         REGISTER_UNTAGGED(stack);
 167         array = allot_array_internal(ARRAY_TYPE,frame_count);
 168         UNREGISTER_UNTAGGED(stack);
 169
 170         frame_index = 0;
 171         iterate_callstack_object(stack,stack_frame_to_array);
 172
 173         dpush(tag_object(array));
 174 }
 175
 176 F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
 177 {
 178         F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack);
 179         CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length);
 180
 181         F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
 182
 183         while(frame >= top && frame_successor(frame) >= top)
 184                 frame = frame_successor(frame);
 185
 186         return frame;
 187 }
 188
 189 /* Some primitives implementing a limited form of callstack mutation.
 190 Used by the single stepper. */
 191 void primitive_innermost_stack_frame_quot(void)
 192 {
 193         F_STACK_FRAME *inner = innermost_stack_frame(
 194                 untag_callstack(dpop()));
 195         type_check(QUOTATION_TYPE,frame_executing(inner));
 196
 197         dpush(frame_executing(inner));
 198 }
 199
 200 void primitive_innermost_stack_frame_scan(void)
 201 {
 202         F_STACK_FRAME *inner = innermost_stack_frame(
 203                 untag_callstack(dpop()));
 204         type_check(QUOTATION_TYPE,frame_executing(inner));
 205
 206         dpush(frame_scan(inner));
 207 }
 208
 209 void primitive_set_innermost_stack_frame_quot(void)
 210 {
 211         F_CALLSTACK *callstack = untag_callstack(dpop());
 212         F_QUOTATION *quot = untag_quotation(dpop());
 213
 214         REGISTER_UNTAGGED(callstack);
 215         REGISTER_UNTAGGED(quot);
 216
 217         jit_compile(tag_object(quot),true);
 218
 219         UNREGISTER_UNTAGGED(quot);
 220         UNREGISTER_UNTAGGED(callstack);
 221
 222         F_STACK_FRAME *inner = innermost_stack_frame(callstack);
 223         type_check(QUOTATION_TYPE,frame_executing(inner));
 224
 225         CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt;
 226
 227         inner->xt = quot->xt;
 228
 229         FRAME_RETURN_ADDRESS(inner) = quot->xt + offset;
 230 }