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         return (void *)undefined_symbol;
 344 }
 345
 346 /* Compute an address to store at a relocation */
 347 void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
 348 {
 349 #ifdef FACTOR_DEBUG
 350         type_check(ARRAY_TYPE,compiled->literals);
 351         type_check(BYTE_ARRAY_TYPE,compiled->relocation);
 352 #endif
 353
 354         CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
 355         F_ARRAY *literals = untag_array_fast(compiled->literals);
 356         F_FIXNUM absolute_value;
 357
 358         switch(REL_TYPE(rel))
 359         {
 360         case RT_PRIMITIVE:
 361                 absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))];
 362                 break;
 363         case RT_DLSYM:
 364                 absolute_value = (CELL)get_rel_symbol(literals,index);
 365                 break;
 366         case RT_IMMEDIATE:
 367                 absolute_value = array_nth(literals,index);
 368                 break;
 369         case RT_XT:
 370                 absolute_value = object_xt(array_nth(literals,index));
 371                 break;
 372         case RT_XT_DIRECT:
 373                 absolute_value = word_direct_xt(array_nth(literals,index));
 374                 break;
 375         case RT_HERE:
 376                 absolute_value = offset + (short)to_fixnum(array_nth(literals,index));
 377                 break;
 378         case RT_THIS:
 379                 absolute_value = (CELL)(compiled + 1);
 380                 break;
 381         case RT_STACK_CHAIN:
 382                 absolute_value = (CELL)&stack_chain;
 383                 break;
 384         case RT_UNTAGGED:
 385                 absolute_value = to_fixnum(array_nth(literals,index));
 386                 break;
 387         default:
 388                 critical_error("Bad rel type",rel);
 389                 return; /* Can't happen */
 390         }
 391
 392         store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
 393 }
 394
 395 /* Perform all fixups on a code block */
 396 void relocate_code_block(F_CODE_BLOCK *compiled)
 397 {
 398         compiled->block.last_scan = NURSERY;
 399         compiled->block.needs_fixup = false;
 400         iterate_relocations(compiled,relocate_code_block_step);
 401         flush_icache_for(compiled);
 402 }
 403
 404 /* Fixup labels. This is done at compile time, not image load time */
 405 void fixup_labels(F_ARRAY *labels, F_CODE_BLOCK *compiled)
 406 {
 407         CELL i;
 408         CELL size = array_capacity(labels);
 409
 410         for(i = 0; i < size; i += 3)
 411         {
 412                 CELL klass = to_fixnum(array_nth(labels,i));
 413                 CELL offset = to_fixnum(array_nth(labels,i + 1));
 414                 CELL target = to_fixnum(array_nth(labels,i + 2));
 415
 416                 store_address_in_code_block(klass,
 417                         offset + (CELL)(compiled + 1),
 418                         target + (CELL)(compiled + 1));
 419         }
 420 }
 421
 422 /* Might GC */
 423 F_CODE_BLOCK *allot_code_block(CELL size)
 424 {
 425         F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
 426
 427         /* If allocation failed, do a code GC */
 428         if(block == NULL)
 429         {
 430                 gc();
 431                 block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
 432
 433                 /* Insufficient room even after code GC, give up */
 434                 if(block == NULL)
 435                 {
 436                         CELL used, total_free, max_free;
 437                         heap_usage(&code_heap,&used,&total_free,&max_free);
 438
 439                         print_string("Code heap stats:\n");
 440                         print_string("Used: "); print_cell(used); nl();
 441                         print_string("Total free space: "); print_cell(total_free); nl();
 442                         print_string("Largest free block: "); print_cell(max_free); nl();
 443                         fatal_error("Out of memory in add-compiled-block",0);
 444                 }
 445         }
 446
 447         return (F_CODE_BLOCK *)block;
 448 }
 449
 450 /* Might GC */
 451 F_CODE_BLOCK *add_code_block(
 452         CELL type,
 453         CELL code_,
 454         CELL labels_,
 455         CELL relocation_,
 456         CELL literals_)
 457 {
 458         gc_root<F_BYTE_ARRAY> code(code_);
 459         gc_root<F_OBJECT> labels(labels_);
 460         gc_root<F_BYTE_ARRAY> relocation(relocation_);
 461         gc_root<F_ARRAY> literals(literals_);
 462
 463         CELL code_length = align8(array_capacity(code.untagged()));
 464         F_CODE_BLOCK *compiled = allot_code_block(code_length);
 465
 466         /* compiled header */
 467         compiled->block.type = type;
 468         compiled->block.last_scan = NURSERY;
 469         compiled->block.needs_fixup = true;
 470         compiled->relocation = relocation.value();
 471
 472         /* slight space optimization */
 473         if(literals.type() == ARRAY_TYPE && array_capacity(literals.untagged()) == 0)
 474                 compiled->literals = F;
 475         else
 476                 compiled->literals = literals.value();
 477
 478         /* code */
 479         memcpy(compiled + 1,code.untagged() + 1,code_length);
 480
 481         /* fixup labels */
 482         if(labels.value() != F)
 483                 fixup_labels(labels.as<F_ARRAY>().untagged(),compiled);
 484
 485         /* next time we do a minor GC, we have to scan the code heap for
 486         literals */
 487         last_code_heap_scan = NURSERY;
 488
 489         return compiled;
 490 }