/* Set the XT fields now that the heap has been compacted */ void fixup_object_xts(void) { begin_scan(); CELL obj; while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) { F_WORD *word = untag_object(obj); update_word_xt(word); } else if(type_of(obj) == QUOTATION_TYPE) { F_QUOTATION *quot = untag_object(obj); if(quot->compiledp != F) set_quot_xt(quot,quot->code); } } /* End the heap scan */ gc_off = false; }
void forward_object_xts(void) { begin_scan(); CELL obj; while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) { F_WORD *word = untag_object(obj); word->code = forward_xt(word->code); if(word->profiling) word->profiling = forward_xt(word->profiling); } else if(type_of(obj) == QUOTATION_TYPE) { F_QUOTATION *quot = untag_object(obj); if(quot->compiledp != F) quot->code = forward_xt(quot->code); } else if(type_of(obj) == CALLSTACK_TYPE) { F_CALLSTACK *stack = untag_object(obj); iterate_callstack_object(stack,forward_frame_xt); } } /* End the heap scan */ gc_off = false; }
/* Allocates memory */ F_COMPILED *compile_profiling_stub(F_WORD *word) { CELL literals = allot_array_1(tag_object(word)); REGISTER_ROOT(literals); F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]); CELL code = array_nth(quadruple,0); REGISTER_ROOT(code); F_REL rel; rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8); rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format(); F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL)); memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL)); UNREGISTER_ROOT(code); UNREGISTER_ROOT(literals); return add_compiled_block( WORD_TYPE, untag_object(code), NULL, /* no labels */ tag_object(relocation), untag_object(literals)); }
/* Allocates memory */ F_COMPILED *compile_profiling_stub(F_WORD *word) { CELL literals = allot_array_1(tag_object(word)); REGISTER_ROOT(literals); F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]); CELL code = array_nth(quadruple,0); REGISTER_ROOT(code); CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8)); CELL rel_offset = array_nth(quadruple,3) * compiled_code_format(); CELL relocation = allot_array_2(rel_type,rel_offset); UNREGISTER_ROOT(code); UNREGISTER_ROOT(literals); return add_compiled_block( WORD_TYPE, untag_object(code), NULL, /* no labels */ untag_object(relocation), untag_object(literals)); }
/* Do some initialization that we do once only */ void do_stage1_init(void) { print_string("*** Stage 2 early init... "); fflush(stdout); CELL words = find_all_words(); REGISTER_ROOT(words); CELL i; CELL length = array_capacity(untag_object(words)); for(i = 0; i < length; i++) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); default_word_code(word,false); UNREGISTER_UNTAGGED(word); update_word_xt(word); } UNREGISTER_ROOT(words); iterate_code_heap(relocate_code_block); userenv[STAGE2_ENV] = T; print_string("done\n"); fflush(stdout); }
void set_profiling(bool profiling) { if(profiling == profiling_p) return; profiling_p = profiling; /* Push everything to tenured space so that we can heap scan and allocate profiling blocks if necessary */ gc(); CELL words = find_all_words(); REGISTER_ROOT(words); CELL i; CELL length = array_capacity(untag_object(words)); for(i = 0; i < length; i++) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); if(profiling) word->counter = tag_fixnum(0); update_word_xt(word); } UNREGISTER_ROOT(words); /* Update XTs in code heap */ iterate_code_heap(relocate_code_block); }
/* gets the address of an object representing a C pointer */ void *alien_offset(CELL object) { F_ALIEN *alien; F_BYTE_ARRAY *byte_array; switch(type_of(object)) { case BYTE_ARRAY_TYPE: byte_array = untag_object(object); return byte_array + 1; case ALIEN_TYPE: alien = untag_object(object); if(alien->expired != F) general_error(ERROR_EXPIRED,object,F,NULL); return alien_offset(alien->alien) + alien->displacement; case F_TYPE: return NULL; default: type_error(ALIEN_TYPE,object); return NULL; /* can't happen */ } }
F_FIXNUM to_fixnum(CELL tagged) { switch(TAG(tagged)) { case FIXNUM_TYPE: return untag_fixnum_fast(tagged); case BIGNUM_TYPE: return bignum_to_fixnum(untag_object(tagged)); default: type_error(FIXNUM_TYPE,tagged); return -1; /* can't happen */ } }
void strip_compiled_quotations(void) { begin_scan(); CELL obj; while((obj = next_object()) != F) { if(type_of(obj) == QUOTATION_TYPE) { F_QUOTATION *quot = untag_object(obj); quot->compiledp = F; } } gc_off = false; }
/* gets the address of an object representing a C pointer, with the intention of storing the pointer across code which may potentially GC. */ void *pinned_alien_offset(CELL object) { F_ALIEN *alien; switch(type_of(object)) { case ALIEN_TYPE: alien = untag_object(object); if(alien->expired != F) general_error(ERROR_EXPIRED,object,F,NULL); return pinned_alien_offset(alien->alien) + alien->displacement; case F_TYPE: return NULL; default: type_error(ALIEN_TYPE,object); return NULL; /* can't happen */ } }
/* make an alien */ CELL allot_alien(CELL delegate, CELL displacement) { REGISTER_ROOT(delegate); F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN)); UNREGISTER_ROOT(delegate); if(type_of(delegate) == ALIEN_TYPE) { F_ALIEN *delegate_alien = untag_object(delegate); displacement += delegate_alien->displacement; alien->alien = delegate_alien->alien; } else alien->alien = delegate; alien->displacement = displacement; alien->expired = F; return tag_object(alien); }
/* Copy all literals referenced from a code block to newspace */ void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start) { if(collecting_gen >= compiled->last_scan) { CELL scan; CELL literal_end = literals_start + compiled->literals_length; if(collecting_accumulation_gen_p()) compiled->last_scan = collecting_gen; else compiled->last_scan = collecting_gen + 1; for(scan = literals_start; scan < literal_end; scan += CELLS) copy_handle((CELL*)scan); if(compiled->relocation != F) { copy_handle(&compiled->relocation); F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); F_REL *rel = (F_REL *)(relocation + 1); F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); while(rel < rel_end) { if(REL_TYPE(rel) == RT_IMMEDIATE) { CELL offset = rel->offset + code_start; F_FIXNUM absolute_value = get(CREF(literals_start,REL_ARGUMENT(rel))); apply_relocation(REL_CLASS(rel),offset,absolute_value); } rel++; } } flush_icache(code_start,literals_start - code_start); } }