vm/code_block.c

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