steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge commit 'origin/master' into emacs

db4
Jose A. Ortega Ruiz 2009-01-25 03:16:24 +01:00
parent 16ca29410b ed1a2855b5
commit b1d0f90567
20 changed files with 796 additions and 787 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
Makefile
View File

@ -25,23 +25,24 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
vm/bignum.o \
vm/callstack.o \
vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \
vm/data_gc.o \
vm/debug.o \
vm/errors.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/math.o \
vm/data_gc.o \
vm/code_gc.o \
vm/primitives.o \
vm/run.o \
vm/callstack.o \
vm/types.o \
vm/profiler.o \
vm/quotations.o \
vm/utilities.o \
vm/errors.o \
vm/profiler.o
vm/run.o \
vm/types.o \
vm/utilities.o
EXE_OBJS = $(PLAF_EXE_OBJS)

17
vm/callstack.c
View File

@ -90,9 +90,9 @@ void primitive_set_callstack(void)
critical_error("Bug in set_callstack()",0);
}
F_COMPILED *frame_code(F_STACK_FRAME *frame)
F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
{
return (F_COMPILED *)frame->xt - 1;
return (F_CODE_BLOCK *)frame->xt - 1;
}
CELL frame_type(F_STACK_FRAME *frame)
@ -102,11 +102,14 @@ CELL frame_type(F_STACK_FRAME *frame)
CELL frame_executing(F_STACK_FRAME *frame)
{
F_COMPILED *compiled = frame_code(frame);
CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start + compiled->code_length;
return get(literal_start);
F_CODE_BLOCK *compiled = frame_code(frame);
if(compiled->literals == F)
return F;
else
{
F_ARRAY *array = untag_object(compiled->literals);
return array_nth(array,0);
}
}
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)

2
vm/callstack.h
View File

@ -8,7 +8,7 @@ F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
F_COMPILED *frame_code(F_STACK_FRAME *frame);
F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame);
CELL frame_executing(F_STACK_FRAME *frame);
CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);

390
vm/code_block.c Normal file
View File

