vm/callstack.cpp

   1 #include "master.hpp"
   2
   3 namespace factor
   4 {
   5
   6 void factor_vm::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 *factor_vm::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 *factor_vm::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 *factor_vm::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 inline void factor_vm::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_FORWARD(callstack)
  64
  65 inline void factor_vm::primitive_set_callstack()
  66 {
  67         callstack *stack = untag_check<callstack>(dpop());
  68
  69         set_callstack(stack_chain->callstack_bottom,
  70                 stack->top(),
  71                 untag_fixnum(stack->length),
  72                 memcpy);
  73
  74         /* We cannot return here ... */
  75         critical_error("Bug in set_callstack()",0);
  76 }
  77
  78 PRIMITIVE_FORWARD(set_callstack)
  79
  80 code_block *factor_vm::frame_code(stack_frame *frame)
  81 {
  82         check_frame(frame);
  83         return (code_block *)frame->xt - 1;
  84 }
  85
  86 cell factor_vm::frame_type(stack_frame *frame)
  87 {
  88         return frame_code(frame)->type;
  89 }
  90
  91 cell factor_vm::frame_executing(stack_frame *frame)
  92 {
  93         code_block *compiled = frame_code(frame);
  94         if(compiled->literals == F || !stack_traces_p())
  95                 return F;
  96         else
  97         {
  98                 array *literals = untag<array>(compiled->literals);
  99                 cell executing = array_nth(literals,0);
 100                 check_data_pointer((object *)executing);
 101                 return executing;
 102         }
 103 }
 104
 105 stack_frame *factor_vm::frame_successor(stack_frame *frame)
 106 {
 107         check_frame(frame);
 108         return (stack_frame *)((cell)frame - frame->size);
 109 }
 110
 111 /* Allocates memory */
 112 cell factor_vm::frame_scan(stack_frame *frame)
 113 {
 114         switch(frame_type(frame))
 115         {
 116         case QUOTATION_TYPE:
 117                 {
 118                         cell quot = frame_executing(frame);
 119                         if(quot == F)
 120                                 return F;
 121                         else
 122                         {
 123                                 char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
 124                                 char *quot_xt = (char *)(frame_code(frame) + 1);
 125
 126                                 return tag_fixnum(quot_code_offset_to_scan(
 127                                         quot,(cell)(return_addr - quot_xt)));
 128                         }
 129                 }
 130         case WORD_TYPE:
 131                 return F;
 132         default:
 133                 critical_error("Bad frame type",frame_type(frame));
 134                 return F;
 135         }
 136 }
 137
 138 namespace
 139 {
 140
 141 struct stack_frame_accumulator {
 142         growable_array frames;
 143
 144         stack_frame_accumulator(factor_vm *vm) : frames(vm) {}
 145
 146         void operator()(stack_frame *frame, factor_vm *myvm)
 147         {
 148                 gc_root<object> executing(myvm->frame_executing(frame),myvm);
 149                 gc_root<object> scan(myvm->frame_scan(frame),myvm);
 150
 151                 frames.add(executing.value());
 152                 frames.add(scan.value());
 153         }
 154 };
 155
 156 }
 157
 158 inline void factor_vm::primitive_callstack_to_array()
 159 {
 160         gc_root<callstack> callstack(dpop(),this);
 161
 162         stack_frame_accumulator accum(this);
 163         iterate_callstack_object(callstack.untagged(),accum);
 164         accum.frames.trim();
 165
 166         dpush(accum.frames.elements.value());
 167 }
 168
 169 PRIMITIVE_FORWARD(callstack_to_array)
 170
 171 stack_frame *factor_vm::innermost_stack_frame(callstack *stack)
 172 {
 173         stack_frame *top = stack->top();
 174         stack_frame *bottom = stack->bottom();
 175         stack_frame *frame = bottom - 1;
 176
 177         while(frame >= top && frame_successor(frame) >= top)
 178                 frame = frame_successor(frame);
 179
 180         return frame;
 181 }
 182
 183 stack_frame *factor_vm::innermost_stack_frame_quot(callstack *callstack)
 184 {
 185         stack_frame *inner = innermost_stack_frame(callstack);
 186         tagged<quotation>(frame_executing(inner)).untag_check(this);
 187         return inner;
 188 }
 189
 190 /* Some primitives implementing a limited form of callstack mutation.
 191 Used by the single stepper. */
 192 inline void factor_vm::primitive_innermost_stack_frame_executing()
 193 {
 194         dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
 195 }
 196
 197 PRIMITIVE_FORWARD(innermost_stack_frame_executing)
 198
 199 inline void factor_vm::primitive_innermost_stack_frame_scan()
 200 {
 201         dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
 202 }
 203
 204 PRIMITIVE_FORWARD(innermost_stack_frame_scan)
 205
 206 inline void factor_vm::primitive_set_innermost_stack_frame_quot()
 207 {
 208         gc_root<callstack> callstack(dpop(),this);
 209         gc_root<quotation> quot(dpop(),this);
 210
 211         callstack.untag_check(this);
 212         quot.untag_check(this);
 213
 214         jit_compile(quot.value(),true);
 215
 216         stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
 217         cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
 218         inner->xt = quot->xt;
 219         FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
 220 }
 221
 222 PRIMITIVE_FORWARD(set_innermost_stack_frame_quot)
 223
 224 /* called before entry into Factor code. */
 225 void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom)
 226 {
 227         stack_chain->callstack_bottom = callstack_bottom;
 228 }
 229
 230 VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *myvm)
 231 {
 232         ASSERTVM();
 233         return VM_PTR->save_callstack_bottom(callstack_bottom);
 234 }
 235
 236 }