vmpp/code_block.cpp

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