@ -0,0 +1,390 @@
#include "master.h"
void flush_icache_for(F_CODE_BLOCK *compiled)
{
CELL start = (CELL)(compiled + 1);
flush_icache(start,compiled->code_length);
}
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{
if(compiled->relocation != F)
{
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)
{
iter(rel,compiled);
rel++;
}
}
}
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
INLINE void store_address_2_2(CELL cell, CELL value)
{
put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
}
/* Store a value into a bitfield of a PowerPC instruction */
INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
{
/* This is unaccurate but good enough */
F_FIXNUM test = (F_FIXNUM)mask >> 1;
if(value <= -test || value >= test)
critical_error("Value does not fit inside relocation",0);
u32 original = *(u32*)cell;
original &= ~mask;
*(u32*)cell = (original | ((value >> shift) & mask));
}
/* Perform a fixup on a code block */
void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value)
{
F_FIXNUM relative_value = absolute_value - offset;
switch(class)
{
case RC_ABSOLUTE_CELL:
put(offset,absolute_value);
break;
case RC_ABSOLUTE:
*(u32*)offset = absolute_value;
break;
case RC_RELATIVE:
*(u32*)offset = relative_value - sizeof(u32);
break;
case RC_ABSOLUTE_PPC_2_2:
store_address_2_2(offset,absolute_value);
break;
case RC_RELATIVE_PPC_2:
store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
break;
case RC_RELATIVE_PPC_3:
store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
break;
case RC_RELATIVE_ARM_3:
store_address_masked(offset,relative_value - CELLS * 2,
REL_RELATIVE_ARM_3_MASK,2);
break;
case RC_INDIRECT_ARM:
store_address_masked(offset,relative_value - CELLS,
REL_INDIRECT_ARM_MASK,0);
break;
case RC_INDIRECT_ARM_PC:
store_address_masked(offset,relative_value - CELLS * 2,
REL_INDIRECT_ARM_MASK,0);
break;
default:
critical_error("Bad rel class",class);
break;
}
}
void update_literal_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value = array_nth(literals,REL_ARGUMENT(rel));
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
}
/* Update pointers to literals from compiled code. */
void update_literal_references(F_CODE_BLOCK *compiled)
{
iterate_relocations(compiled,update_literal_references_step);
flush_icache_for(compiled);
}
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
void copy_literal_references(F_CODE_BLOCK *compiled)
{
if(collecting_gen >= compiled->last_scan)
{
if(collecting_accumulation_gen_p())
compiled->last_scan = collecting_gen;
else
compiled->last_scan = collecting_gen + 1;
/* initialize chase pointer */
CELL scan = newspace->here;
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
/* do some tracing so that all reachable literals are now
at their final address */
copy_reachable_objects(scan,&newspace->here);
update_literal_references(compiled);
}
}
CELL object_xt(CELL obj)
{
if(type_of(obj) == WORD_TYPE)
return (CELL)untag_word(obj)->xt;
else
return (CELL)untag_quotation(obj)->xt;
}
void update_word_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_XT)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
CELL xt = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
store_address_in_code_block(REL_CLASS(rel),offset,xt);
}
}
/* Relocate new code blocks completely; updating references to literals,
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
void update_word_references(F_CODE_BLOCK *compiled)
{
if(compiled->needs_fixup)
relocate_code_block(compiled);
else
{
iterate_relocations(compiled,update_word_references_step);
flush_icache_for(compiled);
}
}
/* Update references to words. This is done after a new code block
is added to the heap. */
/* Mark all literals referenced from a word XT. Only for tenured
collections */
void mark_code_block(F_CODE_BLOCK *compiled)
{
mark_block(compiled_to_block(compiled));
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
flush_icache_for(compiled);
}
/* References to undefined symbols are patched up to call this function on
image load */
void undefined_symbol(void)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
/* Look up an external library symbol referenced by a compiled code block */
void *get_rel_symbol(F_REL *rel, F_ARRAY *literals)
{
CELL arg = REL_ARGUMENT(rel);
CELL symbol = array_nth(literals,arg);
CELL library = array_nth(literals,arg + 1);
F_DLL *dll = (library == F ? NULL : untag_dll(library));
if(dll != NULL && !dll->dll)
return undefined_symbol;
if(type_of(symbol) == BYTE_ARRAY_TYPE)
{
F_SYMBOL *name = alien_offset(symbol);
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
else if(type_of(symbol) == ARRAY_TYPE)
{
CELL i;
F_ARRAY *names = untag_object(symbol);
for(i = 0; i < array_capacity(names); i++)
{
F_SYMBOL *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
}
return undefined_symbol;
}
/* Compute an address to store at a relocation */
void relocate_code_block_step(F_REL *rel, F_CODE_BLOCK *compiled)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value;
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
absolute_value = (CELL)primitives[REL_ARGUMENT(rel)];
break;
case RT_DLSYM:
absolute_value = (CELL)get_rel_symbol(rel,literals);
break;
case RT_IMMEDIATE:
absolute_value = array_nth(literals,REL_ARGUMENT(rel));
break;
case RT_XT:
absolute_value = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
break;
case RT_HERE:
absolute_value = rel->offset + (CELL)(compiled + 1) + (short)REL_ARGUMENT(rel);
break;
case RT_LABEL:
absolute_value = (CELL)(compiled + 1) + REL_ARGUMENT(rel);
break;
case RT_STACK_CHAIN:
absolute_value = (CELL)&stack_chain;
break;
default:
critical_error("Bad rel type",rel->type);
return; /* Can't happen */
}
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
/* Perform all fixups on a code block */
void relocate_code_block(F_CODE_BLOCK *compiled)
{
compiled->last_scan = NURSERY;
compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
}
/* Fixup labels. This is done at compile time, not image load time */
void fixup_labels(F_ARRAY *labels, CELL code_format, F_CODE_BLOCK *compiled)
{
CELL i;
CELL size = array_capacity(labels);
for(i = 0; i < size; i += 3)
{
CELL class = to_fixnum(array_nth(labels,i));
CELL offset = to_fixnum(array_nth(labels,i + 1));
CELL target = to_fixnum(array_nth(labels,i + 2));
store_address_in_code_block(class,
offset + (CELL)(compiled + 1),
target + (CELL)(compiled + 1));
}
}
/* Write a sequence of integers to memory, with 'format' bytes per integer */
void deposit_integers(CELL here, F_ARRAY *array, CELL format)
{
CELL count = array_capacity(array);
CELL i;
for(i = 0; i < count; i++)
{
F_FIXNUM value = to_fixnum(array_nth(array,i));
if(format == 1)
bput(here + i,value);
else if(format == sizeof(unsigned int))
*(unsigned int *)(here + format * i) = value;
else if(format == sizeof(CELL))
*(CELL *)(here + format * i) = value;
else
critical_error("Bad format in deposit_integers()",format);
}
}
bool stack_traces_p(void)
{
return to_boolean(userenv[STACK_TRACES_ENV]);
}
CELL compiled_code_format(void)
{
return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
}
/* Might GC */
void *allot_code_block(CELL size)
{
void *start = heap_allot(&code_heap,size);
/* If allocation failed, do a code GC */
if(start == NULL)
{
gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
if(start == NULL)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl();
print_string("Total free space: "); print_cell(total_free); nl();
print_string("Largest free block: "); print_cell(max_free); nl();
fatal_error("Out of memory in add-compiled-block",0);
}
}
return start;
}
/* Might GC */
F_CODE_BLOCK *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
REGISTER_ROOT(literals);
REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
F_CODE_BLOCK *compiled = allot_code_block(sizeof(F_CODE_BLOCK) + code_length);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(literals);
/* compiled header */
compiled->type = type;
compiled->last_scan = NURSERY;
compiled->needs_fixup = true;
compiled->code_length = code_length;
compiled->literals = literals;
compiled->relocation = relocation;
/* code */
deposit_integers((CELL)(compiled + 1),code,code_format);
/* fixup labels */
if(labels) fixup_labels(labels,code_format,compiled);
/* next time we do a minor GC, we have to scan the code heap for
literals */
last_code_heap_scan = NURSERY;
return compiled;
}

87
vm/code_block.h Normal file
View File

