2009-05-02 05:04:19 -04:00
|
|
|
#include "master.hpp"
|
|
|
|
|
2009-05-04 02:46:13 -04:00
|
|
|
namespace factor
|
|
|
|
{
|
|
|
|
|
2009-05-02 05:04:19 -04:00
|
|
|
/* Allocate a code heap during startup */
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::init_code_heap(cell size)
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
new_heap(&code,size);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
bool factor_vm::in_code_heap_p(cell ptr)
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
return (ptr >= code.seg->start && ptr <= code.seg->end);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-08-17 16:37:09 -04:00
|
|
|
gc_root<word> word(word_,this);
|
|
|
|
gc_root<quotation> def(def_,this);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
2009-05-02 10:19:09 -04:00
|
|
|
jit_compile(def.value(),relocate);
|
|
|
|
|
|
|
|
word->code = def->code;
|
2009-05-02 05:04:19 -04:00
|
|
|
|
2009-05-06 20:22:22 -04:00
|
|
|
if(word->pic_def != F) jit_compile(word->pic_def,relocate);
|
|
|
|
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Apply a function to every code block */
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::iterate_code_heap(code_heap_iterator iter)
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
heap_block *scan = first_block(&code);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
while(scan)
|
|
|
|
{
|
|
|
|
if(scan->status != B_FREE)
|
2009-08-17 16:37:13 -04:00
|
|
|
iter((code_block *)scan,this);
|
2009-05-04 05:50:24 -04:00
|
|
|
scan = next_block(&code,scan);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Copy literals referenced from all code blocks to newspace. Only for
|
|
|
|
aging and nursery collections */
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::copy_code_heap_roots()
|
2009-08-17 16:37:08 -04:00
|
|
|
{
|
|
|
|
iterate_code_heap(factor::copy_literal_references);
|
|
|
|
}
|
|
|
|
|
2009-05-02 05:04:19 -04:00
|
|
|
/* Update pointers to words referenced from all code blocks. Only after
|
|
|
|
defining a new word. */
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::update_code_heap_words()
|
2009-08-17 16:37:08 -04:00
|
|
|
{
|
|
|
|
iterate_code_heap(factor::update_word_references);
|
|
|
|
}
|
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
inline void factor_vm::primitive_modify_code_heap()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-08-17 16:37:09 -04:00
|
|
|
gc_root<array> alist(dpop(),this);
|
2009-05-02 10:19:09 -04:00
|
|
|
|
2009-05-04 05:50:24 -04:00
|
|
|
cell count = array_capacity(alist.untagged());
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
if(count == 0)
|
|
|
|
return;
|
|
|
|
|
2009-05-04 05:50:24 -04:00
|
|
|
cell i;
|
2009-05-02 05:04:19 -04:00
|
|
|
for(i = 0; i < count; i++)
|
|
|
|
{
|
2009-08-17 16:37:09 -04:00
|
|
|
gc_root<array> pair(array_nth(alist.untagged(),i),this);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
2009-08-17 16:37:09 -04:00
|
|
|
gc_root<word> word(array_nth(pair.untagged(),0),this);
|
|
|
|
gc_root<object> data(array_nth(pair.untagged(),1),this);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
2009-05-02 10:19:09 -04:00
|
|
|
switch(data.type())
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-02 10:19:09 -04:00
|
|
|
case QUOTATION_TYPE:
|
|
|
|
jit_compile_word(word.value(),data.value(),false);
|
|
|
|
break;
|
|
|
|
case ARRAY_TYPE:
|
2009-05-04 08:00:06 -04:00
|
|
|
{
|
|
|
|
array *compiled_data = data.as<array>().untagged();
|
|
|
|
cell literals = array_nth(compiled_data,0);
|
|
|
|
cell relocation = array_nth(compiled_data,1);
|
|
|
|
cell labels = array_nth(compiled_data,2);
|
|
|
|
cell code = array_nth(compiled_data,3);
|
|
|
|
|
|
|
|
code_block *compiled = add_code_block(
|
|
|
|
WORD_TYPE,
|
|
|
|
code,
|
|
|
|
labels,
|
|
|
|
relocation,
|
|
|
|
literals);
|
|
|
|
|
|
|
|
word->code = compiled;
|
|
|
|
}
|
2009-05-02 10:19:09 -04:00
|
|
|
break;
|
|
|
|
default:
|
|
|
|
critical_error("Expected a quotation or an array",data.value());
|
|
|
|
break;
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-05-02 10:19:09 -04:00
|
|
|
update_word_xt(word.value());
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
update_code_heap_words();
|
|
|
|
}
|
|
|
|
|
2009-09-25 15:43:01 -04:00
|
|
|
PRIMITIVE_FORWARD(modify_code_heap)
|
2009-08-17 16:37:08 -04:00
|
|
|
|
2009-05-02 05:04:19 -04:00
|
|
|
/* Push the free space and total size of the code heap */
|
2009-09-23 14:05:46 -04:00
|
|
|
inline void factor_vm::primitive_code_room()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
cell used, total_free, max_free;
|
|
|
|
heap_usage(&code,&used,&total_free,&max_free);
|
|
|
|
dpush(tag_fixnum(code.seg->size / 1024));
|
2009-05-02 05:04:19 -04:00
|
|
|
dpush(tag_fixnum(used / 1024));
|
|
|
|
dpush(tag_fixnum(total_free / 1024));
|
|
|
|
dpush(tag_fixnum(max_free / 1024));
|
|
|
|
}
|
|
|
|
|
2009-09-25 15:43:01 -04:00
|
|
|
PRIMITIVE_FORWARD(code_room)
|
2009-08-17 16:37:08 -04:00
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
code_block *factor_vm::forward_xt(code_block *compiled)
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-05 12:07:20 -04:00
|
|
|
return (code_block *)forwarding[compiled];
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::forward_frame_xt(stack_frame *frame)
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
cell offset = (cell)FRAME_RETURN_ADDRESS(frame) - (cell)frame_code(frame);
|
|
|
|
code_block *forwarded = forward_xt(frame_code(frame));
|
|
|
|
frame->xt = forwarded->xt();
|
|
|
|
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
void forward_frame_xt(stack_frame *frame,factor_vm *myvm)
|
2009-08-17 16:37:08 -04:00
|
|
|
{
|
2009-08-17 16:37:14 -04:00
|
|
|
return myvm->forward_frame_xt(frame);
|
2009-08-17 16:37:08 -04:00
|
|
|
}
|
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::forward_object_xts()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
|
|
|
begin_scan();
|
|
|
|
|
2009-05-04 05:50:24 -04:00
|
|
|
cell obj;
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
while((obj = next_object()) != F)
|
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
switch(tagged<object>(obj).type())
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-02 21:47:29 -04:00
|
|
|
case WORD_TYPE:
|
2009-05-04 08:00:06 -04:00
|
|
|
{
|
|
|
|
word *w = untag<word>(obj);
|
|
|
|
|
|
|
|
if(w->code)
|
|
|
|
w->code = forward_xt(w->code);
|
|
|
|
if(w->profiling)
|
|
|
|
w->profiling = forward_xt(w->profiling);
|
|
|
|
}
|
2009-05-02 21:47:29 -04:00
|
|
|
break;
|
|
|
|
case QUOTATION_TYPE:
|
2009-05-04 08:00:06 -04:00
|
|
|
{
|
|
|
|
quotation *quot = untag<quotation>(obj);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
2009-05-12 04:09:15 -04:00
|
|
|
if(quot->code)
|
2009-05-04 08:00:06 -04:00
|
|
|
quot->code = forward_xt(quot->code);
|
|
|
|
}
|
2009-05-02 21:47:29 -04:00
|
|
|
break;
|
|
|
|
case CALLSTACK_TYPE:
|
2009-05-04 08:00:06 -04:00
|
|
|
{
|
|
|
|
callstack *stack = untag<callstack>(obj);
|
2009-08-17 16:37:08 -04:00
|
|
|
iterate_callstack_object(stack,factor::forward_frame_xt);
|
2009-05-04 08:00:06 -04:00
|
|
|
}
|
2009-05-02 21:47:29 -04:00
|
|
|
break;
|
|
|
|
default:
|
|
|
|
break;
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2009-05-13 01:58:54 -04:00
|
|
|
end_scan();
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Set the XT fields now that the heap has been compacted */
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::fixup_object_xts()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
|
|
|
begin_scan();
|
|
|
|
|
2009-05-04 05:50:24 -04:00
|
|
|
cell obj;
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
while((obj = next_object()) != F)
|
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
switch(tagged<object>(obj).type())
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-04 02:00:30 -04:00
|
|
|
case WORD_TYPE:
|
|
|
|
update_word_xt(obj);
|
|
|
|
break;
|
|
|
|
case QUOTATION_TYPE:
|
2009-05-04 08:00:06 -04:00
|
|
|
{
|
|
|
|
quotation *quot = untag<quotation>(obj);
|
2009-05-12 04:09:15 -04:00
|
|
|
if(quot->code)
|
2009-05-04 08:00:06 -04:00
|
|
|
set_quot_xt(quot,quot->code);
|
|
|
|
break;
|
|
|
|
}
|
2009-05-04 02:00:30 -04:00
|
|
|
default:
|
|
|
|
break;
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2009-05-13 01:58:54 -04:00
|
|
|
end_scan();
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Move all free space to the end of the code heap. This is not very efficient,
|
|
|
|
since it makes several passes over the code and data heaps, but we only ever
|
|
|
|
do this before saving a deployed image and exiting, so performaance is not
|
|
|
|
critical here */
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::compact_code_heap()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
|
|
|
/* Free all unreachable code blocks */
|
|
|
|
gc();
|
|
|
|
|
|
|
|
/* Figure out where the code heap blocks are going to end up */
|
2009-05-05 12:07:20 -04:00
|
|
|
cell size = compute_heap_forwarding(&code, forwarding);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
/* Update word and quotation code pointers */
|
|
|
|
forward_object_xts();
|
|
|
|
|
|
|
|
/* Actually perform the compaction */
|
2009-05-05 12:07:20 -04:00
|
|
|
compact_heap(&code,forwarding);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
/* Update word and quotation XTs */
|
|
|
|
fixup_object_xts();
|
|
|
|
|
|
|
|
/* Now update the free list; there will be a single free block at
|
|
|
|
the end */
|
2009-05-04 05:50:24 -04:00
|
|
|
build_free_list(&code,size);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
2009-05-04 02:46:13 -04:00
|
|
|
|
|
|
|
}
|