Merge commit 'origin/master' into emacs
Jose A. Ortega Ruiz
commit
7891c6ebdb
1
Makefile
1
Makefile
|
|
@ -30,6 +30,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
vm/code_gc.o \
|
||||
vm/code_heap.o \
|
||||
vm/data_gc.o \
|
||||
vm/data_heap.o \
|
||||
vm/debug.o \
|
||||
vm/errors.o \
|
||||
vm/factor.o \
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ load-help? off
|
|||
! using the host image's hashing algorithms. We don't
|
||||
! use each-object here since the catch stack isn't yet
|
||||
! set up.
|
||||
gc
|
||||
begin-scan
|
||||
[ hashtable? ] pusher [ (each-object) ] dip
|
||||
end-scan
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ quotations math ;
|
|||
IN: memory
|
||||
|
||||
HELP: begin-scan ( -- )
|
||||
{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
|
||||
{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
|
||||
$nl
|
||||
"This word must always be paired with a call to " { $link end-scan } "." }
|
||||
{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: memory
|
|||
] [ 2drop ] if ; inline recursive
|
||||
|
||||
: each-object ( quot -- )
|
||||
begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
|
||||
gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
|
||||
|
||||
: count-instances ( quot -- n )
|
||||
0 swap [ 1 0 ? + ] compose each-object ; inline
|
||||
|
|
|
|||
|
|
@ -178,6 +178,49 @@ void mark_code_block(F_CODE_BLOCK *compiled)
|
|||
flush_icache_for(compiled);
|
||||
}
|
||||
|
||||
void mark_stack_frame_step(F_STACK_FRAME *frame)
|
||||
{
|
||||
mark_code_block(frame_code(frame));
|
||||
}
|
||||
|
||||
/* Mark code blocks executing in currently active stack frames. */
|
||||
void mark_active_blocks(F_CONTEXT *stacks)
|
||||
{
|
||||
if(collecting_gen == TENURED)
|
||||
{
|
||||
CELL top = (CELL)stacks->callstack_top;
|
||||
CELL bottom = (CELL)stacks->callstack_bottom;
|
||||
|
||||
iterate_callstack(top,bottom,mark_stack_frame_step);
|
||||
}
|
||||
}
|
||||
|
||||
void mark_object_code_block(CELL scan)
|
||||
{
|
||||
F_WORD *word;
|
||||
F_QUOTATION *quot;
|
||||
F_CALLSTACK *stack;
|
||||
|
||||
switch(object_type(scan))
|
||||
{
|
||||
case WORD_TYPE:
|
||||
word = (F_WORD *)scan;
|
||||
mark_code_block(word->code);
|
||||
if(word->profiling)
|
||||
mark_code_block(word->profiling);
|
||||
break;
|
||||
case QUOTATION_TYPE:
|
||||
quot = (F_QUOTATION *)scan;
|
||||
if(quot->compiledp != F)
|
||||
mark_code_block(quot->code);
|
||||
break;
|
||||
case CALLSTACK_TYPE:
|
||||
stack = (F_CALLSTACK *)scan;
|
||||
iterate_callstack_object(stack,mark_stack_frame_step);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
/* References to undefined symbols are patched up to call this function on
|
||||
image load */
|
||||
void undefined_symbol(void)
|
||||
|
|
|
|||
|
|
@ -73,6 +73,10 @@ void update_word_references(F_CODE_BLOCK *compiled);
|
|||
|
||||
void mark_code_block(F_CODE_BLOCK *compiled);
|
||||
|
||||
void mark_active_blocks(F_CONTEXT *stacks);
|
||||
|
||||
void mark_object_code_block(CELL scan);
|
||||
|
||||
void relocate_code_block(F_CODE_BLOCK *relocating);
|
||||
|
||||
CELL compiled_code_format(void);
|
||||
|
|
|
|||
445
vm/data_gc.c
445
vm/data_gc.c
|
|
@ -1,300 +1,5 @@
|
|||
#include "master.h"
|
||||
|
||||
CELL init_zone(F_ZONE *z, CELL size, CELL start)
|
||||
{
|
||||
z->size = size;
|
||||
z->start = z->here = start;
|
||||
z->end = start + size;
|
||||
return z->end;
|
||||
}
|
||||
|
||||
void init_card_decks(void)
|
||||
{
|
||||
CELL start = align(data_heap->segment->start,DECK_SIZE);
|
||||
allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
|
||||
cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
|
||||
decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
|
||||
}
|
||||
|
||||
F_DATA_HEAP *alloc_data_heap(CELL gens,
|
||||
CELL young_size,
|
||||
CELL aging_size,
|
||||
CELL tenured_size)
|
||||
{
|
||||
young_size = align(young_size,DECK_SIZE);
|
||||
aging_size = align(aging_size,DECK_SIZE);
|
||||
tenured_size = align(tenured_size,DECK_SIZE);
|
||||
|
||||
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
|
||||
data_heap->young_size = young_size;
|
||||
data_heap->aging_size = aging_size;
|
||||
data_heap->tenured_size = tenured_size;
|
||||
data_heap->gen_count = gens;
|
||||
|
||||
CELL total_size;
|
||||
if(data_heap->gen_count == 2)
|
||||
total_size = young_size + 2 * tenured_size;
|
||||
else if(data_heap->gen_count == 3)
|
||||
total_size = young_size + 2 * aging_size + 2 * tenured_size;
|
||||
else
|
||||
{
|
||||
fatal_error("Invalid number of generations",data_heap->gen_count);
|
||||
return NULL; /* can't happen */
|
||||
}
|
||||
|
||||
total_size += DECK_SIZE;
|
||||
|
||||
data_heap->segment = alloc_segment(total_size);
|
||||
|
||||
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
|
||||
data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
|
||||
|
||||
CELL cards_size = total_size >> CARD_BITS;
|
||||
data_heap->allot_markers = safe_malloc(cards_size);
|
||||
data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
|
||||
|
||||
data_heap->cards = safe_malloc(cards_size);
|
||||
data_heap->cards_end = data_heap->cards + cards_size;
|
||||
|
||||
CELL decks_size = total_size >> DECK_BITS;
|
||||
data_heap->decks = safe_malloc(decks_size);
|
||||
data_heap->decks_end = data_heap->decks + decks_size;
|
||||
|
||||
CELL alloter = align(data_heap->segment->start,DECK_SIZE);
|
||||
|
||||
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
|
||||
alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
|
||||
|
||||
if(data_heap->gen_count == 3)
|
||||
{
|
||||
alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
|
||||
alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
|
||||
}
|
||||
|
||||
if(data_heap->gen_count >= 2)
|
||||
{
|
||||
alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
|
||||
alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
|
||||
}
|
||||
|
||||
if(data_heap->segment->end - alloter > DECK_SIZE)
|
||||
critical_error("Bug in alloc_data_heap",alloter);
|
||||
|
||||
return data_heap;
|
||||
}
|
||||
|
||||
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
|
||||
{
|
||||
CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
|
||||
|
||||
return alloc_data_heap(data_heap->gen_count,
|
||||
data_heap->young_size,
|
||||
data_heap->aging_size,
|
||||
new_tenured_size);
|
||||
}
|
||||
|
||||
void dealloc_data_heap(F_DATA_HEAP *data_heap)
|
||||
{
|
||||
dealloc_segment(data_heap->segment);
|
||||
free(data_heap->generations);
|
||||
free(data_heap->semispaces);
|
||||
free(data_heap->allot_markers);
|
||||
free(data_heap->cards);
|
||||
free(data_heap->decks);
|
||||
free(data_heap);
|
||||
}
|
||||
|
||||
void clear_cards(CELL from, CELL to)
|
||||
{
|
||||
/* NOTE: reverse order due to heap layout. */
|
||||
F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
|
||||
F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
|
||||
memset(first_card,0,last_card - first_card);
|
||||
}
|
||||
|
||||
void clear_decks(CELL from, CELL to)
|
||||
{
|
||||
/* NOTE: reverse order due to heap layout. */
|
||||
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
|
||||
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
|
||||
memset(first_deck,0,last_deck - first_deck);
|
||||
}
|
||||
|
||||
void clear_allot_markers(CELL from, CELL to)
|
||||
{
|
||||
/* NOTE: reverse order due to heap layout. */
|
||||
F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
|
||||
F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
|
||||
memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
|
||||
}
|
||||
|
||||
void set_data_heap(F_DATA_HEAP *data_heap_)
|
||||
{
|
||||
data_heap = data_heap_;
|
||||
nursery = data_heap->generations[NURSERY];
|
||||
init_card_decks();
|
||||
clear_cards(NURSERY,TENURED);
|
||||
clear_decks(NURSERY,TENURED);
|
||||
clear_allot_markers(NURSERY,TENURED);
|
||||
}
|
||||
|
||||
void gc_reset(void)
|
||||
{
|
||||
int i;
|
||||
for(i = 0; i < MAX_GEN_COUNT; i++)
|
||||
memset(&gc_stats[i],0,sizeof(F_GC_STATS));
|
||||
|
||||
cards_scanned = 0;
|
||||
decks_scanned = 0;
|
||||
code_heap_scans = 0;
|
||||
}
|
||||
|
||||
void init_data_heap(CELL gens,
|
||||
CELL young_size,
|
||||
CELL aging_size,
|
||||
CELL tenured_size,
|
||||
bool secure_gc_)
|
||||
{
|
||||
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
|
||||
|
||||
gc_locals_region = alloc_segment(getpagesize());
|
||||
gc_locals = gc_locals_region->start - CELLS;
|
||||
|
||||
extra_roots_region = alloc_segment(getpagesize());
|
||||
extra_roots = extra_roots_region->start - CELLS;
|
||||
|
||||
secure_gc = secure_gc_;
|
||||
|
||||
gc_reset();
|
||||
}
|
||||
|
||||
/* Size of the object pointed to by a tagged pointer */
|
||||
CELL object_size(CELL tagged)
|
||||
{
|
||||
if(immediate_p(tagged))
|
||||
return 0;
|
||||
else
|
||||
return untagged_object_size(UNTAG(tagged));
|
||||
}
|
||||
|
||||
/* Size of the object pointed to by an untagged pointer */
|
||||
CELL untagged_object_size(CELL pointer)
|
||||
{
|
||||
return align8(unaligned_object_size(pointer));
|
||||
}
|
||||
|
||||
/* Size of the data area of an object pointed to by an untagged pointer */
|
||||
CELL unaligned_object_size(CELL pointer)
|
||||
{
|
||||
F_TUPLE *tuple;
|
||||
F_TUPLE_LAYOUT *layout;
|
||||
|
||||
switch(untag_header(get(pointer)))
|
||||
{
|
||||
case ARRAY_TYPE:
|
||||
case BIGNUM_TYPE:
|
||||
return array_size(array_capacity((F_ARRAY*)pointer));
|
||||
case BYTE_ARRAY_TYPE:
|
||||
return byte_array_size(
|
||||
byte_array_capacity((F_BYTE_ARRAY*)pointer));
|
||||
case STRING_TYPE:
|
||||
return string_size(string_capacity((F_STRING*)pointer));
|
||||
case TUPLE_TYPE:
|
||||
tuple = untag_object(pointer);
|
||||
layout = untag_object(tuple->layout);
|
||||
return tuple_size(layout);
|
||||
case QUOTATION_TYPE:
|
||||
return sizeof(F_QUOTATION);
|
||||
case WORD_TYPE:
|
||||
return sizeof(F_WORD);
|
||||
case RATIO_TYPE:
|
||||
return sizeof(F_RATIO);
|
||||
case FLOAT_TYPE:
|
||||
return sizeof(F_FLOAT);
|
||||
case COMPLEX_TYPE:
|
||||
return sizeof(F_COMPLEX);
|
||||
case DLL_TYPE:
|
||||
return sizeof(F_DLL);
|
||||
case ALIEN_TYPE:
|
||||
return sizeof(F_ALIEN);
|
||||
case WRAPPER_TYPE:
|
||||
return sizeof(F_WRAPPER);
|
||||
case CALLSTACK_TYPE:
|
||||
return callstack_size(
|
||||
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
|
||||
default:
|
||||
critical_error("Invalid header",pointer);
|
||||
return -1; /* can't happen */
|
||||
}
|
||||
}
|
||||
|
||||
void primitive_size(void)
|
||||
{
|
||||
box_unsigned_cell(object_size(dpop()));
|
||||
}
|
||||
|
||||
/* Push memory usage statistics in data heap */
|
||||
void primitive_data_room(void)
|
||||
{
|
||||
F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
|
||||
int gen;
|
||||
|
||||
dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
|
||||
dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
|
||||
|
||||
for(gen = 0; gen < data_heap->gen_count; gen++)
|
||||
{
|
||||
F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
|
||||
set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
|
||||
set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
|
||||
}
|
||||
|
||||
dpush(tag_object(a));
|
||||
}
|
||||
|
||||
/* Disables GC and activates next-object ( -- obj ) primitive */
|
||||
void begin_scan(void)
|
||||
{
|
||||
heap_scan_ptr = data_heap->generations[TENURED].start;
|
||||
gc_off = true;
|
||||
}
|
||||
|
||||
void primitive_begin_scan(void)
|
||||
{
|
||||
gc();
|
||||
begin_scan();
|
||||
}
|
||||
|
||||
CELL next_object(void)
|
||||
{
|
||||
if(!gc_off)
|
||||
general_error(ERROR_HEAP_SCAN,F,F,NULL);
|
||||
|
||||
CELL value = get(heap_scan_ptr);
|
||||
CELL obj = heap_scan_ptr;
|
||||
CELL type;
|
||||
|
||||
if(heap_scan_ptr >= data_heap->generations[TENURED].here)
|
||||
return F;
|
||||
|
||||
type = untag_header(value);
|
||||
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
|
||||
|
||||
return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
|
||||
}
|
||||
|
||||
/* Push object at heap scan cursor and advance; pushes f when done */
|
||||
void primitive_next_object(void)
|
||||
{
|
||||
dpush(next_object());
|
||||
}
|
||||
|
||||
/* Re-enables GC */
|
||||
void primitive_end_scan(void)
|
||||
{
|
||||
gc_off = false;
|
||||
}
|
||||
|
||||
/* Scan all the objects in the card */
|
||||
void copy_card(F_CARD *ptr, CELL gen, CELL here)
|
||||
{
|
||||
|
|
@ -424,22 +129,6 @@ void copy_stack_elements(F_SEGMENT *region, CELL top)
|
|||
copy_handle((CELL*)ptr);
|
||||
}
|
||||
|
||||
void copy_stack_frame_step(F_STACK_FRAME *frame)
|
||||
{
|
||||
mark_code_block(frame_code(frame));
|
||||
}
|
||||
|
||||
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,copy_stack_frame_step);
|
||||
}
|
||||
}
|
||||
|
||||
void copy_registered_locals(void)
|
||||
{
|
||||
CELL ptr = gc_locals_region->start;
|
||||
|
|
@ -471,7 +160,7 @@ void copy_roots(void)
|
|||
copy_handle(&stacks->catchstack_save);
|
||||
copy_handle(&stacks->current_callback_save);
|
||||
|
||||
copy_callstack_roots(stacks);
|
||||
mark_active_blocks(stacks);
|
||||
|
||||
stacks = stacks->next;
|
||||
}
|
||||
|
|
@ -552,78 +241,6 @@ void copy_handle(CELL *handle)
|
|||
*handle = copy_object(pointer);
|
||||
}
|
||||
|
||||
/* The number of cells from the start of the object which should be scanned by
|
||||
the GC. Some types have a binary payload at the end (string, word, DLL) which
|
||||
we ignore. */
|
||||
CELL binary_payload_start(CELL pointer)
|
||||
{
|
||||
F_TUPLE *tuple;
|
||||
F_TUPLE_LAYOUT *layout;
|
||||
|
||||
switch(untag_header(get(pointer)))
|
||||
{
|
||||
/* these objects do not refer to other objects at all */
|
||||
case FLOAT_TYPE:
|
||||
case BYTE_ARRAY_TYPE:
|
||||
case BIGNUM_TYPE:
|
||||
case CALLSTACK_TYPE:
|
||||
return 0;
|
||||
/* these objects have some binary data at the end */
|
||||
case WORD_TYPE:
|
||||
return sizeof(F_WORD) - CELLS * 3;
|
||||
case ALIEN_TYPE:
|
||||
return CELLS * 3;
|
||||
case DLL_TYPE:
|
||||
return CELLS * 2;
|
||||
case QUOTATION_TYPE:
|
||||
return sizeof(F_QUOTATION) - CELLS * 2;
|
||||
case STRING_TYPE:
|
||||
return sizeof(F_STRING);
|
||||
/* everything else consists entirely of pointers */
|
||||
case ARRAY_TYPE:
|
||||
return array_size(array_capacity((F_ARRAY*)pointer));
|
||||
case TUPLE_TYPE:
|
||||
tuple = untag_object(pointer);
|
||||
layout = untag_object(tuple->layout);
|
||||
return tuple_size(layout);
|
||||
case RATIO_TYPE:
|
||||
return sizeof(F_RATIO);
|
||||
case COMPLEX_TYPE:
|
||||
return sizeof(F_COMPLEX);
|
||||
case WRAPPER_TYPE:
|
||||
return sizeof(F_WRAPPER);
|
||||
default:
|
||||
critical_error("Invalid header",pointer);
|
||||
return -1; /* can't happen */
|
||||
}
|
||||
}
|
||||
|
||||
void do_code_slots(CELL scan)
|
||||
{
|
||||
F_WORD *word;
|
||||
F_QUOTATION *quot;
|
||||
F_CALLSTACK *stack;
|
||||
|
||||
switch(object_type(scan))
|
||||
{
|
||||
case WORD_TYPE:
|
||||
word = (F_WORD *)scan;
|
||||
mark_code_block(word->code);
|
||||
if(word->profiling)
|
||||
mark_code_block(word->profiling);
|
||||
break;
|
||||
case QUOTATION_TYPE:
|
||||
quot = (F_QUOTATION *)scan;
|
||||
if(quot->compiledp != F)
|
||||
mark_code_block(quot->code);
|
||||
break;
|
||||
case CALLSTACK_TYPE:
|
||||
stack = (F_CALLSTACK *)scan;
|
||||
iterate_callstack_object(stack,copy_stack_frame_step);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
CELL copy_next_from_nursery(CELL scan)
|
||||
{
|
||||
CELL *obj = (CELL *)scan;
|
||||
|
|
@ -699,7 +316,7 @@ CELL copy_next_from_tenured(CELL scan)
|
|||
}
|
||||
}
|
||||
|
||||
do_code_slots(scan);
|
||||
mark_object_code_block(scan);
|
||||
|
||||
return scan + untagged_object_size(scan);
|
||||
}
|
||||
|
|
@ -723,28 +340,6 @@ void copy_reachable_objects(CELL scan, CELL *end)
|
|||
}
|
||||
}
|
||||
|
||||
INLINE void reset_generation(CELL i)
|
||||
{
|
||||
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
|
||||
|
||||
z->here = z->start;
|
||||
if(secure_gc)
|
||||
memset((void*)z->start,69,z->size);
|
||||
}
|
||||
|
||||
/* After garbage collection, any generations which are now empty need to have
|
||||
their allocation pointers and cards reset. */
|
||||
void reset_generations(CELL from, CELL to)
|
||||
{
|
||||
CELL i;
|
||||
for(i = from; i <= to; i++)
|
||||
reset_generation(i);
|
||||
|
||||
clear_cards(from,to);
|
||||
clear_decks(from,to);
|
||||
clear_allot_markers(from,to);
|
||||
}
|
||||
|
||||
/* Prepare to start copying reachable objects into an unused zone */
|
||||
void begin_gc(CELL requested_bytes)
|
||||
{
|
||||
|
|
@ -950,9 +545,20 @@ void primitive_gc_stats(void)
|
|||
dpush(stats);
|
||||
}
|
||||
|
||||
void primitive_gc_reset(void)
|
||||
void clear_gc_stats(void)
|
||||
{
|
||||
gc_reset();
|
||||
int i;
|
||||
for(i = 0; i < MAX_GEN_COUNT; i++)
|
||||
memset(&gc_stats[i],0,sizeof(F_GC_STATS));
|
||||
|
||||
cards_scanned = 0;
|
||||
decks_scanned = 0;
|
||||
code_heap_scans = 0;
|
||||
}
|
||||
|
||||
void primitive_clear_gc_stats(void)
|
||||
{
|
||||
clear_gc_stats();
|
||||
}
|
||||
|
||||
void primitive_become(void)
|
||||
|
|
@ -978,24 +584,3 @@ void primitive_become(void)
|
|||
|
||||
compile_all_words();
|
||||
}
|
||||
|
||||
CELL find_all_words(void)
|
||||
{
|
||||
GROWABLE_ARRAY(words);
|
||||
|
||||
begin_scan();
|
||||
|
||||
CELL obj;
|
||||
while((obj = next_object()) != F)
|
||||
{
|
||||
if(type_of(obj) == WORD_TYPE)
|
||||
GROWABLE_ARRAY_ADD(words,obj);
|
||||
}
|
||||
|
||||
/* End heap scan */
|
||||
gc_off = false;
|
||||
|
||||
GROWABLE_ARRAY_TRIM(words);
|
||||
|
||||
return words;
|
||||
}
|
||||
|
|
|
|||
296
vm/data_gc.h
296
vm/data_gc.h
|
|
@ -1,162 +1,19 @@
|
|||
/* Set by the -S command line argument */
|
||||
bool secure_gc;
|
||||
|
||||
/* set up guard pages to check for under/overflow.
|
||||
size must be a multiple of the page size */
|
||||
F_SEGMENT *alloc_segment(CELL size);
|
||||
void dealloc_segment(F_SEGMENT *block);
|
||||
|
||||
CELL untagged_object_size(CELL pointer);
|
||||
CELL unaligned_object_size(CELL pointer);
|
||||
CELL object_size(CELL pointer);
|
||||
CELL binary_payload_start(CELL pointer);
|
||||
void begin_scan(void);
|
||||
CELL next_object(void);
|
||||
|
||||
void primitive_data_room(void);
|
||||
void primitive_size(void);
|
||||
void primitive_begin_scan(void);
|
||||
void primitive_next_object(void);
|
||||
void primitive_end_scan(void);
|
||||
|
||||
void gc(void);
|
||||
DLLEXPORT void minor_gc(void);
|
||||
|
||||
/* generational copying GC divides memory into zones */
|
||||
typedef struct {
|
||||
/* allocation pointer is 'here'; its offset is hardcoded in the
|
||||
compiler backends, see core/compiler/.../allot.factor */
|
||||
CELL start;
|
||||
CELL here;
|
||||
CELL size;
|
||||
CELL end;
|
||||
} F_ZONE;
|
||||
|
||||
typedef struct {
|
||||
F_SEGMENT *segment;
|
||||
|
||||
CELL young_size;
|
||||
CELL aging_size;
|
||||
CELL tenured_size;
|
||||
|
||||
CELL gen_count;
|
||||
|
||||
F_ZONE *generations;
|
||||
F_ZONE* semispaces;
|
||||
|
||||
CELL *allot_markers;
|
||||
CELL *allot_markers_end;
|
||||
|
||||
CELL *cards;
|
||||
CELL *cards_end;
|
||||
|
||||
CELL *decks;
|
||||
CELL *decks_end;
|
||||
} F_DATA_HEAP;
|
||||
|
||||
F_DATA_HEAP *data_heap;
|
||||
|
||||
/* card marking write barrier. a card is a byte storing a mark flag,
|
||||
and the offset (in cells) of the first object in the card.
|
||||
|
||||
the mark flag is set by the write barrier when an object in the
|
||||
card has a slot written to.
|
||||
|
||||
the offset of the first object is set by the allocator. */
|
||||
|
||||
/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
|
||||
#define CARD_POINTS_TO_NURSERY 0x80
|
||||
#define CARD_POINTS_TO_AGING 0x40
|
||||
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
|
||||
typedef u8 F_CARD;
|
||||
|
||||
#define CARD_BITS 8
|
||||
#define CARD_SIZE (1<<CARD_BITS)
|
||||
#define ADDR_CARD_MASK (CARD_SIZE-1)
|
||||
|
||||
DLLEXPORT CELL cards_offset;
|
||||
|
||||
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
|
||||
#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
|
||||
|
||||
typedef u8 F_DECK;
|
||||
|
||||
#define DECK_BITS (CARD_BITS + 10)
|
||||
#define DECK_SIZE (1<<DECK_BITS)
|
||||
#define ADDR_DECK_MASK (DECK_SIZE-1)
|
||||
|
||||
DLLEXPORT CELL decks_offset;
|
||||
|
||||
#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
|
||||
#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
|
||||
|
||||
#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
|
||||
|
||||
#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
|
||||
#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
|
||||
|
||||
#define INVALID_ALLOT_MARKER 0xff
|
||||
|
||||
DLLEXPORT CELL allot_markers_offset;
|
||||
|
||||
void init_card_decks(void);
|
||||
|
||||
/* the write barrier must be called any time we are potentially storing a
|
||||
pointer from an older generation to a younger one */
|
||||
INLINE void write_barrier(CELL address)
|
||||
{
|
||||
*ADDR_TO_CARD(address) = CARD_MARK_MASK;
|
||||
*ADDR_TO_DECK(address) = CARD_MARK_MASK;
|
||||
}
|
||||
|
||||
#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
|
||||
|
||||
INLINE void set_slot(CELL obj, CELL slot, CELL value)
|
||||
{
|
||||
put(SLOT(obj,slot),value);
|
||||
write_barrier(obj);
|
||||
}
|
||||
|
||||
/* we need to remember the first object allocated in the card */
|
||||
INLINE void allot_barrier(CELL address)
|
||||
{
|
||||
F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
|
||||
if(*ptr == INVALID_ALLOT_MARKER)
|
||||
*ptr = (address & ADDR_CARD_MASK);
|
||||
}
|
||||
|
||||
void clear_cards(CELL from, CELL to);
|
||||
|
||||
/* the 0th generation is where new objects are allocated. */
|
||||
#define NURSERY 0
|
||||
#define HAVE_NURSERY_P (data_heap->gen_count>1)
|
||||
/* where objects hang around */
|
||||
#define AGING (data_heap->gen_count-2)
|
||||
#define HAVE_AGING_P (data_heap->gen_count>2)
|
||||
/* the oldest generation */
|
||||
#define TENURED (data_heap->gen_count-1)
|
||||
|
||||
#define MIN_GEN_COUNT 1
|
||||
#define MAX_GEN_COUNT 3
|
||||
|
||||
/* used during garbage collection only */
|
||||
|
||||
F_ZONE *newspace;
|
||||
bool performing_gc;
|
||||
CELL collecting_gen;
|
||||
|
||||
/* new objects are allocated here */
|
||||
DLLEXPORT F_ZONE nursery;
|
||||
/* if true, we collecting AGING space for the second time, so if it is still
|
||||
full, we go on to collect TENURED */
|
||||
bool collecting_aging_again;
|
||||
|
||||
INLINE bool in_zone(F_ZONE *z, CELL pointer)
|
||||
{
|
||||
return pointer >= z->start && pointer < z->end;
|
||||
}
|
||||
|
||||
CELL init_zone(F_ZONE *z, CELL size, CELL base);
|
||||
|
||||
void init_data_heap(CELL gens,
|
||||
CELL young_size,
|
||||
CELL aging_size,
|
||||
CELL tenured_size,
|
||||
bool secure_gc_);
|
||||
/* in case a generation fills up in the middle of a gc, we jump back
|
||||
up to try collecting the next generation. */
|
||||
jmp_buf gc_jmp;
|
||||
|
||||
/* statistics */
|
||||
typedef struct {
|
||||
|
|
@ -172,24 +29,8 @@ u64 cards_scanned;
|
|||
u64 decks_scanned;
|
||||
CELL code_heap_scans;
|
||||
|
||||
/* only meaningful during a GC */
|
||||
bool performing_gc;
|
||||
CELL collecting_gen;
|
||||
|
||||
/* if true, we collecting AGING space for the second time, so if it is still
|
||||
full, we go on to collect TENURED */
|
||||
bool collecting_aging_again;
|
||||
|
||||
INLINE bool collecting_accumulation_gen_p(void)
|
||||
{
|
||||
return ((HAVE_AGING_P
|
||||
&& collecting_gen == AGING
|
||||
&& !collecting_aging_again)
|
||||
|| collecting_gen == TENURED);
|
||||
}
|
||||
|
||||
/* What generation was being collected when collect_literals() was last
|
||||
called? Until the next call to primitive_add_compiled_block(), future
|
||||
/* What generation was being collected when copy_code_heap_roots() was last
|
||||
called? Until the next call to add_compiled_block(), future
|
||||
collections of younger generations don't have to touch the code
|
||||
heap. */
|
||||
CELL last_code_heap_scan;
|
||||
|
|
@ -198,22 +39,12 @@ CELL last_code_heap_scan;
|
|||
bool growing_data_heap;
|
||||
F_DATA_HEAP *old_data_heap;
|
||||
|
||||
/* Every object has a regular representation in the runtime, which makes GC
|
||||
much simpler. Every slot of the object until binary_payload_start is a pointer
|
||||
to some other object. */
|
||||
INLINE void do_slots(CELL obj, void (* iter)(CELL *))
|
||||
INLINE bool collecting_accumulation_gen_p(void)
|
||||
{
|
||||
CELL scan = obj;
|
||||
CELL payload_start = binary_payload_start(obj);
|
||||
CELL end = obj + payload_start;
|
||||
|
||||
scan += CELLS;
|
||||
|
||||
while(scan < end)
|
||||
{
|
||||
iter((CELL *)scan);
|
||||
scan += CELLS;
|
||||
}
|
||||
return ((HAVE_AGING_P
|
||||
&& collecting_gen == AGING
|
||||
&& !collecting_aging_again)
|
||||
|| collecting_gen == TENURED);
|
||||
}
|
||||
|
||||
/* test if the pointer is in generation being collected, or a younger one. */
|
||||
|
|
@ -236,98 +67,10 @@ INLINE bool should_copy(CELL untagged)
|
|||
|
||||
void copy_handle(CELL *handle);
|
||||
|
||||
/* in case a generation fills up in the middle of a gc, we jump back
|
||||
up to try collecting the next generation. */
|
||||
jmp_buf gc_jmp;
|
||||
|
||||
/* A heap walk allows useful things to be done, like finding all
|
||||
references to an object for debugging purposes. */
|
||||
CELL heap_scan_ptr;
|
||||
|
||||
/* GC is off during heap walking */
|
||||
bool gc_off;
|
||||
|
||||
void garbage_collection(volatile CELL gen,
|
||||
bool growing_data_heap_,
|
||||
CELL requested_bytes);
|
||||
|
||||
/* If a runtime function needs to call another function which potentially
|
||||
allocates memory, it must store any local variable references to Factor
|
||||
objects on the root stack */
|
||||
|
||||
/* GC locals: stores addresses of pointers to objects. The GC updates these
|
||||
pointers, so you can do
|
||||
|
||||
REGISTER_ROOT(some_local);
|
||||
|
||||
... allocate memory ...
|
||||
|
||||
foo(some_local);
|
||||
|
||||
...
|
||||
|
||||
UNREGISTER_ROOT(some_local); */
|
||||
F_SEGMENT *gc_locals_region;
|
||||
CELL gc_locals;
|
||||
|
||||
DEFPUSHPOP(gc_local_,gc_locals)
|
||||
|
||||
#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
|
||||
#define UNREGISTER_ROOT(obj) \
|
||||
{ \
|
||||
if(gc_local_pop() != (CELL)&obj) \
|
||||
critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
|
||||
}
|
||||
|
||||
/* Extra roots: stores pointers to objects in the heap. Requires extra work
|
||||
(you have to unregister before accessing the object) but more flexible. */
|
||||
F_SEGMENT *extra_roots_region;
|
||||
CELL extra_roots;
|
||||
|
||||
DEFPUSHPOP(root_,extra_roots)
|
||||
|
||||
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
|
||||
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
|
||||
|
||||
INLINE bool in_data_heap_p(CELL ptr)
|
||||
{
|
||||
return (ptr >= data_heap->segment->start
|
||||
&& ptr <= data_heap->segment->end);
|
||||
}
|
||||
|
||||
/* We ignore strings which point outside the data heap, but we might be given
|
||||
a char* which points inside the data heap, in which case it is a root, for
|
||||
example if we call unbox_char_string() the result is placed in a byte array */
|
||||
INLINE bool root_push_alien(const void *ptr)
|
||||
{
|
||||
if(in_data_heap_p((CELL)ptr))
|
||||
{
|
||||
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
|
||||
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
|
||||
{
|
||||
root_push(tag_object(objptr));
|
||||
return true;
|
||||
}
|
||||
}
|
||||
|
||||
return false;
|
||||
}
|
||||
|
||||
#define REGISTER_C_STRING(obj) \
|
||||
bool obj##_root = root_push_alien(obj)
|
||||
#define UNREGISTER_C_STRING(obj) \
|
||||
if(obj##_root) obj = alien_offset(root_pop())
|
||||
|
||||
#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
|
||||
#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))
|
||||
|
||||
INLINE void *allot_zone(F_ZONE *z, CELL a)
|
||||
{
|
||||
CELL h = z->here;
|
||||
z->here = h + align8(a);
|
||||
return (void*)h;
|
||||
}
|
||||
|
||||
/* We leave this many bytes free at the top of the nursery so that inline
|
||||
allocation (which does not call GC because of possible roots in volatile
|
||||
registers) does not run out of memory */
|
||||
|
|
@ -337,7 +80,7 @@ registers) does not run out of memory */
|
|||
* It is up to the caller to fill in the object's fields in a meaningful
|
||||
* fashion!
|
||||
*/
|
||||
INLINE void* allot_object(CELL type, CELL a)
|
||||
INLINE void *allot_object(CELL type, CELL a)
|
||||
{
|
||||
CELL *object;
|
||||
|
||||
|
|
@ -390,7 +133,6 @@ void copy_reachable_objects(CELL scan, CELL *end);
|
|||
|
||||
void primitive_gc(void);
|
||||
void primitive_gc_stats(void);
|
||||
void primitive_gc_reset(void);
|
||||
void clear_gc_stats(void);
|
||||
void primitive_clear_gc_stats(void);
|
||||
void primitive_become(void);
|
||||
|
||||
CELL find_all_words(void);
|
||||
|
|
|
|||
|
|
@ -0,0 +1,371 @@
|
|||
#include "master.h"
|
||||
|
||||
CELL init_zone(F_ZONE *z, CELL size, CELL start)
|
||||
{
|
||||
z->size = size;
|
||||
z->start = z->here = start;
|
||||
z->end = start + size;
|
||||
return z->end;
|
||||
}
|
||||
|
||||
void init_card_decks(void)
|
||||
{
|
||||
CELL start = align(data_heap->segment->start,DECK_SIZE);
|
||||
allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
|
||||
cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
|
||||
decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
|
||||
}
|
||||
|
||||
F_DATA_HEAP *alloc_data_heap(CELL gens,
|
||||
CELL young_size,
|
||||
CELL aging_size,
|
||||
CELL tenured_size)
|
||||
{
|
||||
young_size = align(young_size,DECK_SIZE);
|
||||
aging_size = align(aging_size,DECK_SIZE);
|
||||
tenured_size = align(tenured_size,DECK_SIZE);
|
||||
|
||||
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
|
||||
data_heap->young_size = young_size;
|
||||
data_heap->aging_size = aging_size;
|
||||
data_heap->tenured_size = tenured_size;
|
||||
data_heap->gen_count = gens;
|
||||
|
||||
CELL total_size;
|
||||
if(data_heap->gen_count == 2)
|
||||
total_size = young_size + 2 * tenured_size;
|
||||
else if(data_heap->gen_count == 3)
|
||||
total_size = young_size + 2 * aging_size + 2 * tenured_size;
|
||||
else
|
||||
{
|
||||
fatal_error("Invalid number of generations",data_heap->gen_count);
|
||||
return NULL; /* can't happen */
|
||||
}
|
||||
|
||||
total_size += DECK_SIZE;
|
||||
|
||||
data_heap->segment = alloc_segment(total_size);
|
||||
|
||||
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
|
||||
data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
|
||||
|
||||
CELL cards_size = total_size >> CARD_BITS;
|
||||
data_heap->allot_markers = safe_malloc(cards_size);
|
||||
data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
|
||||
|
||||
data_heap->cards = safe_malloc(cards_size);
|
||||
data_heap->cards_end = data_heap->cards + cards_size;
|
||||
|
||||
CELL decks_size = total_size >> DECK_BITS;
|
||||
data_heap->decks = safe_malloc(decks_size);
|
||||
data_heap->decks_end = data_heap->decks + decks_size;
|
||||
|
||||
CELL alloter = align(data_heap->segment->start,DECK_SIZE);
|
||||
|
||||
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
|
||||
alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
|
||||
|
||||
if(data_heap->gen_count == 3)
|
||||
{
|
||||
alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
|
||||
alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
|
||||
}
|
||||
|
||||
if(data_heap->gen_count >= 2)
|
||||
{
|
||||
alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
|
||||
alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
|
||||
}
|
||||
|
||||
if(data_heap->segment->end - alloter > DECK_SIZE)
|
||||
critical_error("Bug in alloc_data_heap",alloter);
|
||||
|
||||
return data_heap;
|
||||
}
|
||||
|
||||
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
|
||||
{
|
||||
CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
|
||||
|
||||
return alloc_data_heap(data_heap->gen_count,
|
||||
data_heap->young_size,
|
||||
data_heap->aging_size,
|
||||
new_tenured_size);
|
||||
}
|
||||
|
||||
void dealloc_data_heap(F_DATA_HEAP *data_heap)
|
||||
{
|
||||
dealloc_segment(data_heap->segment);
|
||||
free(data_heap->generations);
|
||||
free(data_heap->semispaces);
|
||||
free(data_heap->allot_markers);
|
||||
free(data_heap->cards);
|
||||
free(data_heap->decks);
|
||||
free(data_heap);
|
||||
}
|
||||
|
||||
void clear_cards(CELL from, CELL to)
|
||||
{
|
||||
/* NOTE: reverse order due to heap layout. */
|
||||
F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
|
||||
F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
|
||||
memset(first_card,0,last_card - first_card);
|
||||
}
|
||||
|
||||
void clear_decks(CELL from, CELL to)
|
||||
{
|
||||
/* NOTE: reverse order due to heap layout. */
|
||||
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
|
||||
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
|
||||
memset(first_deck,0,last_deck - first_deck);
|
||||
}
|
||||
|
||||
void clear_allot_markers(CELL from, CELL to)
|
||||
{
|
||||
/* NOTE: reverse order due to heap layout. */
|
||||
F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
|
||||
F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
|
||||
memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
|
||||
}
|
||||
|
||||
void reset_generation(CELL i)
|
||||
{
|
||||
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
|
||||
|
||||
z->here = z->start;
|
||||
if(secure_gc)
|
||||
memset((void*)z->start,69,z->size);
|
||||
}
|
||||
|
||||
/* After garbage collection, any generations which are now empty need to have
|
||||
their allocation pointers and cards reset. */
|
||||
void reset_generations(CELL from, CELL to)
|
||||
{
|
||||
CELL i;
|
||||
for(i = from; i <= to; i++)
|
||||
reset_generation(i);
|
||||
|
||||
clear_cards(from,to);
|
||||
clear_decks(from,to);
|
||||
clear_allot_markers(from,to);
|
||||
}
|
||||
|
||||
void set_data_heap(F_DATA_HEAP *data_heap_)
|
||||
{
|
||||
data_heap = data_heap_;
|
||||
nursery = data_heap->generations[NURSERY];
|
||||
init_card_decks();
|
||||
clear_cards(NURSERY,TENURED);
|
||||
clear_decks(NURSERY,TENURED);
|
||||
clear_allot_markers(NURSERY,TENURED);
|
||||
}
|
||||
|
||||
void init_data_heap(CELL gens,
|
||||
CELL young_size,
|
||||
CELL aging_size,
|
||||
CELL tenured_size,
|
||||
bool secure_gc_)
|
||||
{
|
||||
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
|
||||
|
||||
gc_locals_region = alloc_segment(getpagesize());
|
||||
gc_locals = gc_locals_region->start - CELLS;
|
||||
|
||||
extra_roots_region = alloc_segment(getpagesize());
|
||||
extra_roots = extra_roots_region->start - CELLS;
|
||||
|
||||
secure_gc = secure_gc_;
|
||||
}
|
||||
|
||||
/* Size of the object pointed to by a tagged pointer */
|
||||
CELL object_size(CELL tagged)
|
||||
{
|
||||
if(immediate_p(tagged))
|
||||
return 0;
|
||||
else
|
||||
return untagged_object_size(UNTAG(tagged));
|
||||
}
|
||||
|
||||
/* Size of the object pointed to by an untagged pointer */
|
||||
CELL untagged_object_size(CELL pointer)
|
||||
{
|
||||
return align8(unaligned_object_size(pointer));
|
||||
}
|
||||
|
||||
/* Size of the data area of an object pointed to by an untagged pointer */
|
||||
CELL unaligned_object_size(CELL pointer)
|
||||
{
|
||||
F_TUPLE *tuple;
|
||||
F_TUPLE_LAYOUT *layout;
|
||||
|
||||
switch(untag_header(get(pointer)))
|
||||
{
|
||||
case ARRAY_TYPE:
|
||||
case BIGNUM_TYPE:
|
||||
return array_size(array_capacity((F_ARRAY*)pointer));
|
||||
case BYTE_ARRAY_TYPE:
|
||||
return byte_array_size(
|
||||
byte_array_capacity((F_BYTE_ARRAY*)pointer));
|
||||
case STRING_TYPE:
|
||||
return string_size(string_capacity((F_STRING*)pointer));
|
||||
case TUPLE_TYPE:
|
||||
tuple = untag_object(pointer);
|
||||
layout = untag_object(tuple->layout);
|
||||
return tuple_size(layout);
|
||||
case QUOTATION_TYPE:
|
||||
return sizeof(F_QUOTATION);
|
||||
case WORD_TYPE:
|
||||
return sizeof(F_WORD);
|
||||
case RATIO_TYPE:
|
||||
return sizeof(F_RATIO);
|
||||
case FLOAT_TYPE:
|
||||
return sizeof(F_FLOAT);
|
||||
case COMPLEX_TYPE:
|
||||
return sizeof(F_COMPLEX);
|
||||
case DLL_TYPE:
|
||||
return sizeof(F_DLL);
|
||||
case ALIEN_TYPE:
|
||||
return sizeof(F_ALIEN);
|
||||
case WRAPPER_TYPE:
|
||||
return sizeof(F_WRAPPER);
|
||||
case CALLSTACK_TYPE:
|
||||
return callstack_size(
|
||||
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
|
||||
default:
|
||||
critical_error("Invalid header",pointer);
|
||||
return -1; /* can't happen */
|
||||
}
|
||||
}
|
||||
|
||||
void primitive_size(void)
|
||||
{
|
||||
box_unsigned_cell(object_size(dpop()));
|
||||
}
|
||||
|
||||
/* The number of cells from the start of the object which should be scanned by
|
||||
the GC. Some types have a binary payload at the end (string, word, DLL) which
|
||||
we ignore. */
|
||||
CELL binary_payload_start(CELL pointer)
|
||||
{
|
||||
F_TUPLE *tuple;
|
||||
F_TUPLE_LAYOUT *layout;
|
||||
|
||||
switch(untag_header(get(pointer)))
|
||||
{
|
||||
/* these objects do not refer to other objects at all */
|
||||
case FLOAT_TYPE:
|
||||
case BYTE_ARRAY_TYPE:
|
||||
case BIGNUM_TYPE:
|
||||
case CALLSTACK_TYPE:
|
||||
return 0;
|
||||
/* these objects have some binary data at the end */
|
||||
case WORD_TYPE:
|
||||
return sizeof(F_WORD) - CELLS * 3;
|
||||
case ALIEN_TYPE:
|
||||
return CELLS * 3;
|
||||
case DLL_TYPE:
|
||||
return CELLS * 2;
|
||||
case QUOTATION_TYPE:
|
||||
return sizeof(F_QUOTATION) - CELLS * 2;
|
||||
case STRING_TYPE:
|
||||
return sizeof(F_STRING);
|
||||
/* everything else consists entirely of pointers */
|
||||
case ARRAY_TYPE:
|
||||
return array_size(array_capacity((F_ARRAY*)pointer));
|
||||
case TUPLE_TYPE:
|
||||
tuple = untag_object(pointer);
|
||||
layout = untag_object(tuple->layout);
|
||||
return tuple_size(layout);
|
||||
case RATIO_TYPE:
|
||||
return sizeof(F_RATIO);
|
||||
case COMPLEX_TYPE:
|
||||
return sizeof(F_COMPLEX);
|
||||
case WRAPPER_TYPE:
|
||||
return sizeof(F_WRAPPER);
|
||||
default:
|
||||
critical_error("Invalid header",pointer);
|
||||
return -1; /* can't happen */
|
||||
}
|
||||
}
|
||||
|
||||
/* Push memory usage statistics in data heap */
|
||||
void primitive_data_room(void)
|
||||
{
|
||||
F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
|
||||
int gen;
|
||||
|
||||
dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
|
||||
dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
|
||||
|
||||
for(gen = 0; gen < data_heap->gen_count; gen++)
|
||||
{
|
||||
F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
|
||||
set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
|
||||
set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
|
||||
}
|
||||
|
||||
dpush(tag_object(a));
|
||||
}
|
||||
|
||||
/* Disables GC and activates next-object ( -- obj ) primitive */
|
||||
void begin_scan(void)
|
||||
{
|
||||
heap_scan_ptr = data_heap->generations[TENURED].start;
|
||||
gc_off = true;
|
||||
}
|
||||
|
||||
void primitive_begin_scan(void)
|
||||
{
|
||||
begin_scan();
|
||||
}
|
||||
|
||||
CELL next_object(void)
|
||||
{
|
||||
if(!gc_off)
|
||||
general_error(ERROR_HEAP_SCAN,F,F,NULL);
|
||||
|
||||
CELL value = get(heap_scan_ptr);
|
||||
CELL obj = heap_scan_ptr;
|
||||
CELL type;
|
||||
|
||||
if(heap_scan_ptr >= data_heap->generations[TENURED].here)
|
||||
return F;
|
||||
|
||||
type = untag_header(value);
|
||||
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
|
||||
|
||||
return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
|
||||
}
|
||||
|
||||
/* Push object at heap scan cursor and advance; pushes f when done */
|
||||
void primitive_next_object(void)
|
||||
{
|
||||
dpush(next_object());
|
||||
}
|
||||
|
||||
/* Re-enables GC */
|
||||
void primitive_end_scan(void)
|
||||
{
|
||||
gc_off = false;
|
||||
}
|
||||
|
||||
CELL find_all_words(void)
|
||||
{
|
||||
GROWABLE_ARRAY(words);
|
||||
|
||||
begin_scan();
|
||||
|
||||
CELL obj;
|
||||
while((obj = next_object()) != F)
|
||||
{
|
||||
if(type_of(obj) == WORD_TYPE)
|
||||
GROWABLE_ARRAY_ADD(words,obj);
|
||||
}
|
||||
|
||||
/* End heap scan */
|
||||
gc_off = false;
|
||||
|
||||
GROWABLE_ARRAY_TRIM(words);
|
||||
|
||||
return words;
|
||||
}
|
||||
|
|
@ -0,0 +1,138 @@
|
|||
/* Set by the -securegc command line argument */
|
||||
bool secure_gc;
|
||||
|
||||
/* generational copying GC divides memory into zones */
|
||||
typedef struct {
|
||||
/* allocation pointer is 'here'; its offset is hardcoded in the
|
||||
compiler backends*/
|
||||
CELL start;
|
||||
CELL here;
|
||||
CELL size;
|
||||
CELL end;
|
||||
} F_ZONE;
|
||||
|
||||
typedef struct {
|
||||
F_SEGMENT *segment;
|
||||
|
||||
CELL young_size;
|
||||
CELL aging_size;
|
||||
CELL tenured_size;
|
||||
|
||||
CELL gen_count;
|
||||
|
||||
F_ZONE *generations;
|
||||
F_ZONE* semispaces;
|
||||
|
||||
CELL *allot_markers;
|
||||
CELL *allot_markers_end;
|
||||
|
||||
CELL *cards;
|
||||
CELL *cards_end;
|
||||
|
||||
CELL *decks;
|
||||
CELL *decks_end;
|
||||
} F_DATA_HEAP;
|
||||
|
||||
F_DATA_HEAP *data_heap;
|
||||
|
||||
/* the 0th generation is where new objects are allocated. */
|
||||
#define NURSERY 0
|
||||
#define HAVE_NURSERY_P (data_heap->gen_count>1)
|
||||
/* where objects hang around */
|
||||
#define AGING (data_heap->gen_count-2)
|
||||
#define HAVE_AGING_P (data_heap->gen_count>2)
|
||||
/* the oldest generation */
|
||||
#define TENURED (data_heap->gen_count-1)
|
||||
|
||||
#define MIN_GEN_COUNT 1
|
||||
#define MAX_GEN_COUNT 3
|
||||
|
||||
/* new objects are allocated here */
|
||||
DLLEXPORT F_ZONE nursery;
|
||||
|
||||
INLINE bool in_zone(F_ZONE *z, CELL pointer)
|
||||
{
|
||||
return pointer >= z->start && pointer < z->end;
|
||||
}
|
||||
|
||||
CELL init_zone(F_ZONE *z, CELL size, CELL base);
|
||||
|
||||
void init_card_decks(void);
|
||||
|
||||
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes);
|
||||
|
||||
void dealloc_data_heap(F_DATA_HEAP *data_heap);
|
||||
|
||||
void clear_cards(CELL from, CELL to);
|
||||
void clear_decks(CELL from, CELL to);
|
||||
void clear_allot_markers(CELL from, CELL to);
|
||||
void reset_generation(CELL i);
|
||||
void reset_generations(CELL from, CELL to);
|
||||
|
||||
void set_data_heap(F_DATA_HEAP *data_heap_);
|
||||
|
||||
void init_data_heap(CELL gens,
|
||||
CELL young_size,
|
||||
CELL aging_size,
|
||||
CELL tenured_size,
|
||||
bool secure_gc_);
|
||||
|
||||
/* set up guard pages to check for under/overflow.
|
||||
size must be a multiple of the page size */
|
||||
F_SEGMENT *alloc_segment(CELL size);
|
||||
void dealloc_segment(F_SEGMENT *block);
|
||||
|
||||
CELL untagged_object_size(CELL pointer);
|
||||
CELL unaligned_object_size(CELL pointer);
|
||||
CELL object_size(CELL pointer);
|
||||
CELL binary_payload_start(CELL pointer);
|
||||
|
||||
void begin_scan(void);
|
||||
CELL next_object(void);
|
||||
|
||||
void primitive_data_room(void);
|
||||
void primitive_size(void);
|
||||
|
||||
void primitive_begin_scan(void);
|
||||
void primitive_next_object(void);
|
||||
void primitive_end_scan(void);
|
||||
|
||||
/* A heap walk allows useful things to be done, like finding all
|
||||
references to an object for debugging purposes. */
|
||||
CELL heap_scan_ptr;
|
||||
|
||||
/* GC is off during heap walking */
|
||||
bool gc_off;
|
||||
|
||||
INLINE bool in_data_heap_p(CELL ptr)
|
||||
{
|
||||
return (ptr >= data_heap->segment->start
|
||||
&& ptr <= data_heap->segment->end);
|
||||
}
|
||||
|
||||
INLINE void *allot_zone(F_ZONE *z, CELL a)
|
||||
{
|
||||
CELL h = z->here;
|
||||
z->here = h + align8(a);
|
||||
return (void*)h;
|
||||
}
|
||||
|
||||
CELL find_all_words(void);
|
||||
|
||||
/* Every object has a regular representation in the runtime, which makes GC
|
||||
much simpler. Every slot of the object until binary_payload_start is a pointer
|
||||
to some other object. */
|
||||
INLINE void do_slots(CELL obj, void (* iter)(CELL *))
|
||||
{
|
||||
CELL scan = obj;
|
||||
CELL payload_start = binary_payload_start(obj);
|
||||
CELL end = obj + payload_start;
|
||||
|
||||
scan += CELLS;
|
||||
|
||||
while(scan < end)
|
||||
{
|
||||
iter((CELL *)scan);
|
||||
scan += CELLS;
|
||||
}
|
||||
}
|
||||
|
|
@ -26,6 +26,8 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
|
|||
p->tenured_size,
|
||||
p->secure_gc);
|
||||
|
||||
clear_gc_stats();
|
||||
|
||||
F_ZONE *tenured = &data_heap->generations[TENURED];
|
||||
|
||||
F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
/* If a runtime function needs to call another function which potentially
|
||||
allocates memory, it must store any local variable references to Factor
|
||||
objects on the root stack */
|
||||
|
||||
/* GC locals: stores addresses of pointers to objects. The GC updates these
|
||||
pointers, so you can do
|
||||
|
||||
REGISTER_ROOT(some_local);
|
||||
|
||||
... allocate memory ...
|
||||
|
||||
foo(some_local);
|
||||
|
||||
...
|
||||
|
||||
UNREGISTER_ROOT(some_local); */
|
||||
F_SEGMENT *gc_locals_region;
|
||||
CELL gc_locals;
|
||||
|
||||
DEFPUSHPOP(gc_local_,gc_locals)
|
||||
|
||||
#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
|
||||
#define UNREGISTER_ROOT(obj) \
|
||||
{ \
|
||||
if(gc_local_pop() != (CELL)&obj) \
|
||||
critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
|
||||
}
|
||||
|
||||
/* Extra roots: stores pointers to objects in the heap. Requires extra work
|
||||
(you have to unregister before accessing the object) but more flexible. */
|
||||
F_SEGMENT *extra_roots_region;
|
||||
CELL extra_roots;
|
||||
|
||||
DEFPUSHPOP(root_,extra_roots)
|
||||
|
||||
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
|
||||
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
|
||||
|
||||
/* We ignore strings which point outside the data heap, but we might be given
|
||||
a char* which points inside the data heap, in which case it is a root, for
|
||||
example if we call unbox_char_string() the result is placed in a byte array */
|
||||
INLINE bool root_push_alien(const void *ptr)
|
||||
{
|
||||
if(in_data_heap_p((CELL)ptr))
|
||||
{
|
||||
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
|
||||
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
|
||||
{
|
||||
root_push(tag_object(objptr));
|
||||
return true;
|
||||
}
|
||||
}
|
||||
|
||||
return false;
|
||||
}
|
||||
|
||||
#define REGISTER_C_STRING(obj) \
|
||||
bool obj##_root = root_push_alien(obj)
|
||||
#define UNREGISTER_C_STRING(obj) \
|
||||
if(obj##_root) obj = alien_offset(root_pop())
|
||||
|
||||
#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
|
||||
#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))
|
||||
|
|
@ -25,6 +25,9 @@
|
|||
#include "errors.h"
|
||||
#include "bignumint.h"
|
||||
#include "bignum.h"
|
||||
#include "write_barrier.h"
|
||||
#include "data_heap.h"
|
||||
#include "local_roots.h"
|
||||
#include "data_gc.h"
|
||||
#include "debug.h"
|
||||
#include "types.h"
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ void *primitives[] = {
|
|||
primitive_resize_byte_array,
|
||||
primitive_dll_validp,
|
||||
primitive_unimplemented,
|
||||
primitive_gc_reset,
|
||||
primitive_clear_gc_stats,
|
||||
primitive_jit_compile,
|
||||
primitive_load_locals,
|
||||
};
|
||||
|
|
|
|||
|
|
@ -0,0 +1,66 @@
|
|||
/* card marking write barrier. a card is a byte storing a mark flag,
|
||||
and the offset (in cells) of the first object in the card.
|
||||
|
||||
the mark flag is set by the write barrier when an object in the
|
||||
card has a slot written to.
|
||||
|
||||
the offset of the first object is set by the allocator. */
|
||||
|
||||
/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
|
||||
#define CARD_POINTS_TO_NURSERY 0x80
|
||||
#define CARD_POINTS_TO_AGING 0x40
|
||||
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
|
||||
typedef u8 F_CARD;
|
||||
|
||||
#define CARD_BITS 8
|
||||
#define CARD_SIZE (1<<CARD_BITS)
|
||||
#define ADDR_CARD_MASK (CARD_SIZE-1)
|
||||
|
||||
DLLEXPORT CELL cards_offset;
|
||||
|
||||
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
|
||||
#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
|
||||
|
||||
typedef u8 F_DECK;
|
||||
|
||||
#define DECK_BITS (CARD_BITS + 10)
|
||||
#define DECK_SIZE (1<<DECK_BITS)
|
||||
#define ADDR_DECK_MASK (DECK_SIZE-1)
|
||||
|
||||
DLLEXPORT CELL decks_offset;
|
||||
|
||||
#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
|
||||
#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
|
||||
|
||||
#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
|
||||
|
||||
#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
|
||||
#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
|
||||
|
||||
#define INVALID_ALLOT_MARKER 0xff
|
||||
|
||||
DLLEXPORT CELL allot_markers_offset;
|
||||
|
||||
/* the write barrier must be called any time we are potentially storing a
|
||||
pointer from an older generation to a younger one */
|
||||
INLINE void write_barrier(CELL address)
|
||||
{
|
||||
*ADDR_TO_CARD(address) = CARD_MARK_MASK;
|
||||
*ADDR_TO_DECK(address) = CARD_MARK_MASK;
|
||||
}
|
||||
|
||||
#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
|
||||
|
||||
INLINE void set_slot(CELL obj, CELL slot, CELL value)
|
||||
{
|
||||
put(SLOT(obj,slot),value);
|
||||
write_barrier(obj);
|
||||
}
|
||||
|
||||
/* we need to remember the first object allocated in the card */
|
||||
INLINE void allot_barrier(CELL address)
|
||||
{
|
||||
F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
|
||||
if(*ptr == INVALID_ALLOT_MARKER)
|
||||
*ptr = (address & ADDR_CARD_MASK);
|
||||
}
|
||||
Loading…
Reference in New Issue