@ -0,0 +1,87 @@
typedef enum {
/* arg is a primitive number */
RT_PRIMITIVE,
/* arg is a literal table index, holding an array pair (symbol/dll) */
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a compiled word reference */
RT_XT,
/* current offset */
RT_HERE,
/* a local label */
RT_LABEL,
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
RT_STACK_CHAIN
} F_RELTYPE;
typedef enum {
/* absolute address in a 64-bit location */
RC_ABSOLUTE_CELL,
/* absolute address in a 32-bit location */
RC_ABSOLUTE,
/* relative address in a 32-bit location */
RC_RELATIVE,
/* relative address in a PowerPC LIS/ORI sequence */
RC_ABSOLUTE_PPC_2_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */
RC_RELATIVE_PPC_2,
/* relative address in a PowerPC B/BL instruction */
RC_RELATIVE_PPC_3,
/* relative address in an ARM B/BL instruction */
RC_RELATIVE_ARM_3,
/* pointer to address in an ARM LDR/STR instruction */
RC_INDIRECT_ARM,
/* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
RC_INDIRECT_ARM_PC
} F_RELCLASS;
#define REL_RELATIVE_PPC_2_MASK 0xfffc
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0x000000ff)
#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
/* code relocation consists of a table of entries for each fixup */
typedef struct {
unsigned int type;
unsigned int offset;
} F_REL;
void flush_icache_for(F_CODE_BLOCK *compiled);
typedef void (*RELOCATION_ITERATOR)(F_REL *rel, F_CODE_BLOCK *compiled);
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value);
void relocate_code_block(F_CODE_BLOCK *compiled);
void update_literal_references(F_CODE_BLOCK *compiled);
void copy_literal_references(F_CODE_BLOCK *compiled);
void update_word_references(F_CODE_BLOCK *compiled);
void mark_code_block(F_CODE_BLOCK *compiled);
void relocate_code_block(F_CODE_BLOCK *relocating);
CELL compiled_code_format(void);
bool stack_traces_p(void);
F_CODE_BLOCK *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals);

266
vm/code_gc.c
View File

@ -11,18 +11,6 @@ void new_heap(F_HEAP *heap, CELL size)
heap->free_list = NULL;
}
/* Allocate a code heap during startup */
void init_code_heap(CELL size)
{
new_heap(&code_heap,size);
}
bool in_code_heap_p(CELL ptr)
{
return (ptr >= code_heap.segment->start
&& ptr <= code_heap.segment->end);
}
/* If there is no previous block, next_free becomes the head of the free list,
else its linked in */
INLINE void update_free_list(F_HEAP *heap, F_BLOCK *prev, F_BLOCK *next_free)
@ -92,7 +80,7 @@ void build_free_list(F_HEAP *heap, CELL size)
}
/* Allocate a block of memory from the mark and sweep GC heap */
CELL heap_allot(F_HEAP *heap, CELL size)
void *heap_allot(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
F_BLOCK *scan = heap->free_list;
@ -139,13 +127,29 @@ CELL heap_allot(F_HEAP *heap, CELL size)
/* this is our new block */
scan->status = B_ALLOCATED;
return (CELL)(scan + 1);
return scan + 1;
}
return 0;
return NULL;
}
/* If in the middle of code GC, we have to grow the heap, GC restarts from
void mark_block(F_BLOCK *block)
{
/* If already marked, do nothing */
switch(block->status)
{
case B_MARKED:
return;
case B_ALLOCATED:
block->status = B_MARKED;
break;
default:
critical_error("Marking the wrong block",(CELL)block);
break;
}
}
/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
void unmark_marked(F_HEAP *heap)
{
@ -243,136 +247,6 @@ CELL heap_size(F_HEAP *heap)
return heap->segment->size;
}
/* Apply a function to every code block */
void iterate_code_heap(CODE_HEAP_ITERATOR iter)
{
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
if(scan->status != B_FREE)
iterate_code_heap_step(block_to_compiled(scan),iter);
scan = next_block(&code_heap,scan);
}
}
/* 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);
}
}
/* Copy literals referenced from all code blocks to newspace */
void collect_literals(void)
{
iterate_code_heap(collect_literals_step);
}
/* Mark all XTs and literals referenced from a word XT */
void recursive_mark(F_BLOCK *block)
{
/* If already marked, do nothing */
switch(block->status)
{
case B_MARKED:
return;
case B_ALLOCATED:
block->status = B_MARKED;
break;
default:
critical_error("Marking the wrong block",(CELL)block);
break;
}
F_COMPILED *compiled = block_to_compiled(block);
iterate_code_heap_step(compiled,collect_literals_step);
}
/* Push the free space and total size of the code heap */
void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
CELL size = 0;
F_BLOCK *scan = first_block(heap);
while(scan)
{
char *status;
switch(scan->status)
{
case B_FREE:
status = "free";
break;
case B_ALLOCATED:
size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
status = "invalid";
break;
}
print_cell_hex((CELL)scan); print_string(" ");
print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n");
scan = next_block(heap,scan);
}
print_cell(size); print_string(" bytes of relocation data\n");
}
/* Compute where each block is going to go, after compaction */
CELL compute_heap_forwarding(F_HEAP *heap)
{
@ -395,80 +269,6 @@ CELL compute_heap_forwarding(F_HEAP *heap)
return address - heap->segment->start;
}
F_COMPILED *forward_xt(F_COMPILED *compiled)
{
return block_to_compiled(compiled_to_block(compiled)->forwarding);
}
void forward_frame_xt(F_STACK_FRAME *frame)
{
CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
F_COMPILED *forwarded = forward_xt(frame_code(frame));
frame->xt = (XT)(forwarded + 1);
FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
}
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;
}
/* 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 compact_heap(F_HEAP *heap)
{
F_BLOCK *scan = first_block(heap);
@ -482,29 +282,3 @@ void compact_heap(F_HEAP *heap)
scan = next;
}
}
/* 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 */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
CELL size = compute_heap_forwarding(&code_heap);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
compact_heap(&code_heap);
/* Update word and quotation XTs */
fixup_object_xts();
/* Now update the free list; there will be a single free block at
the end */
build_free_list(&code_heap,size);
}

