vm/callstack.cpp

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