vm/code_block.c

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