vm/code_heap.c

   1 #include "master.h"
   2
   3 /* References to undefined symbols are patched up to call this function on
   4 image load */
   5 void undefined_symbol(void)
   6 {
   7         general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
   8 }
   9
  10 INLINE CELL get_literal(CELL literals_start, CELL num)
  11 {
  12         return get(CREF(literals_start,num));
  13 }
  14
  15 /* Look up an external library symbol referenced by a compiled code block */
  16 void *get_rel_symbol(F_REL *rel, CELL literals_start)
  17 {
  18         CELL arg = REL_ARGUMENT(rel);
  19         CELL symbol = get_literal(literals_start,arg);
  20         CELL library = get_literal(literals_start,arg + 1);
  21
  22         F_DLL *dll = (library == F ? NULL : untag_dll(library));
  23
  24         if(dll != NULL && !dll->dll)
  25                 return undefined_symbol;
  26
  27         if(type_of(symbol) == BYTE_ARRAY_TYPE)
  28         {
  29                 F_SYMBOL *name = alien_offset(symbol);
  30                 void *sym = ffi_dlsym(dll,name);
  31
  32                 if(sym)
  33                         return sym;
  34         }
  35         else if(type_of(symbol) == ARRAY_TYPE)
  36         {
  37                 CELL i;
  38                 F_ARRAY *names = untag_object(symbol);
  39                 for(i = 0; i < array_capacity(names); i++)
  40                 {
  41                         F_SYMBOL *name = alien_offset(array_nth(names,i));
  42                         void *sym = ffi_dlsym(dll,name);
  43
  44                         if(sym)
  45                                 return sym;
  46                 }
  47         }
  48
  49         return undefined_symbol;
  50 }
  51
  52 /* Compute an address to store at a relocation */
  53 INLINE CELL compute_code_rel(F_REL *rel,
  54         CELL code_start, CELL literals_start)
  55 {
  56         CELL obj;
  57
  58         switch(REL_TYPE(rel))
  59         {
  60         case RT_PRIMITIVE:
  61                 return (CELL)primitives[REL_ARGUMENT(rel)];
  62         case RT_DLSYM:
  63                 return (CELL)get_rel_symbol(rel,literals_start);
  64         case RT_IMMEDIATE:
  65                 return get(CREF(literals_start,REL_ARGUMENT(rel)));
  66         case RT_XT:
  67                 obj = get(CREF(literals_start,REL_ARGUMENT(rel)));
  68                 if(type_of(obj) == WORD_TYPE)
  69                         return (CELL)untag_word(obj)->xt;
  70                 else
  71                         return (CELL)untag_quotation(obj)->xt;
  72         case RT_HERE:
  73                 return rel->offset + code_start + (short)REL_ARGUMENT(rel);
  74         case RT_LABEL:
  75                 return code_start + REL_ARGUMENT(rel);
  76         case RT_STACK_CHAIN:
  77                 return (CELL)&stack_chain;
  78         default:
  79                 critical_error("Bad rel type",rel->type);
  80                 return -1; /* Can't happen */
  81         }
  82 }
  83
  84 /* Store a 32-bit value into a PowerPC LIS/ORI sequence */
  85 INLINE void reloc_set_2_2(CELL cell, CELL value)
  86 {
  87         put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
  88         put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
  89 }
  90
  91 /* Store a value into a bitfield of a PowerPC instruction */
  92 INLINE void reloc_set_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
  93 {
  94         /* This is unaccurate but good enough */
  95         F_FIXNUM test = (F_FIXNUM)mask >> 1;
  96         if(value <= -test || value >= test)
  97                 critical_error("Value does not fit inside relocation",0);
  98
  99         u32 original = *(u32*)cell;
 100         original &= ~mask;
 101         *(u32*)cell = (original | ((value >> shift) & mask));
 102 }
 103
 104 /* Perform a fixup on a code block */
 105 void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
 106 {
 107         F_FIXNUM relative_value = absolute_value - offset;
 108
 109         switch(class)
 110         {
 111         case RC_ABSOLUTE_CELL:
 112                 put(offset,absolute_value);
 113                 break;
 114         case RC_ABSOLUTE:
 115                 *(u32*)offset = absolute_value;
 116                 break;
 117         case RC_RELATIVE:
 118                 *(u32*)offset = relative_value - sizeof(u32);
 119                 break;
 120         case RC_ABSOLUTE_PPC_2_2:
 121                 reloc_set_2_2(offset,absolute_value);
 122                 break;
 123         case RC_RELATIVE_PPC_2:
 124                 reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
 125                 break;
 126         case RC_RELATIVE_PPC_3:
 127                 reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
 128                 break;
 129         case RC_RELATIVE_ARM_3:
 130                 reloc_set_masked(offset,relative_value - CELLS * 2,
 131                         REL_RELATIVE_ARM_3_MASK,2);
 132                 break;
 133         case RC_INDIRECT_ARM:
 134                 reloc_set_masked(offset,relative_value - CELLS,
 135                         REL_INDIRECT_ARM_MASK,0);
 136                 break;
 137         case RC_INDIRECT_ARM_PC:
 138                 reloc_set_masked(offset,relative_value - CELLS * 2,
 139                         REL_INDIRECT_ARM_MASK,0);
 140                 break;
 141         default:
 142                 critical_error("Bad rel class",class);
 143                 break;
 144         }
 145 }
 146
 147 /* Perform all fixups on a code block */
 148 void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
 149 {
 150         compiled->last_scan = NURSERY;
 151
 152         if(compiled->relocation != F)
 153         {
 154                 F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
 155
 156                 F_REL *rel = (F_REL *)(relocation + 1);
 157                 F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
 158
 159                 while(rel < rel_end)
 160                 {
 161                         CELL offset = rel->offset + code_start;
 162
 163                         F_FIXNUM absolute_value = compute_code_rel(
 164                                 rel,code_start,literals_start);
 165
 166                         apply_relocation(REL_CLASS(rel),offset,absolute_value);
 167
 168                         rel++;
 169                 }
 170         }
 171
 172         flush_icache(code_start,literals_start - code_start);
 173 }
 174
 175 /* Fixup labels. This is done at compile time, not image load time */
 176 void fixup_labels(F_ARRAY *labels, CELL code_format, CELL code_start)
 177 {
 178         CELL i;
 179         CELL size = array_capacity(labels);
 180
 181         for(i = 0; i < size; i += 3)
 182         {
 183                 CELL class = to_fixnum(array_nth(labels,i));
 184                 CELL offset = to_fixnum(array_nth(labels,i + 1));
 185                 CELL target = to_fixnum(array_nth(labels,i + 2));
 186
 187                 apply_relocation(class,
 188                         offset + code_start,
 189                         target + code_start);
 190         }
 191 }
 192
 193 /* Write a sequence of integers to memory, with 'format' bytes per integer */
 194 void deposit_integers(CELL here, F_ARRAY *array, CELL format)
 195 {
 196         CELL count = array_capacity(array);
 197         CELL i;
 198
 199         for(i = 0; i < count; i++)
 200         {
 201                 F_FIXNUM value = to_fixnum(array_nth(array,i));
 202                 if(format == 1)
 203                         bput(here + i,value);
 204                 else if(format == sizeof(unsigned int))
 205                         *(unsigned int *)(here + format * i) = value;
 206                 else if(format == CELLS)
 207                         put(CREF(here,i),value);
 208                 else
 209                         critical_error("Bad format in deposit_integers()",format);
 210         }
 211 }
 212
 213 /* Write a sequence of tagged pointers to memory */
 214 void deposit_objects(CELL here, F_ARRAY *array)
 215 {
 216         memcpy((void*)here,array + 1,array_capacity(array) * CELLS);
 217 }
 218
 219 bool stack_traces_p(void)
 220 {
 221         return to_boolean(userenv[STACK_TRACES_ENV]);
 222 }
 223
 224 CELL compiled_code_format(void)
 225 {
 226         return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
 227 }
 228
 229 CELL allot_code_block(CELL size)
 230 {
 231         CELL start = heap_allot(&code_heap,size);
 232
 233         /* If allocation failed, do a code GC */
 234         if(start == 0)
 235         {
 236                 gc();
 237                 start = heap_allot(&code_heap,size);
 238
 239                 /* Insufficient room even after code GC, give up */
 240                 if(start == 0)
 241                 {
 242                         CELL used, total_free, max_free;
 243                         heap_usage(&code_heap,&used,&total_free,&max_free);
 244
 245                         print_string("Code heap stats:\n");
 246                         print_string("Used: "); print_cell(used); nl();
 247                         print_string("Total free space: "); print_cell(total_free); nl();
 248                         print_string("Largest free block: "); print_cell(max_free); nl();
 249                         fatal_error("Out of memory in add-compiled-block",0);
 250                 }
 251         }
 252
 253         return start;
 254 }
 255
 256 /* Might GC */
 257 F_COMPILED *add_compiled_block(
 258         CELL type,
 259         F_ARRAY *code,
 260         F_ARRAY *labels,
 261         CELL relocation,
 262         F_ARRAY *literals)
 263 {
 264         CELL code_format = compiled_code_format();
 265
 266         CELL code_length = align8(array_capacity(code) * code_format);
 267         CELL literals_length = array_capacity(literals) * CELLS;
 268
 269         REGISTER_ROOT(relocation);
 270         REGISTER_UNTAGGED(code);
 271         REGISTER_UNTAGGED(labels);
 272         REGISTER_UNTAGGED(literals);
 273
 274         CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
 275
 276         UNREGISTER_UNTAGGED(literals);
 277         UNREGISTER_UNTAGGED(labels);
 278         UNREGISTER_UNTAGGED(code);
 279         UNREGISTER_ROOT(relocation);
 280
 281         /* compiled header */
 282         F_COMPILED *header = (void *)here;
 283         header->type = type;
 284         header->last_scan = NURSERY;
 285         header->code_length = code_length;
 286         header->literals_length = literals_length;
 287         header->relocation = relocation;
 288
 289         here += sizeof(F_COMPILED);
 290
 291         CELL code_start = here;
 292
 293         /* code */
 294         deposit_integers(here,code,code_format);
 295         here += code_length;
 296
 297         /* literals */
 298         deposit_objects(here,literals);
 299         here += literals_length;
 300
 301         /* fixup labels */
 302         if(labels)
 303                 fixup_labels(labels,code_format,code_start);
 304
 305         /* next time we do a minor GC, we have to scan the code heap for
 306         literals */
 307         last_code_heap_scan = NURSERY;
 308
 309         return header;
 310 }
 311
 312 void set_word_code(F_WORD *word, F_COMPILED *compiled)
 313 {
 314         if(compiled->type != WORD_TYPE)
 315                 critical_error("bad param to set_word_xt",(CELL)compiled);
 316
 317         word->code = compiled;
 318         word->compiledp = T;
 319 }
 320
 321 /* Allocates memory */
 322 void default_word_code(F_WORD *word, bool relocate)
 323 {
 324         REGISTER_UNTAGGED(word);
 325         jit_compile(word->def,relocate);
 326         UNREGISTER_UNTAGGED(word);
 327
 328         word->code = untag_quotation(word->def)->code;
 329         word->compiledp = F;
 330 }
 331
 332 void primitive_modify_code_heap(void)
 333 {
 334         bool rescan_code_heap = to_boolean(dpop());
 335         F_ARRAY *alist = untag_array(dpop());
 336
 337         CELL count = untag_fixnum_fast(alist->capacity);
 338         CELL i;
 339         for(i = 0; i < count; i++)
 340         {
 341                 F_ARRAY *pair = untag_array(array_nth(alist,i));
 342
 343                 F_WORD *word = untag_word(array_nth(pair,0));
 344
 345                 CELL data = array_nth(pair,1);
 346
 347                 if(data == F)
 348                 {
 349                         REGISTER_UNTAGGED(alist);
 350                         REGISTER_UNTAGGED(word);
 351                         default_word_code(word,false);
 352                         UNREGISTER_UNTAGGED(word);
 353                         UNREGISTER_UNTAGGED(alist);
 354                 }
 355                 else
 356                 {
 357                         F_ARRAY *compiled_code = untag_array(data);
 358
 359                         F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
 360                         CELL relocation = array_nth(compiled_code,1);
 361                         F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
 362                         F_ARRAY *code = untag_array(array_nth(compiled_code,3));
 363
 364                         REGISTER_UNTAGGED(alist);
 365                         REGISTER_UNTAGGED(word);
 366
 367                         F_COMPILED *compiled = add_compiled_block(
 368                                 WORD_TYPE,
 369                                 code,
 370                                 labels,
 371                                 relocation,
 372                                 literals);
 373
 374                         UNREGISTER_UNTAGGED(word);
 375                         UNREGISTER_UNTAGGED(alist);
 376
 377                         set_word_code(word,compiled);
 378                 }
 379
 380                 REGISTER_UNTAGGED(alist);
 381                 update_word_xt(word);
 382                 UNREGISTER_UNTAGGED(alist);
 383         }
 384
 385         /* If there were any interned words in the set, we relocate all XT
 386         references in the entire code heap. But if all the words are
 387         uninterned, it is impossible that other words reference them, so we
 388         only have to relocate the new words. This makes compile-call much
 389         more efficient */
 390         if(rescan_code_heap)
 391                 iterate_code_heap(relocate_code_block);
 392         else
 393         {
 394                 for(i = 0; i < count; i++)
 395                 {
 396                         F_ARRAY *pair = untag_array(array_nth(alist,i));
 397                         F_WORD *word = untag_word(array_nth(pair,0));
 398
 399                         iterate_code_heap_step(word->code,relocate_code_block);
 400                 }
 401         }
 402 }