38
vm/code_gc.h
View File

@ -26,11 +26,14 @@ typedef struct {
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
CELL heap_allot(F_HEAP *heap, CELL size);
void *heap_allot(F_HEAP *heap, CELL size);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
CELL compute_heap_forwarding(F_HEAP *heap);
void compact_heap(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
{
@ -41,29 +44,6 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
return (F_BLOCK *)next;
}
/* compiled code */
F_HEAP code_heap;
typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{
CELL code_start = (CELL)(compiled + 1);
CELL literals_start = code_start + compiled->code_length;
iter(compiled,code_start,literals_start);
}
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
{
return (F_BLOCK *)compiled - 1;
}
INLINE F_COMPILED *block_to_compiled(F_BLOCK *block)
{
return (F_COMPILED *)(block + 1);
}
INLINE F_BLOCK *first_block(F_HEAP *heap)
{
return (F_BLOCK *)heap->segment->start;
@ -73,13 +53,3 @@ INLINE F_BLOCK *last_block(F_HEAP *heap)
{
return (F_BLOCK *)heap->segment->end;
}
void init_code_heap(CELL size);
bool in_code_heap_p(CELL ptr);
void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void collect_literals(void);
void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
void compact_code_heap(void);
void primitive_code_room(void);

476
vm/code_heap.c
View File

@ -1,315 +1,18 @@
#include "master.h"
/* References to undefined symbols are patched up to call this function on
image load */
void undefined_symbol(void)
/* Allocate a code heap during startup */
void init_code_heap(CELL size)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
new_heap(&code_heap,size);
}
INLINE CELL get_literal(CELL literals_start, CELL num)
bool in_code_heap_p(CELL ptr)
{
return get(CREF(literals_start,num));
return (ptr >= code_heap.segment->start
&& ptr <= code_heap.segment->end);
}
/* Look up an external library symbol referenced by a compiled code block */
void *get_rel_symbol(F_REL *rel, CELL literals_start)
{
CELL arg = REL_ARGUMENT(rel);
CELL symbol = get_literal(literals_start,arg);
CELL library = get_literal(literals_start,arg + 1);
F_DLL *dll = (library == F ? NULL : untag_dll(library));
if(dll != NULL && !dll->dll)
return undefined_symbol;
if(type_of(symbol) == BYTE_ARRAY_TYPE)
{
F_SYMBOL *name = alien_offset(symbol);
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
else if(type_of(symbol) == ARRAY_TYPE)
{
CELL i;
F_ARRAY *names = untag_object(symbol);
for(i = 0; i < array_capacity(names); i++)
{
F_SYMBOL *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
}
return undefined_symbol;
}
/* Compute an address to store at a relocation */
INLINE CELL compute_code_rel(F_REL *rel,
CELL code_start, CELL literals_start)
{
CELL obj;
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
return (CELL)primitives[REL_ARGUMENT(rel)];
case RT_DLSYM:
return (CELL)get_rel_symbol(rel,literals_start);
case RT_IMMEDIATE:
return get(CREF(literals_start,REL_ARGUMENT(rel)));
case RT_XT:
obj = get(CREF(literals_start,REL_ARGUMENT(rel)));
if(type_of(obj) == WORD_TYPE)
return (CELL)untag_word(obj)->xt;
else
return (CELL)untag_quotation(obj)->xt;
case RT_HERE:
return rel->offset + code_start + (short)REL_ARGUMENT(rel);
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
case RT_STACK_CHAIN:
return (CELL)&stack_chain;
default:
critical_error("Bad rel type",rel->type);
return -1; /* Can't happen */
}
}
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
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)));
}
/* Store a value into a bitfield of a PowerPC instruction */
INLINE void reloc_set_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
{
/* This is unaccurate but good enough */
F_FIXNUM test = (F_FIXNUM)mask >> 1;
if(value <= -test || value >= test)
critical_error("Value does not fit inside relocation",0);
u32 original = *(u32*)cell;
original &= ~mask;
*(u32*)cell = (original | ((value >> shift) & mask));
}
/* Perform a fixup on a code block */
void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
{
F_FIXNUM relative_value = absolute_value - offset;
switch(class)
{
case RC_ABSOLUTE_CELL:
put(offset,absolute_value);
break;
case RC_ABSOLUTE:
*(u32*)offset = absolute_value;
break;
case RC_RELATIVE:
*(u32*)offset = relative_value - sizeof(u32);
break;
case RC_ABSOLUTE_PPC_2_2:
reloc_set_2_2(offset,absolute_value);
break;
case RC_RELATIVE_PPC_2:
reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
break;
case RC_RELATIVE_PPC_3:
reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
break;
case RC_RELATIVE_ARM_3:
reloc_set_masked(offset,relative_value - CELLS * 2,
REL_RELATIVE_ARM_3_MASK,2);
break;
case RC_INDIRECT_ARM:
reloc_set_masked(offset,relative_value - CELLS,
REL_INDIRECT_ARM_MASK,0);
break;
case RC_INDIRECT_ARM_PC:
reloc_set_masked(offset,relative_value - CELLS * 2,
REL_INDIRECT_ARM_MASK,0);
break;
default:
critical_error("Bad rel class",class);
break;
}
}
/* Perform all fixups on a code block */
void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
compiled->last_scan = NURSERY;
if(compiled->relocation != F)
{
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)
{
CELL offset = rel->offset + code_start;
F_FIXNUM absolute_value = compute_code_rel(
rel,code_start,literals_start);
apply_relocation(REL_CLASS(rel),offset,absolute_value);
rel++;
}
}
flush_icache(code_start,literals_start - code_start);
}
/* Fixup labels. This is done at compile time, not image load time */
void fixup_labels(F_ARRAY *labels, CELL code_format, CELL code_start)
{
CELL i;
CELL size = array_capacity(labels);
for(i = 0; i < size; i += 3)
{
CELL class = to_fixnum(array_nth(labels,i));
CELL offset = to_fixnum(array_nth(labels,i + 1));
CELL target = to_fixnum(array_nth(labels,i + 2));
apply_relocation(class,
offset + code_start,
target + code_start);
}
}
/* Write a sequence of integers to memory, with 'format' bytes per integer */
void deposit_integers(CELL here, F_ARRAY *array, CELL format)
{
CELL count = array_capacity(array);
CELL i;
for(i = 0; i < count; i++)
{
F_FIXNUM value = to_fixnum(array_nth(array,i));
if(format == 1)
bput(here + i,value);
else if(format == sizeof(unsigned int))
*(unsigned int *)(here + format * i) = value;
else if(format == CELLS)
put(CREF(here,i),value);
else
critical_error("Bad format in deposit_integers()",format);
}
}
/* Write a sequence of tagged pointers to memory */
void deposit_objects(CELL here, F_ARRAY *array)
{
memcpy((void*)here,array + 1,array_capacity(array) * CELLS);
}
bool stack_traces_p(void)
{
return to_boolean(userenv[STACK_TRACES_ENV]);
}
CELL compiled_code_format(void)
{
return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
}
CELL allot_code_block(CELL size)
{
CELL start = heap_allot(&code_heap,size);
/* If allocation failed, do a code GC */
if(start == 0)
{
gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
if(start == 0)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl();
print_string("Total free space: "); print_cell(total_free); nl();
print_string("Largest free block: "); print_cell(max_free); nl();
fatal_error("Out of memory in add-compiled-block",0);
}
}
return start;
}
/* Might GC */
F_COMPILED *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
F_ARRAY *literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
CELL literals_length = array_capacity(literals) * CELLS;
REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
REGISTER_UNTAGGED(literals);
CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
UNREGISTER_UNTAGGED(literals);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
UNREGISTER_ROOT(relocation);
/* compiled header */
F_COMPILED *header = (void *)here;
header->type = type;
header->last_scan = NURSERY;
header->code_length = code_length;
header->literals_length = literals_length;
header->relocation = relocation;
here += sizeof(F_COMPILED);
CELL code_start = here;
/* code */
deposit_integers(here,code,code_format);
here += code_length;
/* literals */
deposit_objects(here,literals);
here += literals_length;
/* fixup labels */
if(labels)
fixup_labels(labels,code_format,code_start);
/* next time we do a minor GC, we have to scan the code heap for
literals */
last_code_heap_scan = NURSERY;
return header;
}
void set_word_code(F_WORD *word, F_COMPILED *compiled)
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
{
if(compiled->type != WORD_TYPE)
critical_error("bad param to set_word_xt",(CELL)compiled);
@ -329,12 +32,48 @@ void default_word_code(F_WORD *word, bool relocate)
word->optimizedp = F;
}
/* Apply a function to every code block */
void iterate_code_heap(CODE_HEAP_ITERATOR iter)
{
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
if(scan->status != B_FREE)
iter(block_to_compiled(scan));
scan = next_block(&code_heap,scan);
}
}
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
void copy_code_heap_roots(void)
{
iterate_code_heap(copy_literal_references);
}
/* Update literals referenced from all code blocks. Only for tenured
collections, done at the end. */
void update_code_heap_roots(void)
{
iterate_code_heap(update_literal_references);
}
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
void update_code_heap_words(void)
{
iterate_code_heap(update_word_references);
}
void primitive_modify_code_heap(void)
{
bool rescan_code_heap = to_boolean(dpop());
F_ARRAY *alist = untag_array(dpop());
CELL count = untag_fixnum_fast(alist->capacity);
if(count == 0)
return;
CELL i;
for(i = 0; i < count; i++)
{
@ -364,12 +103,12 @@ void primitive_modify_code_heap(void)
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
F_COMPILED *compiled = add_compiled_block(
F_CODE_BLOCK *compiled = add_compiled_block(
WORD_TYPE,
code,
labels,
relocation,
literals);
tag_object(literals));
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
@ -382,21 +121,116 @@ void primitive_modify_code_heap(void)
UNREGISTER_UNTAGGED(alist);
}
/* If there were any interned words in the set, we relocate all XT
references in the entire code heap. But if all the words are
uninterned, it is impossible that other words reference them, so we
only have to relocate the new words. This makes compile-call much
more efficient */
if(rescan_code_heap)
iterate_code_heap(relocate_code_block);
else
{
for(i = 0; i < count; i++)
{
F_ARRAY *pair = untag_array(array_nth(alist,i));
F_WORD *word = untag_word(array_nth(pair,0));
update_code_heap_words();
}
iterate_code_heap_step(word->code,relocate_code_block);
/* Push the free space and total size of the code heap */
void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
{
return block_to_compiled(compiled_to_block(compiled)->forwarding);
}
void forward_frame_xt(F_STACK_FRAME *frame)
{
CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame));
frame->xt = (XT)(forwarded + 1);
FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
}
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;
}
/* 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;
}
/* 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 */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
CELL size = compute_heap_forwarding(&code_heap);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
compact_heap(&code_heap);
/* Update word and quotation XTs */
fixup_object_xts();
/* Now update the free list; there will be a single free block at
the end */
build_free_list(&code_heap,size);
}

