vm/compiler.c

   1 #include "factor.h"
   2
   3 void undefined_symbol(void)
   4 {
   5         general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
   6 }
   7
   8 #define CREF(array,i) ((CELL)(array) + CELLS * (i))
   9
  10 INLINE CELL get_literal(CELL literal_start, CELL num)
  11 {
  12         return get(CREF(literal_start,num));
  13 }
  14
  15 CELL get_rel_symbol(F_REL *rel, CELL literal_start)
  16 {
  17         CELL arg = REL_ARGUMENT(rel);
  18         F_ARRAY *pair = untag_array(get_literal(literal_start,arg));
  19         F_STRING *symbol = untag_string(get(AREF(pair,0)));
  20         CELL library = get(AREF(pair,1));
  21         DLL *dll = (library == F ? NULL : untag_dll(library));
  22
  23         if(dll != NULL && !dll->dll)
  24                 return (CELL)undefined_symbol;
  25
  26         CELL sym = (CELL)ffi_dlsym(dll,symbol,false);
  27
  28         if(!sym)
  29                 return (CELL)undefined_symbol;
  30
  31         return sym;
  32 }
  33
  34 INLINE CELL compute_code_rel(F_REL *rel,
  35         CELL code_start, CELL literal_start, CELL words_start)
  36 {
  37         CELL offset = code_start + rel->offset;
  38
  39         switch(REL_TYPE(rel))
  40         {
  41         case RT_PRIMITIVE:
  42                 return primitive_to_xt(REL_ARGUMENT(rel));
  43         case RT_DLSYM:
  44                 return get_rel_symbol(rel,literal_start);
  45         case RT_HERE:
  46                 return offset;
  47         case RT_CARDS:
  48                 return cards_offset;
  49         case RT_LITERAL:
  50                 return CREF(literal_start,REL_ARGUMENT(rel));
  51         case RT_XT:
  52                 return get(CREF(words_start,REL_ARGUMENT(rel)));
  53         case RT_LABEL:
  54                 return code_start + REL_ARGUMENT(rel);
  55         default:
  56                 critical_error("Bad rel type",rel->type);
  57                 return -1;
  58         }
  59 }
  60
  61 INLINE void reloc_set_2_2(CELL cell, CELL value)
  62 {
  63         put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
  64         put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
  65 }
  66
  67 INLINE void reloc_set_masked(CELL cell, CELL value, CELL mask)
  68 {
  69         u32 original = *(u32*)cell;
  70         original &= ~mask;
  71         *(u32*)cell = (original | (value & mask));
  72 }
  73
  74 void apply_relocation(F_REL *rel,
  75         CELL code_start, CELL literal_start, CELL words_start)
  76 {
  77         CELL absolute_value;
  78         CELL relative_value;
  79         CELL offset = rel->offset + code_start;
  80
  81         absolute_value = compute_code_rel(rel,
  82                 code_start,literal_start,words_start);
  83         relative_value = absolute_value - offset;
  84
  85         switch(REL_CLASS(rel))
  86         {
  87         case REL_ABSOLUTE_CELL:
  88                 put(offset,absolute_value);
  89                 break;
  90         case REL_ABSOLUTE:
  91                 *(u32*)offset = absolute_value;
  92                 break;
  93         case REL_RELATIVE:
  94                 *(u32*)offset = relative_value - sizeof(u32);
  95                 break;
  96         case REL_ABSOLUTE_2_2:
  97                 reloc_set_2_2(offset,absolute_value);
  98                 break;
  99         case REL_RELATIVE_2_2:
 100                 reloc_set_2_2(offset,relative_value);
 101                 break;
 102         case REL_RELATIVE_2:
 103                 reloc_set_masked(offset,relative_value,REL_RELATIVE_2_MASK);
 104                 break;
 105         case REL_RELATIVE_3:
 106                 reloc_set_masked(offset,relative_value,REL_RELATIVE_3_MASK);
 107                 break;
 108         default:
 109                 critical_error("Bad rel class",REL_CLASS(rel));
 110                 return;
 111         }
 112 }
 113
 114 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 115         CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
 116 {
 117         F_REL *rel = (F_REL *)reloc_start;
 118         F_REL *rel_end = (F_REL *)literal_start;
 119
 120         /* apply relocations */
 121         while(rel < rel_end)
 122                 apply_relocation(rel++,code_start,literal_start,words_start);
 123 }
 124
 125 void finalize_code_block(F_COMPILED *relocating, CELL code_start,
 126         CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
 127 {
 128         CELL scan;
 129
 130         for(scan = words_start; scan < words_end; scan += CELLS)
 131                 put(scan,untag_word(get(scan))->xt);
 132
 133         relocating->finalized = true;
 134
 135         relocate_code_block(relocating,code_start,reloc_start,
 136                 literal_start,words_start,words_end);
 137
 138         flush_icache(code_start,reloc_start - code_start);
 139 }
 140
 141 void deposit_integers(CELL here, F_VECTOR *vector, CELL format)
 142 {
 143         CELL count = untag_fixnum_fast(vector->top);
 144         F_ARRAY *array = untag_array_fast(vector->array);
 145         CELL i;
 146
 147         if(format == 1)
 148         {
 149                 for(i = 0; i < count; i++)
 150                         cput(here + i,to_fixnum(get(AREF(array,i))));
 151         }
 152         else if(format == CELLS)
 153         {
 154                 for(i = 0; i < count; i++)
 155                         put(CREF(here,i),to_fixnum(get(AREF(array,i))));
 156         }
 157         else
 158                 critical_error("Bad format param to deposit_vector()",format);
 159 }
 160
 161 void deposit_objects(CELL here, F_VECTOR *vector, CELL literal_length)
 162 {
 163         F_ARRAY *array = untag_array_fast(vector->array);
 164         memcpy((void*)here,array + 1,literal_length);
 165 }
 166
 167 CELL add_compiled_block(CELL code_format, F_VECTOR *code,
 168         F_VECTOR *literals, F_VECTOR *words, F_VECTOR *rel)
 169 {
 170         CELL code_length = align8(untag_fixnum_fast(code->top) * code_format);
 171         CELL rel_length = untag_fixnum_fast(rel->top) * CELLS;
 172         CELL literal_length = untag_fixnum_fast(literals->top) * CELLS;
 173         CELL words_length = untag_fixnum_fast(words->top) * CELLS;
 174
 175         CELL total_length = sizeof(F_COMPILED) + code_length + rel_length
 176                 + literal_length + words_length;
 177
 178         CELL start = heap_allot(&compiling,total_length);
 179         CELL here = start;
 180
 181         /* compiled header */
 182         F_COMPILED header;
 183         header.code_length = code_length;
 184         header.reloc_length = rel_length;
 185         header.literal_length = literal_length;
 186         header.words_length = words_length;
 187         header.finalized = false;
 188
 189         memcpy((void*)here,&header,sizeof(F_COMPILED));
 190         here += sizeof(F_COMPILED);
 191
 192         /* code */
 193         deposit_integers(here,code,code_format);
 194         here += code_length;
 195
 196         /* relation info */
 197         deposit_integers(here,rel,CELLS);
 198         here += rel_length;
 199
 200         /* literals */
 201         deposit_objects(here,literals,literal_length);
 202         here += literal_length;
 203
 204         /* words */
 205         deposit_objects(here,words,words_length);
 206         here += words_length;
 207
 208         return start + sizeof(F_COMPILED);
 209 }
 210
 211 #define FROB \
 212         CELL code_format = to_cell(get(ds)); \
 213         F_VECTOR *code = untag_vector(get(ds - CELLS)); \
 214         F_VECTOR *words = untag_vector(get(ds - CELLS * 2)); \
 215         F_VECTOR *literals = untag_vector(get(ds - CELLS * 3)); \
 216         F_VECTOR *rel = untag_vector(get(ds - CELLS * 4)); \
 217         CELL code_length = align8(untag_fixnum_fast(code->top) * code_format); \
 218         CELL rel_length = untag_fixnum_fast(rel->top) * CELLS; \
 219         CELL literal_length = untag_fixnum_fast(literals->top) * CELLS; \
 220         CELL words_length = untag_fixnum_fast(words->top) * CELLS;
 221
 222 void primitive_add_compiled_block(void)
 223 {
 224         CELL start;
 225
 226         {
 227                 /* read parameters from stack, leaving them on the stack */
 228                 FROB
 229
 230                 /* try allocating a new code block */
 231                 CELL total_length = sizeof(F_COMPILED) + code_length
 232                         + rel_length + literal_length + words_length;
 233
 234                 start = heap_allot(&compiling,total_length);
 235
 236                 /* if allocation failed, do a code GC */
 237                 if(start == 0)
 238                 {
 239                         garbage_collection(TENURED,true);
 240                         start = heap_allot(&compiling,total_length);
 241
 242                         /* insufficient room even after code GC, give up */
 243                         if(start == 0)
 244                                 critical_error("code heap exhausted",0);
 245                 }
 246         }
 247
 248         /* we have to read the parameters again, since we may have called
 249         code GC in which case the data heap semi-spaces will have switched */
 250         FROB
 251
 252         /* now we can pop the parameters from the stack */
 253         ds -= CELLS * 5;
 254
 255         /* begin depositing the code block's contents */
 256         CELL here = start;
 257
 258         /* compiled header */
 259         F_COMPILED header;
 260         header.code_length = code_length;
 261         header.reloc_length = rel_length;
 262         header.literal_length = literal_length;
 263         header.words_length = words_length;
 264         header.finalized = false;
 265
 266         memcpy((void*)here,&header,sizeof(F_COMPILED));
 267         here += sizeof(F_COMPILED);
 268
 269         /* code */
 270         deposit_integers(here,code,code_format);
 271         here += code_length;
 272
 273         /* relation info */
 274         deposit_integers(here,rel,CELLS);
 275         here += rel_length;
 276
 277         /* literals */
 278         deposit_objects(here,literals,literal_length);
 279         here += literal_length;
 280
 281         /* words */
 282         deposit_objects(here,words,words_length);
 283         here += words_length;
 284
 285         /* push the XT of the new word on the stack */
 286         box_unsigned_cell(start + sizeof(F_COMPILED));
 287 }
 288
 289 #undef FROB
 290
 291 void primitive_finalize_compile(void)
 292 {
 293         F_ARRAY *array = untag_array(dpop());
 294
 295         /* set word XT's */
 296         CELL count = untag_fixnum_fast(array->capacity);
 297         CELL i;
 298         for(i = 0; i < count; i++)
 299         {
 300                 F_ARRAY *pair = untag_array(get(AREF(array,i)));
 301                 F_WORD *word = untag_word(get(AREF(pair,0)));
 302                 word->xt = to_cell(get(AREF(pair,1)));
 303                 word->compiledp = T;
 304         }
 305
 306         /* perform relocation */
 307         for(i = 0; i < count; i++)
 308         {
 309                 F_ARRAY *pair = untag_array(get(AREF(array,i)));
 310                 CELL xt = to_cell(get(AREF(pair,1)));
 311                 iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
 312         }
 313 }