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 void primitive_add_compiled_block(void)
 212 {
 213         CELL code_format = to_cell(dpop());
 214         F_VECTOR *code = untag_vector(dpop());
 215         F_VECTOR *words = untag_vector(dpop());
 216         F_VECTOR *literals = untag_vector(dpop());
 217         F_VECTOR *rel = untag_vector(dpop());
 218
 219         /* push the XT of the new word on the stack */
 220         box_unsigned_cell(add_compiled_block(code_format,code,literals,words,rel));
 221 }
 222
 223 void primitive_finalize_compile(void)
 224 {
 225         F_ARRAY *array = untag_array(dpop());
 226
 227         /* set word XT's */
 228         CELL count = untag_fixnum_fast(array->capacity);
 229         CELL i;
 230         for(i = 0; i < count; i++)
 231         {
 232                 F_ARRAY *pair = untag_array(get(AREF(array,i)));
 233                 F_WORD *word = untag_word(get(AREF(pair,0)));
 234                 word->xt = to_cell(get(AREF(pair,1)));
 235                 word->compiledp = T;
 236         }
 237
 238         /* perform relocation */
 239         for(i = 0; i < count; i++)
 240         {
 241                 F_ARRAY *pair = untag_array(get(AREF(array,i)));
 242                 CELL xt = to_cell(get(AREF(pair,1)));
 243                 iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
 244         }
 245 }