90
vm/code_heap.h
View File

@ -1,78 +1,34 @@
typedef enum {
/* arg is a primitive number */
RT_PRIMITIVE,
/* arg is a literal table index, holding an array pair (symbol/dll) */
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a compiled word reference */
RT_XT,
/* current offset */
RT_HERE,
/* a local label */
RT_LABEL,
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
RT_STACK_CHAIN
} F_RELTYPE;
/* compiled code */
F_HEAP code_heap;
typedef enum {
/* absolute address in a 64-bit location */
RC_ABSOLUTE_CELL,
/* absolute address in a 32-bit location */
RC_ABSOLUTE,
/* relative address in a 32-bit location */
RC_RELATIVE,
/* relative address in a PowerPC LIS/ORI sequence */
RC_ABSOLUTE_PPC_2_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */
RC_RELATIVE_PPC_2,
/* relative address in a PowerPC B/BL instruction */
RC_RELATIVE_PPC_3,
/* relative address in an ARM B/BL instruction */
RC_RELATIVE_ARM_3,
/* pointer to address in an ARM LDR/STR instruction */
RC_INDIRECT_ARM,
/* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
RC_INDIRECT_ARM_PC
} F_RELCLASS;
INLINE F_BLOCK *compiled_to_block(F_CODE_BLOCK *compiled)
{
return (F_BLOCK *)compiled - 1;
}
#define REL_RELATIVE_PPC_2_MASK 0xfffc
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
INLINE F_CODE_BLOCK *block_to_compiled(F_BLOCK *block)
{
return (F_CODE_BLOCK *)(block + 1);
}
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0x000000ff)
#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
void init_code_heap(CELL size);
/* code relocation consists of a table of entries for each fixup */
typedef struct {
unsigned int type;
unsigned int offset;
} F_REL;
#define CREF(array,i) ((CELL)(array) + CELLS * (i))
void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value);
void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
bool in_code_heap_p(CELL ptr);
void default_word_code(F_WORD *word, bool relocate);
void set_word_code(F_WORD *word, F_COMPILED *compiled);
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled);
F_COMPILED *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
F_ARRAY *literals);
typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
CELL compiled_code_format(void);
bool stack_traces_p(void);
void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void copy_code_heap_roots(void);
void update_code_heap_roots(void);
void primitive_modify_code_heap(void);
void primitive_code_room(void);
void compact_code_heap(void);

