vm/callstack.cpp

   1 #include "master.hpp"
   2
   3 namespace factor
   4 {
   5
   6 static void check_frame(stack_frame *frame)
   7 {
   8 #ifdef FACTOR_DEBUG
   9         check_code_pointer((cell)frame->xt);
  10         assert(frame->size != 0);
  11 #endif
  12 }
  13
  14 callstack *allot_callstack(cell size)
  15 {
  16         callstack *stack = allot<callstack>(callstack_size(size));
  17         stack->length = tag_fixnum(size);
  18         return stack;
  19 }
  20
  21 stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom)
  22 {
  23         stack_frame *frame = bottom - 1;
  24
  25         while(frame >= top)
  26                 frame = frame_successor(frame);
  27
  28         return frame + 1;
  29 }
  30
  31 /* We ignore the topmost frame, the one calling 'callstack',
  32 so that set-callstack doesn't get stuck in an infinite loop.
  33
  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()
  39 {
  40         stack_frame *frame = stack_chain->callstack_bottom - 1;
  41         while(frame >= stack_chain->callstack_top
  42                 && frame_successor(frame) >= stack_chain->callstack_top)
  43         {
  44                 frame = frame_successor(frame);
  45         }
  46         return frame + 1;
  47 }
  48
  49 PRIMITIVE(callstack)
  50 {
  51         stack_frame *top = capture_start();
  52         stack_frame *bottom = stack_chain->callstack_bottom;
  53
  54         fixnum size = (cell)bottom - (cell)top;
  55         if(size < 0)
  56                 size = 0;
  57
  58         callstack *stack = allot_callstack(size);
  59         memcpy(stack->top(),top,size);
  60         dpush(tag<callstack>(stack));
  61 }
  62
  63 PRIMITIVE(set_callstack)
  64 {
  65         callstack *stack = untag_check<callstack>(dpop());
  66
  67         set_callstack(stack_chain->callstack_bottom,
  68                 stack->top(),
  69                 untag_fixnum(stack->length),
  70                 memcpy);
  71
  72         /* We cannot return here ... */
  73         critical_error("Bug in set_callstack()",0);
  74 }
  75
  76 code_block *frame_code(stack_frame *frame)
  77 {
  78         check_frame(frame);
  79         return (code_block *)frame->xt - 1;
  80 }
  81
  82 cell frame_type(stack_frame *frame)
  83 {
  84         return frame_code(frame)->type;
  85 }
  86
  87 cell frame_executing(stack_frame *frame)
  88 {
  89         code_block *compiled = frame_code(frame);
  90         if(compiled->literals == F || !stack_traces_p())
  91                 return F;
  92         else
  93         {
  94                 array *literals = untag<array>(compiled->literals);
  95                 cell executing = array_nth(literals,0);
  96                 check_data_pointer((object *)executing);
  97                 return executing;
  98         }
  99 }
 100
 101 stack_frame *frame_successor(stack_frame *frame)
 102 {
 103         check_frame(frame);
 104         return (stack_frame *)((cell)frame - frame->size);
 105 }
 106
 107 /* Allocates memory */
 108 cell frame_scan(stack_frame *frame)
 109 {
 110         switch(frame_type(frame))
 111         {
 112         case QUOTATION_TYPE:
 113                 cell quot = frame_executing(frame);
 114                 if(quot == F)
 115                         return F;
 116                 else
 117                 {
 118                         char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
 119                         char *quot_xt = (char *)(frame_code(frame) + 1);
 120
 121                         return tag_fixnum(quot_code_offset_to_scan(
 122                                 quot,(cell)(return_addr - quot_xt)));
 123                 }
 124         case WORD_TYPE:
 125                 return F;
 126         default:
 127                 critical_error("Bad frame type",frame_type(frame));
 128                 return F;
 129         }
 130 }
 131
 132 namespace
 133 {
 134
 135 struct stack_frame_accumulator {
 136         growable_array frames;
 137
 138         void operator()(stack_frame *frame)
 139         {
 140                 gc_root<object> executing(frame_executing(frame));
 141                 gc_root<object> scan(frame_scan(frame));
 142
 143                 frames.add(executing.value());
 144                 frames.add(scan.value());
 145         }
 146 };
 147
 148 }
 149
 150 PRIMITIVE(callstack_to_array)
 151 {
 152         gc_root<callstack> callstack(dpop());
 153
 154         stack_frame_accumulator accum;
 155         iterate_callstack_object(callstack.untagged(),accum);
 156         accum.frames.trim();
 157
 158         dpush(accum.frames.elements.value());
 159 }
 160
 161 stack_frame *innermost_stack_frame(callstack *stack)
 162 {
 163         stack_frame *top = stack->top();
 164         stack_frame *bottom = stack->bottom();
 165         stack_frame *frame = bottom - 1;
 166
 167         while(frame >= top && frame_successor(frame) >= top)
 168                 frame = frame_successor(frame);
 169
 170         return frame;
 171 }
 172
 173 stack_frame *innermost_stack_frame_quot(callstack *callstack)
 174 {
 175         stack_frame *inner = innermost_stack_frame(callstack);
 176         tagged<quotation>(frame_executing(inner)).untag_check();
 177         return inner;
 178 }
 179
 180 /* Some primitives implementing a limited form of callstack mutation.
 181 Used by the single stepper. */
 182 PRIMITIVE(innermost_stack_frame_executing)
 183 {
 184         dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
 185 }
 186
 187 PRIMITIVE(innermost_stack_frame_scan)
 188 {
 189         dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
 190 }
 191
 192 PRIMITIVE(set_innermost_stack_frame_quot)
 193 {
 194         gc_root<callstack> callstack(dpop());
 195         gc_root<quotation> quot(dpop());
 196
 197         callstack.untag_check();
 198         quot.untag_check();
 199
 200         jit_compile(quot.value(),true);
 201
 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;
 206 }
 207
 208 /* called before entry into Factor code. */
 209 VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
 210 {
 211         stack_chain->callstack_bottom = callstack_bottom;
 212 }
 213
 214 }