diff --git a/Makefile b/Makefile index ffcbf6364c..c028fd5921 100644 --- a/Makefile +++ b/Makefile @@ -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) diff --git a/vm/callstack.c b/vm/callstack.c index dfa7dd5f4a..ae3f524112 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -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) diff --git a/vm/callstack.h b/vm/callstack.h index da0748b071..68937980f6 100755 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -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); diff --git a/vm/code_block.c b/vm/code_block.c new file mode 100644 index 0000000000..61803d9536 --- /dev/null +++ b/vm/code_block.c @@ -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; +} diff --git a/vm/code_block.h b/vm/code_block.h new file mode 100644 index 0000000000..7ee60d24cf --- /dev/null +++ b/vm/code_block.h @@ -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); diff --git a/vm/code_gc.c b/vm/code_gc.c index c15185944a..8c734c263c 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -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); -} diff --git a/vm/code_gc.h b/vm/code_gc.h index 72ad8d451c..4d4637d0e1 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -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); diff --git a/vm/code_heap.c b/vm/code_heap.c index 99db189356..325aed5037 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -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); } diff --git a/vm/code_heap.h b/vm/code_heap.h index d167ece7fa..17a32aedd3 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -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); diff --git a/vm/data_gc.c b/vm/data_gc.c index 2122f930f0..90d1c7625f 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -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); diff --git a/vm/data_gc.h b/vm/data_gc.h index 6d367a25fd..db1fbd6c8b 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -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); diff --git a/vm/debug.c b/vm/debug.c index 172e889ddb..6b72b97bec 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -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"); } diff --git a/vm/image.c b/vm/image.c index 5f4492e537..d60b693fd8 100755 --- a/vm/image.c +++ b/vm/image.c @@ -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() diff --git a/vm/layouts.h b/vm/layouts.h index ad7e4c0f65..94e2f623a3 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -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 */ diff --git a/vm/master.h b/vm/master.h index 0f4daa705b..29ff0243c7 100644 --- a/vm/master.h +++ b/vm/master.h @@ -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" diff --git a/vm/profiler.c b/vm/profiler.c index e3db67964f..66cefcf891 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -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; } diff --git a/vm/profiler.h b/vm/profiler.h index 26a3a78d4b..4a44ec3f36 100755 --- a/vm/profiler.h +++ b/vm/profiler.h @@ -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); diff --git a/vm/quotations.c b/vm/quotations.c index 2d7818a307..ca1a8bb3b5 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -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); diff --git a/vm/quotations.h b/vm/quotations.h index 4c2c17bbb6..d571a90ed6 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -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); diff --git a/vm/types.c b/vm/types.c index 983c238943..2f8cafb768 100755 --- a/vm/types.c +++ b/vm/types.c @@ -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)