92
vm/data_gc.c
View File

@ -296,7 +296,7 @@ void primitive_end_scan(void)
}
/* Scan all the objects in the card */
void collect_card(F_CARD *ptr, CELL gen, CELL here)
void copy_card(F_CARD *ptr, CELL gen, CELL here)
{
CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
@ -304,12 +304,12 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here)
if(here < card_end)
card_end = here;
collect_next_loop(card_scan,&card_end);
copy_reachable_objects(card_scan,&card_end);
cards_scanned++;
}
void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
{
F_CARD *first_card = DECK_TO_CARD(deck);
F_CARD *last_card = DECK_TO_CARD(deck + 1);
@ -330,7 +330,7 @@ void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
{
if(ptr[card] & mask)
{
collect_card(&ptr[card],gen,here);
copy_card(&ptr[card],gen,here);
ptr[card] &= ~unmask;
}
}
@ -341,7 +341,7 @@ void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
}
/* Copy all newspace objects referenced from marked cards to the destination */
void collect_gen_cards(CELL gen)
void copy_gen_cards(CELL gen)
{
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
@ -365,7 +365,7 @@ void collect_gen_cards(CELL gen)
unmask = CARD_MARK_MASK;
else
{
critical_error("bug in collect_gen_cards",gen);
critical_error("bug in copy_gen_cards",gen);
return;
}
}
@ -390,7 +390,7 @@ void collect_gen_cards(CELL gen)
}
else
{
critical_error("bug in collect_gen_cards",gen);
critical_error("bug in copy_gen_cards",gen);
return;
}
@ -400,7 +400,7 @@ void collect_gen_cards(CELL gen)
{
if(*ptr & mask)
{
collect_card_deck(ptr,gen,mask,unmask);
copy_card_deck(ptr,gen,mask,unmask);
*ptr &= ~unmask;
}
}
@ -408,15 +408,15 @@ void collect_gen_cards(CELL gen)
/* Scan cards in all generations older than the one being collected, copying
old->new references */
void collect_cards(void)
void copy_cards(void)
{
int i;
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
collect_gen_cards(i);
copy_gen_cards(i);
}
/* Copy all tagged pointers in a range of memory */
void collect_stack(F_SEGMENT *region, CELL top)
void copy_stack_elements(F_SEGMENT *region, CELL top)
{
CELL ptr = region->start;
@ -424,25 +424,23 @@ void collect_stack(F_SEGMENT *region, CELL top)
copy_handle((CELL*)ptr);
}
void collect_stack_frame(F_STACK_FRAME *frame)
void copy_stack_frame_step(F_STACK_FRAME *frame)
{
recursive_mark(compiled_to_block(frame_code(frame)));
mark_code_block(frame_code(frame));
}
/* The base parameter allows us to adjust for a heap-allocated
callstack snapshot */
void collect_callstack(F_CONTEXT *stacks)
void copy_callstack_roots(F_CONTEXT *stacks)
{
if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
iterate_callstack(top,bottom,collect_stack_frame);
iterate_callstack(top,bottom,copy_stack_frame_step);
}
}
void collect_gc_locals(void)
void copy_registered_locals(void)
{
CELL ptr = gc_locals_region->start;
@ -452,28 +450,28 @@ void collect_gc_locals(void)
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered with REGISTER_ROOT */
void collect_roots(void)
void copy_roots(void)
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
collect_gc_locals();
collect_stack(extra_roots_region,extra_roots);
copy_registered_locals();
copy_stack_elements(extra_roots_region,extra_roots);
save_stacks();
F_CONTEXT *stacks = stack_chain;
while(stacks)
{
collect_stack(stacks->datastack_region,stacks->datastack);
collect_stack(stacks->retainstack_region,stacks->retainstack);
copy_stack_elements(stacks->datastack_region,stacks->datastack);
copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
copy_handle(&stacks->catchstack_save);
copy_handle(&stacks->current_callback_save);
collect_callstack(stacks);
copy_callstack_roots(stacks);
stacks = stacks->next;
}
@ -610,23 +608,23 @@ void do_code_slots(CELL scan)
{
case WORD_TYPE:
word = (F_WORD *)scan;
recursive_mark(compiled_to_block(word->code));
mark_code_block(word->code);
if(word->profiling)
recursive_mark(compiled_to_block(word->profiling));
mark_code_block(word->profiling);
break;
case QUOTATION_TYPE:
quot = (F_QUOTATION *)scan;
if(quot->compiledp != F)
recursive_mark(compiled_to_block(quot->code));
mark_code_block(quot->code);
break;
case CALLSTACK_TYPE:
stack = (F_CALLSTACK *)scan;
iterate_callstack_object(stack,collect_stack_frame);
iterate_callstack_object(stack,copy_stack_frame_step);
break;
}
}
CELL collect_next_nursery(CELL scan)
CELL copy_next_from_nursery(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
@ -651,7 +649,7 @@ CELL collect_next_nursery(CELL scan)
return scan + untagged_object_size(scan);
}
CELL collect_next_aging(CELL scan)
CELL copy_next_from_aging(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
@ -680,8 +678,7 @@ CELL collect_next_aging(CELL scan)
return scan + untagged_object_size(scan);
}
/* This function is performance-critical */
CELL collect_next_tenured(CELL scan)
CELL copy_next_from_tenured(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
@ -707,22 +704,22 @@ CELL collect_next_tenured(CELL scan)
return scan + untagged_object_size(scan);
}
void collect_next_loop(CELL scan, CELL *end)
void copy_reachable_objects(CELL scan, CELL *end)
{
if(HAVE_NURSERY_P && collecting_gen == NURSERY)
{
while(scan < *end)
scan = collect_next_nursery(scan);
scan = copy_next_from_nursery(scan);
}
else if(HAVE_AGING_P && collecting_gen == AGING)
{
while(scan < *end)
scan = collect_next_aging(scan);
scan = copy_next_from_aging(scan);
}
else if(collecting_gen == TENURED)
{
while(scan < *end)
scan = collect_next_tenured(scan);
scan = copy_next_from_tenured(scan);
}
}
@ -879,25 +876,22 @@ void garbage_collection(CELL gen,
CELL scan = newspace->here;
/* collect objects referenced from stacks and environment */
collect_roots();
copy_roots();
/* collect objects referenced from older generations */
collect_cards();
copy_cards();
/* do some tracing */
copy_reachable_objects(scan,&newspace->here);
/* don't scan code heap unless it has pointers to this
generation or younger */
if(collecting_gen >= last_code_heap_scan)
{
if(collecting_gen != TENURED)
{
/* if we are doing code GC, then we will copy over
literals from any code block which gets marked as live.
if we are not doing code GC, just consider all literals
as roots. */
code_heap_scans++;
code_heap_scans++;
collect_literals();
}
if(collecting_gen == TENURED)
update_code_heap_roots();
else
copy_code_heap_roots();
if(collecting_accumulation_gen_p())
last_code_heap_scan = collecting_gen;
@ -905,8 +899,6 @@ void garbage_collection(CELL gen,
last_code_heap_scan = collecting_gen + 1;
}
collect_next_loop(scan,&newspace->here);
CELL gc_elapsed = (current_micros() - start);
end_gc(gc_elapsed);

3
vm/data_gc.h
View File

@ -126,7 +126,6 @@ INLINE void allot_barrier(CELL address)
}
void clear_cards(CELL from, CELL to);
void collect_cards(void);
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
@ -387,7 +386,7 @@ INLINE void* allot_object(CELL type, CELL a)
return object;
}
void collect_next_loop(CELL scan, CELL *end);
void copy_reachable_objects(CELL scan, CELL *end);
void primitive_gc(void);
void primitive_gc_stats(void);

