/* Set the XT fields now that the heap has been compacted */
void factor_vm::fixup_object_xts()
{
begin_scan();
cell obj;
while((obj = next_object()) != F)
{
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
update_word_xt(obj);
break;
case QUOTATION_TYPE:
{
quotation *quot = untag<quotation>(obj);
if(quot->code)
set_quot_xt(quot,quot->code);
break;
}
default:
break;
}
}
end_scan();
}
/* 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);
}
/* 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 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);
}
/* Allocates memory */
void factor_vm::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();
gc_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
for(i = 0; i < length; i++)
{
tagged<word> word(array_nth(words.untagged(),i));
if(profiling)
word->counter = tag_fixnum(0);
update_word_xt(word.value());
}
update_code_heap_words();
}
void factor_vm::primitive_modify_code_heap()
{
gc_root<array> alist(dpop(),this);
cell count = array_capacity(alist.untagged());
if(count == 0)
return;
cell i;
for(i = 0; i < count; i++)
{
gc_root<array> pair(array_nth(alist.untagged(),i),this);
gc_root<word> word(array_nth(pair.untagged(),0),this);
gc_root<object> data(array_nth(pair.untagged(),1),this);
switch(data.type())
{
case QUOTATION_TYPE:
jit_compile_word(word.value(),data.value(),false);
break;
case ARRAY_TYPE:
{
array *compiled_data = data.as<array>().untagged();
cell owner = array_nth(compiled_data,0);
cell literals = array_nth(compiled_data,1);
cell relocation = array_nth(compiled_data,2);
cell labels = array_nth(compiled_data,3);
cell code = array_nth(compiled_data,4);
code_block *compiled = add_code_block(
WORD_TYPE,
code,
labels,
owner,
relocation,
literals);
word->code = compiled;
}
break;
default:
critical_error("Expected a quotation or an array",data.value());
break;
}
update_word_xt(word.value());
}
update_code_heap_words();
}
void factor_vm::forward_object_xts()
{
begin_scan();
cell obj;
while(to_boolean(obj = next_object()))
{
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
{
word *w = untag<word>(obj);
if(w->code)
w->code = code->forward_code_block(w->code);
if(w->profiling)
w->profiling = code->forward_code_block(w->profiling);
update_word_xt(obj);
}
break;
case QUOTATION_TYPE:
{
quotation *quot = untag<quotation>(obj);
if(quot->code)
{
quot->code = code->forward_code_block(quot->code);
set_quot_xt(quot,quot->code);
}
}
break;
case CALLSTACK_TYPE:
{
callstack *stack = untag<callstack>(obj);
callframe_forwarder forwarder(this);
iterate_callstack_object(stack,forwarder);
}
break;
default:
break;
}
}
end_scan();
}
