vm/code_heap.c

   1 #include "master.h"
   2
   3 /* Allocate a code heap during startup */
   4 void init_code_heap(CELL size)
   5 {
   6         new_heap(&code_heap,size);
   7 }
   8
   9 bool in_code_heap_p(CELL ptr)
  10 {
  11         return (ptr >= code_heap.segment->start
  12                 && ptr <= code_heap.segment->end);
  13 }
  14
  15 void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
  16 {
  17         if(compiled->type != WORD_TYPE)
  18                 critical_error("bad param to set_word_xt",(CELL)compiled);
  19
  20         word->code = compiled;
  21         word->optimizedp = T;
  22 }
  23
  24 /* Allocates memory */
  25 void default_word_code(F_WORD *word, bool relocate)
  26 {
  27         REGISTER_UNTAGGED(word);
  28         jit_compile(word->def,relocate);
  29         UNREGISTER_UNTAGGED(word);
  30
  31         word->code = untag_quotation(word->def)->code;
  32         word->optimizedp = F;
  33 }
  34
  35 /* Apply a function to every code block */
  36 void iterate_code_heap(CODE_HEAP_ITERATOR iter)
  37 {
  38         F_BLOCK *scan = first_block(&code_heap);
  39
  40         while(scan)
  41         {
  42                 if(scan->status != B_FREE)
  43                         iter(block_to_compiled(scan));
  44                 scan = next_block(&code_heap,scan);
  45         }
  46 }
  47
  48 /* Copy literals referenced from all code blocks to newspace. Only for
  49 aging and nursery collections */
  50 void copy_code_heap_roots(void)
  51 {
  52         iterate_code_heap(copy_literal_references);
  53 }
  54
  55 /* Update literals referenced from all code blocks. Only for tenured
  56 collections, done at the end. */
  57 void update_code_heap_roots(void)
  58 {
  59         iterate_code_heap(update_literal_references);
  60 }
  61
  62 /* Update pointers to words referenced from all code blocks. Only after
  63 defining a new word. */
  64 void update_code_heap_words(void)
  65 {
  66         iterate_code_heap(update_word_references);
  67 }
  68
  69 void primitive_modify_code_heap(void)
  70 {
  71         F_ARRAY *alist = untag_array(dpop());
  72
  73         CELL count = untag_fixnum_fast(alist->capacity);
  74         if(count == 0)
  75                 return;
  76
  77         CELL i;
  78         for(i = 0; i < count; i++)
  79         {
  80                 F_ARRAY *pair = untag_array(array_nth(alist,i));
  81
  82                 F_WORD *word = untag_word(array_nth(pair,0));
  83
  84                 CELL data = array_nth(pair,1);
  85
  86                 if(data == F)
  87                 {
  88                         REGISTER_UNTAGGED(alist);
  89                         REGISTER_UNTAGGED(word);
  90                         default_word_code(word,false);
  91                         UNREGISTER_UNTAGGED(word);
  92                         UNREGISTER_UNTAGGED(alist);
  93                 }
  94                 else
  95                 {
  96                         F_ARRAY *compiled_code = untag_array(data);
  97
  98                         F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
  99                         CELL relocation = array_nth(compiled_code,1);
 100                         F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
 101                         F_ARRAY *code = untag_array(array_nth(compiled_code,3));
 102
 103                         REGISTER_UNTAGGED(alist);
 104                         REGISTER_UNTAGGED(word);
 105
 106                         F_CODE_BLOCK *compiled = add_compiled_block(
 107                                 WORD_TYPE,
 108                                 code,
 109                                 labels,
 110                                 relocation,
 111                                 tag_object(literals));
 112
 113                         UNREGISTER_UNTAGGED(word);
 114                         UNREGISTER_UNTAGGED(alist);
 115
 116                         set_word_code(word,compiled);
 117                 }
 118
 119                 REGISTER_UNTAGGED(alist);
 120                 update_word_xt(word);
 121                 UNREGISTER_UNTAGGED(alist);
 122         }
 123
 124         update_code_heap_words();
 125 }
 126
 127 /* Push the free space and total size of the code heap */
 128 void primitive_code_room(void)
 129 {
 130         CELL used, total_free, max_free;
 131         heap_usage(&code_heap,&used,&total_free,&max_free);
 132         dpush(tag_fixnum((code_heap.segment->size) / 1024));
 133         dpush(tag_fixnum(used / 1024));
 134         dpush(tag_fixnum(total_free / 1024));
 135         dpush(tag_fixnum(max_free / 1024));
 136 }
 137
 138 F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
 139 {
 140         return block_to_compiled(compiled_to_block(compiled)->forwarding);
 141 }
 142
 143 void forward_frame_xt(F_STACK_FRAME *frame)
 144 {
 145         CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
 146         F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame));
 147         frame->xt = (XT)(forwarded + 1);
 148         FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
 149 }
 150
 151 void forward_object_xts(void)
 152 {
 153         begin_scan();
 154
 155         CELL obj;
 156
 157         while((obj = next_object()) != F)
 158         {
 159                 if(type_of(obj) == WORD_TYPE)
 160                 {
 161                         F_WORD *word = untag_object(obj);
 162
 163                         word->code = forward_xt(word->code);
 164                         if(word->profiling)
 165                                 word->profiling = forward_xt(word->profiling);
 166                 }
 167                 else if(type_of(obj) == QUOTATION_TYPE)
 168                 {
 169                         F_QUOTATION *quot = untag_object(obj);
 170
 171                         if(quot->compiledp != F)
 172                                 quot->code = forward_xt(quot->code);
 173                 }
 174                 else if(type_of(obj) == CALLSTACK_TYPE)
 175                 {
 176                         F_CALLSTACK *stack = untag_object(obj);
 177                         iterate_callstack_object(stack,forward_frame_xt);
 178                 }
 179         }
 180
 181         /* End the heap scan */
 182         gc_off = false;
 183 }
 184
 185 /* Set the XT fields now that the heap has been compacted */
 186 void fixup_object_xts(void)
 187 {
 188         begin_scan();
 189
 190         CELL obj;
 191
 192         while((obj = next_object()) != F)
 193         {
 194                 if(type_of(obj) == WORD_TYPE)
 195                 {
 196                         F_WORD *word = untag_object(obj);
 197                         update_word_xt(word);
 198                 }
 199                 else if(type_of(obj) == QUOTATION_TYPE)
 200                 {
 201                         F_QUOTATION *quot = untag_object(obj);
 202
 203                         if(quot->compiledp != F)
 204                                 set_quot_xt(quot,quot->code);
 205                 }
 206         }
 207
 208         /* End the heap scan */
 209         gc_off = false;
 210 }
 211
 212 /* Move all free space to the end of the code heap. This is not very efficient,
 213 since it makes several passes over the code and data heaps, but we only ever
 214 do this before saving a deployed image and exiting, so performaance is not
 215 critical here */
 216 void compact_code_heap(void)
 217 {
 218         /* Free all unreachable code blocks */
 219         gc();
 220
 221         /* Figure out where the code heap blocks are going to end up */
 222         CELL size = compute_heap_forwarding(&code_heap);
 223
 224         /* Update word and quotation code pointers */
 225         forward_object_xts();
 226
 227         /* Actually perform the compaction */
 228         compact_heap(&code_heap);
 229
 230         /* Update word and quotation XTs */
 231         fixup_object_xts();
 232
 233         /* Now update the free list; there will be a single free block at
 234         the end */
 235         build_free_list(&code_heap,size);
 236 }