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 \
! 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
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." } ;
] [ 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
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)
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);
#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)
{
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;
copy_handle(&stacks->catchstack_save);
copy_handle(&stacks->current_callback_save);
- copy_callstack_roots(stacks);
+ mark_active_blocks(stacks);
stacks = stacks->next;
}
*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;
}
}
- do_code_slots(scan);
+ mark_object_code_block(scan);
return scan + untagged_object_size(scan);
}
}
}
-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)
{
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)
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;
-}
-/* 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;
-/* 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;
-}
+F_ZONE *newspace;
+bool performing_gc;
+CELL collecting_gen;
-CELL init_zone(F_ZONE *z, CELL size, CELL base);
+/* 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;
-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 {
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;
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. */
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 */
* 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;
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);
--- /dev/null
+#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;
+}
--- /dev/null
+/* 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;
+ }
+}
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);
--- /dev/null
+/* 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()))
#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"
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,
- primitive_gc_reset,
+ primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
};
--- /dev/null
+/* 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);
+}
projects / factor.git / commitdiff