vm/run.c

   1 #include "factor.h"
   2
   3 INLINE void execute(F_WORD* word)
   4 {
   5         ((XT)(word->xt))(word);
   6 }
   7
   8 INLINE void push_callframe(void)
   9 {
  10         cs += CELLS * 3;
  11         put(cs - CELLS * 2,callframe);
  12         put(cs - CELLS,callframe_scan);
  13         put(cs,callframe_end);
  14 }
  15
  16 INLINE void set_callframe(CELL quot)
  17 {
  18         F_ARRAY *untagged = (F_ARRAY*)UNTAG(quot);
  19         type_check(QUOTATION_TYPE,quot);
  20         callframe = quot;
  21         callframe_scan = AREF(untagged,0);
  22         callframe_end = AREF(untagged,array_capacity(untagged));
  23 }
  24
  25 void call(CELL quot)
  26 {
  27         if(quot == F)
  28                 return;
  29
  30         /* tail call optimization */
  31         if(callframe_scan < callframe_end)
  32                 push_callframe();
  33
  34         set_callframe(quot);
  35 }
  36
  37 /* Called from interpreter() */
  38 void handle_error(void)
  39 {
  40         if(throwing)
  41         {
  42                 if(thrown_keep_stacks)
  43                 {
  44                         ds = thrown_ds;
  45                         rs = thrown_rs;
  46                 }
  47                 else
  48                         fix_stacks();
  49
  50                 dpush(thrown_error);
  51                 /* Notify any 'catch' blocks */
  52                 push_callframe();
  53                 set_callframe(userenv[BREAK_ENV]);
  54                 throwing = false;
  55         }
  56 }
  57
  58 void interpreter_loop(void)
  59 {
  60         CELL next;
  61
  62         for(;;)
  63         {
  64                 if(callframe_scan == callframe_end)
  65                 {
  66                         if(cs_bot - cs == CELLS)
  67                                 return;
  68
  69                         callframe_end = get(cs);
  70                         callframe_scan = get(cs - CELLS);
  71                         callframe = get(cs - CELLS * 2);
  72                         cs -= CELLS * 3;
  73                         continue;
  74                 }
  75
  76                 next = get(callframe_scan);
  77                 callframe_scan += CELLS;
  78
  79                 switch(TAG(next))
  80                 {
  81                 case WORD_TYPE:
  82                         execute(untag_word_fast(next));
  83                         break;
  84                 case WRAPPER_TYPE:
  85                         dpush(untag_wrapper_fast(next)->object);
  86                         break;
  87                 default:
  88                         dpush(next);
  89                         break;
  90                 }
  91         }
  92 }
  93
  94 void interpreter(void)
  95 {
  96         SETJMP(stack_chain->toplevel);
  97         handle_error();
  98         interpreter_loop();
  99 }
 100
 101 /* Called by compiled callbacks after nest_stacks() and boxing registers */
 102 void run_callback(CELL quot)
 103 {
 104         call(quot);
 105         run();
 106 }
 107
 108 /* XT of deferred words */
 109 void undefined(F_WORD* word)
 110 {
 111         general_error(ERROR_UNDEFINED_WORD,tag_word(word),F,true);
 112 }
 113
 114 /* XT of compound definitions */
 115 void docol(F_WORD* word)
 116 {
 117         call(word->def);
 118 }
 119
 120 /* pushes word parameter */
 121 void dosym(F_WORD* word)
 122 {
 123         dpush(word->def);
 124 }
 125
 126 void primitive_execute(void)
 127 {
 128         execute(untag_word(dpop()));
 129 }
 130
 131 void primitive_call(void)
 132 {
 133         call(dpop());
 134 }
 135
 136 void primitive_ifte(void)
 137 {
 138         ds -= CELLS * 3;
 139         call(get(ds + CELLS) == F ? get(ds + CELLS * 3) : get(ds + CELLS * 2));
 140 }
 141
 142 void primitive_dispatch(void)
 143 {
 144         F_ARRAY *a = untag_array_fast(dpop());
 145         F_FIXNUM n = untag_fixnum_fast(dpop());
 146         call(get(AREF(a,n)));
 147 }
 148
 149 void primitive_getenv(void)
 150 {
 151         F_FIXNUM e = untag_fixnum_fast(dpeek());
 152         drepl(userenv[e]);
 153 }
 154
 155 void primitive_setenv(void)
 156 {
 157         F_FIXNUM e = untag_fixnum_fast(dpop());
 158         CELL value = dpop();
 159         userenv[e] = value;
 160 }
 161
 162 void primitive_exit(void)
 163 {
 164         exit(to_fixnum(dpop()));
 165 }
 166
 167 void primitive_os_env(void)
 168 {
 169         char *name, *value;
 170
 171         maybe_gc(0);
 172
 173         name = unbox_char_string();
 174         value = getenv(name);
 175         if(value == NULL)
 176                 dpush(F);
 177         else
 178                 box_char_string(getenv(name));
 179 }
 180
 181 void primitive_eq(void)
 182 {
 183         CELL lhs = dpop();
 184         CELL rhs = dpeek();
 185         drepl((lhs == rhs) ? T : F);
 186 }
 187
 188 void primitive_millis(void)
 189 {
 190         maybe_gc(0);
 191         dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
 192 }
 193
 194 void primitive_type(void)
 195 {
 196         drepl(tag_fixnum(type_of(dpeek())));
 197 }
 198
 199 void primitive_tag(void)
 200 {
 201         drepl(tag_fixnum(TAG(dpeek())));
 202 }
 203
 204 void primitive_slot(void)
 205 {
 206         F_FIXNUM slot = untag_fixnum_fast(dpop());
 207         CELL obj = UNTAG(dpop());
 208         dpush(get(SLOT(obj,slot)));
 209 }
 210
 211 void primitive_set_slot(void)
 212 {
 213         F_FIXNUM slot = untag_fixnum_fast(dpop());
 214         CELL obj = UNTAG(dpop());
 215         CELL value = dpop();
 216         put(SLOT(obj,slot),value);
 217         write_barrier(obj);
 218 }
 219
 220 void primitive_integer_slot(void)
 221 {
 222         F_FIXNUM slot = untag_fixnum_fast(dpop());
 223         CELL obj = UNTAG(dpop());
 224         dpush(tag_cell(get(SLOT(obj,slot))));
 225 }
 226
 227 void primitive_set_integer_slot(void)
 228 {
 229         F_FIXNUM slot = untag_fixnum_fast(dpop());
 230         CELL obj = UNTAG(dpop());
 231         F_FIXNUM value = to_cell(dpop());
 232         put(SLOT(obj,slot),value);
 233 }
 234
 235 CELL clone(CELL obj)
 236 {
 237         CELL size = object_size(obj);
 238         CELL tag = TAG(obj);
 239         void *new_obj = allot(size);
 240         return RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag);
 241 }
 242
 243 void primitive_clone(void)
 244 {
 245         maybe_gc(0);
 246         drepl(clone(dpeek()));
 247 }
 248
 249 void fatal_error(char* msg, CELL tagged)
 250 {
 251         fprintf(stderr,"Fatal error: %s %lx\n",msg,tagged);
 252         exit(1);
 253 }
 254
 255 void critical_error(char* msg, CELL tagged)
 256 {
 257         fprintf(stderr,"Critical error: %s %lx\n",msg,tagged);
 258         factorbug();
 259 }
 260
 261 void early_error(CELL error)
 262 {
 263         if(userenv[BREAK_ENV] == F)
 264         {
 265                 /* Crash at startup */
 266                 fprintf(stderr,"Error during startup: ");
 267                 print_obj(error);
 268                 fprintf(stderr,"\n");
 269                 factorbug();
 270         }
 271 }
 272
 273 void throw_error(CELL error, bool keep_stacks)
 274 {
 275         early_error(error);
 276
 277         throwing = true;
 278         thrown_error = error;
 279         thrown_keep_stacks = keep_stacks;
 280         thrown_ds = ds;
 281         thrown_rs = rs;
 282
 283         /* Return to interpreter() function */
 284         LONGJMP(stack_chain->toplevel,1);
 285 }
 286
 287 void primitive_throw(void)
 288 {
 289         throw_error(dpop(),true);
 290 }
 291
 292 void primitive_die(void)
 293 {
 294         factorbug();
 295 }
 296
 297 void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks)
 298 {
 299         throw_error(make_array_4(userenv[ERROR_ENV],
 300                 tag_fixnum(error),arg1,arg2),keep_stacks);
 301 }
 302
 303 void memory_protection_error(void *addr, int signal)
 304 {
 305         if(in_page(addr, (void *) ds_bot, 0, -1))
 306                 general_error(ERROR_DS_UNDERFLOW,F,F,false);
 307         else if(in_page(addr, (void *) ds_bot, ds_size, 0))
 308                 general_error(ERROR_DS_OVERFLOW,F,F,false);
 309         else if(in_page(addr, (void *) rs_bot, 0, -1))
 310                 general_error(ERROR_RS_UNDERFLOW,F,F,false);
 311         else if(in_page(addr, (void *) rs_bot, rs_size, 0))
 312                 general_error(ERROR_RS_OVERFLOW,F,F,false);
 313         else if(in_page(addr, (void *) cs_bot, 0, -1))
 314                 general_error(ERROR_CS_UNDERFLOW,F,F,false);
 315         else if(in_page(addr, (void *) cs_bot, cs_size, 0))
 316                 general_error(ERROR_CS_OVERFLOW,F,F,false);
 317         else
 318                 signal_error(signal);
 319 }
 320
 321 /* It is not safe to access 'ds' from a signal handler, so we just not
 322 touch it */
 323 void signal_error(int signal)
 324 {
 325         general_error(ERROR_SIGNAL,tag_fixnum(signal),F,false);
 326 }
 327
 328 void type_error(CELL type, CELL tagged)
 329 {
 330         general_error(ERROR_TYPE,tag_fixnum(type),tagged,true);
 331 }