56
vm/debug.c
View File

@ -308,34 +308,42 @@ void find_data_references(CELL look_for_)
gc_off = false;
}
CELL look_for;
void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
/* Dump all code blocks for debugging */
void dump_code_heap(void)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
CELL size = 0;
for(scan = literals_start; scan < literal_end; scan += CELLS)
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start + compiled->code_length;
CELL obj = get(literal_start);
if(look_for == get(scan))
char *status;
switch(scan->status)
{
print_cell_hex_pad(obj);
print_string(" ");
print_nested_obj(obj,2);
nl();
case B_FREE:
status = "free";
break;
case B_ALLOCATED:
size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
status = "invalid";
break;
}
}
}
void find_code_references(CELL look_for_)
{
look_for = look_for_;
iterate_code_heap(find_code_references_step);
print_cell_hex((CELL)scan); print_string(" ");
print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n");
scan = next_block(&code_heap,scan);
}
print_cell(size); print_string(" bytes of relocation data\n");
}
void factorbug(void)
@ -464,8 +472,6 @@ void factorbug(void)
CELL addr = read_cell_hex();
print_string("Data heap references:\n");
find_data_references(addr);
print_string("Code heap references:\n");
find_code_references(addr);
nl();
}
else if(strcmp(cmd,"words") == 0)
@ -478,7 +484,7 @@ void factorbug(void)
dpush(addr);
}
else if(strcmp(cmd,"code") == 0)
dump_heap(&code_heap);
dump_code_heap();
else
print_string("unknown command\n");
}

