314 lines
7.8 KiB
C
314 lines
7.8 KiB
C
#include "factor.h"
|
|
|
|
void undefined_symbol(void)
|
|
{
|
|
general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
|
|
}
|
|
|
|
#define CREF(array,i) ((CELL)(array) + CELLS * (i))
|
|
|
|
INLINE CELL get_literal(CELL literal_start, CELL num)
|
|
{
|
|
return get(CREF(literal_start,num));
|
|
}
|
|
|
|
CELL get_rel_symbol(F_REL *rel, CELL literal_start)
|
|
{
|
|
CELL arg = REL_ARGUMENT(rel);
|
|
F_ARRAY *pair = untag_array(get_literal(literal_start,arg));
|
|
F_STRING *symbol = untag_string(get(AREF(pair,0)));
|
|
CELL library = get(AREF(pair,1));
|
|
DLL *dll = (library == F ? NULL : untag_dll(library));
|
|
|
|
if(dll != NULL && !dll->dll)
|
|
return (CELL)undefined_symbol;
|
|
|
|
CELL sym = (CELL)ffi_dlsym(dll,symbol,false);
|
|
|
|
if(!sym)
|
|
return (CELL)undefined_symbol;
|
|
|
|
return sym;
|
|
}
|
|
|
|
INLINE CELL compute_code_rel(F_REL *rel,
|
|
CELL code_start, CELL literal_start, CELL words_start)
|
|
{
|
|
CELL offset = code_start + rel->offset;
|
|
|
|
switch(REL_TYPE(rel))
|
|
{
|
|
case RT_PRIMITIVE:
|
|
return primitive_to_xt(REL_ARGUMENT(rel));
|
|
case RT_DLSYM:
|
|
return get_rel_symbol(rel,literal_start);
|
|
case RT_HERE:
|
|
return offset;
|
|
case RT_CARDS:
|
|
return cards_offset;
|
|
case RT_LITERAL:
|
|
return CREF(literal_start,REL_ARGUMENT(rel));
|
|
case RT_XT:
|
|
return get(CREF(words_start,REL_ARGUMENT(rel)));
|
|
case RT_LABEL:
|
|
return code_start + REL_ARGUMENT(rel);
|
|
default:
|
|
critical_error("Bad rel type",rel->type);
|
|
return -1;
|
|
}
|
|
}
|
|
|
|
INLINE void reloc_set_2_2(CELL cell, CELL value)
|
|
{
|
|
put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
|
|
put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
|
|
}
|
|
|
|
INLINE void reloc_set_masked(CELL cell, CELL value, CELL mask)
|
|
{
|
|
u32 original = *(u32*)cell;
|
|
original &= ~mask;
|
|
*(u32*)cell = (original | (value & mask));
|
|
}
|
|
|
|
void apply_relocation(F_REL *rel,
|
|
CELL code_start, CELL literal_start, CELL words_start)
|
|
{
|
|
CELL absolute_value;
|
|
CELL relative_value;
|
|
CELL offset = rel->offset + code_start;
|
|
|
|
absolute_value = compute_code_rel(rel,
|
|
code_start,literal_start,words_start);
|
|
relative_value = absolute_value - offset;
|
|
|
|
switch(REL_CLASS(rel))
|
|
{
|
|
case REL_ABSOLUTE_CELL:
|
|
put(offset,absolute_value);
|
|
break;
|
|
case REL_ABSOLUTE:
|
|
*(u32*)offset = absolute_value;
|
|
break;
|
|
case REL_RELATIVE:
|
|
*(u32*)offset = relative_value - sizeof(u32);
|
|
break;
|
|
case REL_ABSOLUTE_2_2:
|
|
reloc_set_2_2(offset,absolute_value);
|
|
break;
|
|
case REL_RELATIVE_2_2:
|
|
reloc_set_2_2(offset,relative_value);
|
|
break;
|
|
case REL_RELATIVE_2:
|
|
reloc_set_masked(offset,relative_value,REL_RELATIVE_2_MASK);
|
|
break;
|
|
case REL_RELATIVE_3:
|
|
reloc_set_masked(offset,relative_value,REL_RELATIVE_3_MASK);
|
|
break;
|
|
default:
|
|
critical_error("Bad rel class",REL_CLASS(rel));
|
|
return;
|
|
}
|
|
}
|
|
|
|
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
|
|
CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
|
|
{
|
|
F_REL *rel = (F_REL *)reloc_start;
|
|
F_REL *rel_end = (F_REL *)literal_start;
|
|
|
|
/* apply relocations */
|
|
while(rel < rel_end)
|
|
apply_relocation(rel++,code_start,literal_start,words_start);
|
|
}
|
|
|
|
void finalize_code_block(F_COMPILED *relocating, CELL code_start,
|
|
CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
|
|
{
|
|
CELL scan;
|
|
|
|
for(scan = words_start; scan < words_end; scan += CELLS)
|
|
put(scan,untag_word(get(scan))->xt);
|
|
|
|
relocating->finalized = true;
|
|
|
|
relocate_code_block(relocating,code_start,reloc_start,
|
|
literal_start,words_start,words_end);
|
|
|
|
flush_icache(code_start,reloc_start - code_start);
|
|
}
|
|
|
|
void deposit_integers(CELL here, F_VECTOR *vector, CELL format)
|
|
{
|
|
CELL count = untag_fixnum_fast(vector->top);
|
|
F_ARRAY *array = untag_array_fast(vector->array);
|
|
CELL i;
|
|
|
|
if(format == 1)
|
|
{
|
|
for(i = 0; i < count; i++)
|
|
cput(here + i,to_fixnum(get(AREF(array,i))));
|
|
}
|
|
else if(format == CELLS)
|
|
{
|
|
for(i = 0; i < count; i++)
|
|
put(CREF(here,i),to_fixnum(get(AREF(array,i))));
|
|
}
|
|
else
|
|
critical_error("Bad format param to deposit_vector()",format);
|
|
}
|
|
|
|
void deposit_objects(CELL here, F_VECTOR *vector, CELL literal_length)
|
|
{
|
|
F_ARRAY *array = untag_array_fast(vector->array);
|
|
memcpy((void*)here,array + 1,literal_length);
|
|
}
|
|
|
|
CELL add_compiled_block(CELL code_format, F_VECTOR *code,
|
|
F_VECTOR *literals, F_VECTOR *words, F_VECTOR *rel)
|
|
{
|
|
CELL code_length = align8(untag_fixnum_fast(code->top) * code_format);
|
|
CELL rel_length = untag_fixnum_fast(rel->top) * CELLS;
|
|
CELL literal_length = untag_fixnum_fast(literals->top) * CELLS;
|
|
CELL words_length = untag_fixnum_fast(words->top) * CELLS;
|
|
|
|
CELL total_length = sizeof(F_COMPILED) + code_length + rel_length
|
|
+ literal_length + words_length;
|
|
|
|
CELL start = heap_allot(&compiling,total_length);
|
|
CELL here = start;
|
|
|
|
/* compiled header */
|
|
F_COMPILED header;
|
|
header.code_length = code_length;
|
|
header.reloc_length = rel_length;
|
|
header.literal_length = literal_length;
|
|
header.words_length = words_length;
|
|
header.finalized = false;
|
|
|
|
memcpy((void*)here,&header,sizeof(F_COMPILED));
|
|
here += sizeof(F_COMPILED);
|
|
|
|
/* code */
|
|
deposit_integers(here,code,code_format);
|
|
here += code_length;
|
|
|
|
/* relation info */
|
|
deposit_integers(here,rel,CELLS);
|
|
here += rel_length;
|
|
|
|
/* literals */
|
|
deposit_objects(here,literals,literal_length);
|
|
here += literal_length;
|
|
|
|
/* words */
|
|
deposit_objects(here,words,words_length);
|
|
here += words_length;
|
|
|
|
return start + sizeof(F_COMPILED);
|
|
}
|
|
|
|
#define FROB \
|
|
CELL code_format = to_cell(get(ds)); \
|
|
F_VECTOR *code = untag_vector(get(ds - CELLS)); \
|
|
F_VECTOR *words = untag_vector(get(ds - CELLS * 2)); \
|
|
F_VECTOR *literals = untag_vector(get(ds - CELLS * 3)); \
|
|
F_VECTOR *rel = untag_vector(get(ds - CELLS * 4)); \
|
|
CELL code_length = align8(untag_fixnum_fast(code->top) * code_format); \
|
|
CELL rel_length = untag_fixnum_fast(rel->top) * CELLS; \
|
|
CELL literal_length = untag_fixnum_fast(literals->top) * CELLS; \
|
|
CELL words_length = untag_fixnum_fast(words->top) * CELLS;
|
|
|
|
void primitive_add_compiled_block(void)
|
|
{
|
|
CELL start;
|
|
|
|
{
|
|
/* read parameters from stack, leaving them on the stack */
|
|
FROB
|
|
|
|
/* try allocating a new code block */
|
|
CELL total_length = sizeof(F_COMPILED) + code_length
|
|
+ rel_length + literal_length + words_length;
|
|
|
|
start = heap_allot(&compiling,total_length);
|
|
|
|
/* if allocation failed, do a code GC */
|
|
if(start == 0)
|
|
{
|
|
garbage_collection(TENURED,true);
|
|
start = heap_allot(&compiling,total_length);
|
|
|
|
/* insufficient room even after code GC, give up */
|
|
if(start == 0)
|
|
critical_error("code heap exhausted",0);
|
|
}
|
|
}
|
|
|
|
/* we have to read the parameters again, since we may have called
|
|
code GC in which case the data heap semi-spaces will have switched */
|
|
FROB
|
|
|
|
/* now we can pop the parameters from the stack */
|
|
ds -= CELLS * 5;
|
|
|
|
/* begin depositing the code block's contents */
|
|
CELL here = start;
|
|
|
|
/* compiled header */
|
|
F_COMPILED header;
|
|
header.code_length = code_length;
|
|
header.reloc_length = rel_length;
|
|
header.literal_length = literal_length;
|
|
header.words_length = words_length;
|
|
header.finalized = false;
|
|
|
|
memcpy((void*)here,&header,sizeof(F_COMPILED));
|
|
here += sizeof(F_COMPILED);
|
|
|
|
/* code */
|
|
deposit_integers(here,code,code_format);
|
|
here += code_length;
|
|
|
|
/* relation info */
|
|
deposit_integers(here,rel,CELLS);
|
|
here += rel_length;
|
|
|
|
/* literals */
|
|
deposit_objects(here,literals,literal_length);
|
|
here += literal_length;
|
|
|
|
/* words */
|
|
deposit_objects(here,words,words_length);
|
|
here += words_length;
|
|
|
|
/* push the XT of the new word on the stack */
|
|
box_unsigned_cell(start + sizeof(F_COMPILED));
|
|
}
|
|
|
|
#undef FROB
|
|
|
|
void primitive_finalize_compile(void)
|
|
{
|
|
F_ARRAY *array = untag_array(dpop());
|
|
|
|
/* set word XT's */
|
|
CELL count = untag_fixnum_fast(array->capacity);
|
|
CELL i;
|
|
for(i = 0; i < count; i++)
|
|
{
|
|
F_ARRAY *pair = untag_array(get(AREF(array,i)));
|
|
F_WORD *word = untag_word(get(AREF(pair,0)));
|
|
word->xt = to_cell(get(AREF(pair,1)));
|
|
word->compiledp = T;
|
|
}
|
|
|
|
/* perform relocation */
|
|
for(i = 0; i < count; i++)
|
|
{
|
|
F_ARRAY *pair = untag_array(get(AREF(array,i)));
|
|
CELL xt = to_cell(get(AREF(pair,1)));
|
|
iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
|
|
}
|
|
}
|