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                 {
 114                         cell quot = frame_executing(frame);
 115                         if(quot == F)
 116                                 return F;
 117                         else
 118                         {
 119                                 char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
 120                                 char *quot_xt = (char *)(frame_code(frame) + 1);
 121
 122                                 return tag_fixnum(quot_code_offset_to_scan(
 123                                         quot,(cell)(return_addr - quot_xt)));
 124                         }
 125                 }
 126         case WORD_TYPE:
 127                 return F;
 128         default:
 129                 critical_error("Bad frame type",frame_type(frame));
 130                 return F;
 131         }
 132 }
 133
 134 namespace
 135 {
 136
 137 struct stack_frame_accumulator {
 138         growable_array frames;
 139
 140         void operator()(stack_frame *frame)
 141         {
 142                 gc_root<object> executing(frame_executing(frame));
 143                 gc_root<object> scan(frame_scan(frame));
 144
 145                 frames.add(executing.value());
 146                 frames.add(scan.value());
 147         }
 148 };
 149
 150 }
 151
 152 PRIMITIVE(callstack_to_array)
 153 {
 154         gc_root<callstack> callstack(dpop());
 155
 156         stack_frame_accumulator accum;
 157         iterate_callstack_object(callstack.untagged(),accum);
 158         accum.frames.trim();
 159
 160         dpush(accum.frames.elements.value());
 161 }
 162
 163 stack_frame *innermost_stack_frame(callstack *stack)
 164 {
 165         stack_frame *top = stack->top();
 166         stack_frame *bottom = stack->bottom();
 167         stack_frame *frame = bottom - 1;
 168
 169         while(frame >= top && frame_successor(frame) >= top)
 170                 frame = frame_successor(frame);
 171
 172         return frame;
 173 }
 174
 175 stack_frame *innermost_stack_frame_quot(callstack *callstack)
 176 {
 177         stack_frame *inner = innermost_stack_frame(callstack);
 178         tagged<quotation>(frame_executing(inner)).untag_check();
 179         return inner;
 180 }
 181
 182 /* Some primitives implementing a limited form of callstack mutation.
 183 Used by the single stepper. */
 184 PRIMITIVE(innermost_stack_frame_executing)
 185 {
 186         dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
 187 }
 188
 189 PRIMITIVE(innermost_stack_frame_scan)
 190 {
 191         dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
 192 }
 193
 194 PRIMITIVE(set_innermost_stack_frame_quot)
 195 {
 196         gc_root<callstack> callstack(dpop());
 197         gc_root<quotation> quot(dpop());
 198
 199         callstack.untag_check();
 200         quot.untag_check();
 201
 202         jit_compile(quot.value(),true);
 203
 204         stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
 205         cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
 206         inner->xt = quot->xt;
 207         FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
 208 }
 209
 210 /* called before entry into Factor code. */
 211 VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
 212 {
 213         stack_chain->callstack_bottom = callstack_bottom;
 214 }
 215
 216 }