11
vm/image.c
View File

@ -311,18 +311,13 @@ void relocate_data()
}
}
void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
void fixup_code_block(F_CODE_BLOCK *compiled)
{
/* relocate literal table data */
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
data_fixup(&compiled->relocation);
data_fixup(&compiled->literals);
for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan);
relocate_code_block(compiled,code_start,literals_start);
relocate_code_block(compiled);
}
void relocate_code()

11
vm/layouts.h
View File

@ -106,10 +106,11 @@ typedef struct
{
char type; /* this is WORD_TYPE or QUOTATION_TYPE */
char last_scan; /* the youngest generation in which this block's literals may live */
char needs_fixup; /* is this a new block that needs full fixup? */
CELL code_length; /* # bytes */
CELL literals_length; /* # bytes */
CELL literals; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_COMPILED;
} F_CODE_BLOCK;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
@ -135,9 +136,9 @@ typedef struct {
/* UNTAGGED execution token: jump here to execute word */
XT xt;
/* UNTAGGED compiled code block */
F_COMPILED *code;
F_CODE_BLOCK *code;
/* UNTAGGED profiler stub */
F_COMPILED *profiling;
F_CODE_BLOCK *profiling;
} F_WORD;
/* Assembly code makes assumptions about the layout of this struct */
@ -174,7 +175,7 @@ typedef struct {
/* UNTAGGED */
XT xt;
/* UNTAGGED compiled code block */
F_COMPILED *code;
F_CODE_BLOCK *code;
} F_QUOTATION;
/* Assembly code makes assumptions about the layout of this struct */

1
vm/master.h
View File

@ -32,6 +32,7 @@
#include "float_bits.h"
#include "io.h"
#include "code_gc.h"
#include "code_block.h"
#include "code_heap.h"
#include "image.h"
#include "callstack.h"

6
vm/profiler.c
View File

@ -1,7 +1,7 @@
#include "master.h"
/* Allocates memory */
F_COMPILED *compile_profiling_stub(F_WORD *word)
F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
{
CELL literals = allot_array_1(tag_object(word));
REGISTER_ROOT(literals);
@ -26,7 +26,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
untag_object(code),
NULL, /* no labels */
tag_object(relocation),
untag_object(literals));
literals);
}
/* Allocates memory */
@ -37,7 +37,7 @@ void update_word_xt(F_WORD *word)
if(!word->profiling)
{
REGISTER_UNTAGGED(word);
F_COMPILED *profiling = compile_profiling_stub(word);
F_CODE_BLOCK *profiling = compile_profiling_stub(word);
UNREGISTER_UNTAGGED(word);
word->profiling = profiling;
}

2
vm/profiler.h
View File

@ -1,4 +1,4 @@
bool profiling_p;
void primitive_profiling(void);
F_COMPILED *compile_profiling_stub(F_WORD *word);
F_CODE_BLOCK *compile_profiling_stub(F_WORD *word);
void update_word_xt(F_WORD *word);

8
vm/quotations.c
View File

@ -155,7 +155,7 @@ bool jit_stack_frame_p(F_ARRAY *array)
return false;
}
void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("bad param to set_quot_xt",(CELL)code);
@ -339,17 +339,17 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY_TRIM(literals);
GROWABLE_BYTE_ARRAY_TRIM(relocation);
F_COMPILED *compiled = add_compiled_block(
F_CODE_BLOCK *compiled = add_compiled_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
relocation,
untag_object(literals));
literals);
set_quot_xt(untag_object(quot),compiled);
if(relocate)
iterate_code_heap_step(compiled,relocate_code_block);
relocate_code_block(compiled);
UNREGISTER_ROOT(literals);
UNREGISTER_ROOT(relocation);

2
vm/quotations.h
View File

@ -1,4 +1,4 @@
void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);

8
vm/types.c
View File

@ -62,7 +62,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
UNREGISTER_UNTAGGED(word);
if(profiling_p)
iterate_code_heap_step(word->profiling,relocate_code_block);
relocate_code_block(word->profiling);
return word;
}
@ -79,9 +79,9 @@ void primitive_word(void)
void primitive_word_xt(void)
{
F_WORD *word = untag_word(dpop());
F_COMPILED *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK) + code->code_length));
}
void primitive_wrapper(void)