vm/run.c

   1 #include "master.h"
   2
   3 void uncurry(CELL obj)
   4 {
   5         F_CURRY *curry;
   6
   7         switch(type_of(obj))
   8         {
   9         case QUOTATION_TYPE:
  10                 dpush(obj);
  11                 break;
  12         case CURRY_TYPE:
  13                 curry = untag_object(obj);
  14                 dpush(curry->obj);
  15                 uncurry(curry->quot);
  16                 break;
  17         default:
  18                 type_error(QUOTATION_TYPE,obj);
  19                 break;
  20         }
  21 }
  22
  23 void update_xt(F_WORD* word)
  24 {
  25         word->compiledp = F;
  26
  27         if(word->def == T)
  28                 word->xt = dosym;
  29         else if(type_of(word->def) == QUOTATION_TYPE)
  30         {
  31                 if(profiling)
  32                         word->xt = docol_profiling;
  33                 else
  34                         word->xt = docol;
  35         }
  36         else if(type_of(word->def) == FIXNUM_TYPE)
  37                 word->xt = primitives[to_fixnum(word->def)];
  38         else
  39                 word->xt = undefined;
  40 }
  41
  42 DEFINE_PRIMITIVE(uncurry)
  43 {
  44         uncurry(dpop());
  45 }
  46
  47 DEFINE_PRIMITIVE(getenv)
  48 {
  49         F_FIXNUM e = untag_fixnum_fast(dpeek());
  50         drepl(userenv[e]);
  51 }
  52
  53 DEFINE_PRIMITIVE(setenv)
  54 {
  55         F_FIXNUM e = untag_fixnum_fast(dpop());
  56         CELL value = dpop();
  57         userenv[e] = value;
  58 }
  59
  60 DEFINE_PRIMITIVE(exit)
  61 {
  62         exit(to_fixnum(dpop()));
  63 }
  64
  65 DEFINE_PRIMITIVE(os_env)
  66 {
  67         char *name = unbox_char_string();
  68         char *value = getenv(name);
  69         if(value == NULL)
  70                 dpush(F);
  71         else
  72                 box_char_string(value);
  73 }
  74
  75 DEFINE_PRIMITIVE(eq)
  76 {
  77         CELL lhs = dpop();
  78         CELL rhs = dpeek();
  79         drepl((lhs == rhs) ? T : F);
  80 }
  81
  82 DEFINE_PRIMITIVE(millis)
  83 {
  84         box_unsigned_8(current_millis());
  85 }
  86
  87 DEFINE_PRIMITIVE(sleep)
  88 {
  89         sleep_millis(to_cell(dpop()));
  90 }
  91
  92 DEFINE_PRIMITIVE(type)
  93 {
  94         drepl(tag_fixnum(type_of(dpeek())));
  95 }
  96
  97 DEFINE_PRIMITIVE(tag)
  98 {
  99         drepl(tag_fixnum(TAG(dpeek())));
 100 }
 101
 102 DEFINE_PRIMITIVE(class_hash)
 103 {
 104         CELL obj = dpeek();
 105         CELL tag = TAG(obj);
 106         if(tag == TUPLE_TYPE)
 107         {
 108                 F_WORD *class = untag_object(get(SLOT(obj,2)));
 109                 drepl(class->hashcode);
 110         }
 111         else if(tag == OBJECT_TYPE)
 112                 drepl(get(UNTAG(obj)));
 113         else
 114                 drepl(tag_fixnum(tag));
 115 }
 116
 117 DEFINE_PRIMITIVE(slot)
 118 {
 119         F_FIXNUM slot = untag_fixnum_fast(dpop());
 120         CELL obj = dpop();
 121         dpush(get(SLOT(obj,slot)));
 122 }
 123
 124 DEFINE_PRIMITIVE(set_slot)
 125 {
 126         F_FIXNUM slot = untag_fixnum_fast(dpop());
 127         CELL obj = dpop();
 128         CELL value = dpop();
 129         set_slot(obj,slot,value);
 130 }
 131
 132 void fatal_error(char* msg, CELL tagged)
 133 {
 134         fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged);
 135         exit(1);
 136 }
 137
 138 void critical_error(char* msg, CELL tagged)
 139 {
 140         fprintf(stderr,"You have triggered a bug in Factor. Please report.\n");
 141         fprintf(stderr,"critical_error: %s %lx\n",msg,tagged);
 142         factorbug();
 143 }
 144
 145 void throw_error(CELL error, F_STACK_FRAME *callstack_top)
 146 {
 147         /* If error was thrown during heap scan, we re-enable the GC */
 148         gc_off = false;
 149
 150         /* Reset local roots */
 151         extra_roots = stack_chain->extra_roots;
 152
 153         /* If we had an underflow or overflow, stack pointers might be
 154         out of bounds */
 155         fix_stacks();
 156
 157         dpush(error);
 158
 159         /* If the error handler is set, we rewind any C stack frames and
 160         pass the error to user-space. */
 161         if(userenv[BREAK_ENV] != F)
 162         {
 163                 /* Errors thrown from C code pass NULL for this parameter.
 164                 Errors thrown from Factor code, or signal handlers, pass the
 165                 actual stack pointer at the time, since the saved pointer is
 166                 not necessarily up to date at that point. */
 167                 if(!callstack_top)
 168                         callstack_top = stack_chain->callstack_top;
 169
 170                 throw_impl(userenv[BREAK_ENV],callstack_top);
 171         }
 172         /* Error was thrown in early startup before error handler is set, just
 173         crash. */
 174         else
 175         {
 176                 fprintf(stderr,"You have triggered a bug in Factor. Please report.\n");
 177                 fprintf(stderr,"early_error: ");
 178                 print_obj(error);
 179                 fprintf(stderr,"\n");
 180                 factorbug();
 181         }
 182 }
 183
 184 void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2,
 185         F_STACK_FRAME *callstack_top)
 186 {
 187         throw_error(allot_array_4(userenv[ERROR_ENV],
 188                 tag_fixnum(error),arg1,arg2),callstack_top);
 189 }
 190
 191 void type_error(CELL type, CELL tagged)
 192 {
 193         general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
 194 }
 195
 196 void not_implemented_error(void)
 197 {
 198         general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
 199 }
 200
 201 /* This function is called from the undefined function in cpu_*.S */
 202 void undefined_error(CELL word, F_STACK_FRAME *callstack_top)
 203 {
 204         stack_chain->callstack_top = callstack_top;
 205         general_error(ERROR_UNDEFINED_WORD,word,F,NULL);
 206 }
 207
 208 /* Test if 'fault' is in the guard page at the top or bottom (depending on
 209 offset being 0 or -1) of area+area_size */
 210 bool in_page(CELL fault, CELL area, CELL area_size, int offset)
 211 {
 212         int pagesize = getpagesize();
 213         area += area_size;
 214         area += offset * pagesize;
 215
 216         return fault >= area && fault <= area + pagesize;
 217 }
 218
 219 void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
 220 {
 221         if(in_page(addr, ds_bot, 0, -1))
 222                 general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
 223         else if(in_page(addr, ds_bot, ds_size, 0))
 224                 general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
 225         else if(in_page(addr, rs_bot, 0, -1))
 226                 general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
 227         else if(in_page(addr, rs_bot, rs_size, 0))
 228                 general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
 229         else if(in_page(addr, nursery->end, 0, 0))
 230                 critical_error("allot_object() missed GC check",0);
 231         else if(in_page(addr, extra_roots_region->start, 0, -1))
 232                 critical_error("local root underflow",0);
 233         else if(in_page(addr, extra_roots_region->end, 0, 0))
 234                 critical_error("local root overflow",0);
 235         else
 236                 general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
 237 }
 238
 239 void signal_error(int signal, F_STACK_FRAME *native_stack)
 240 {
 241         general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
 242 }
 243
 244 void divide_by_zero_error(F_STACK_FRAME *native_stack)
 245 {
 246         general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack);
 247 }
 248
 249 DEFINE_PRIMITIVE(throw)
 250 {
 251         uncurry(dpop());
 252         throw_impl(dpop(),stack_chain->callstack_top);
 253 }
 254
 255 void enable_word_profiling(F_WORD *word)
 256 {
 257         if(word->xt == docol)
 258                 word->xt = docol_profiling;
 259 }
 260
 261 void disable_word_profiling(F_WORD *word)
 262 {
 263         if(word->xt == docol_profiling)
 264                 word->xt = docol;
 265 }
 266
 267 DEFINE_PRIMITIVE(profiling)
 268 {
 269         profiling = to_boolean(dpop());
 270
 271         begin_scan();
 272
 273         CELL obj;
 274         while((obj = next_object()) != F)
 275         {
 276                 if(type_of(obj) == WORD_TYPE)
 277                 {
 278                         if(profiling)
 279                                 enable_word_profiling(untag_object(obj));
 280                         else
 281                                 disable_word_profiling(untag_object(obj));
 282                 }
 283         }
 284
 285         gc_off = false; /* end heap scan */
 286 }