vm/debug.o \
vm/factor.o \
vm/ffi_test.o \
- vm/heap.o \
vm/image.o \
vm/io.o \
vm/math.o \
- vm/memory.o \
+ vm/data_gc.o \
+ vm/code_gc.o \
vm/primitives.o \
vm/run.o \
vm/stack.o \
- signal 4 on datastack underflow on mac intel??
- test alien-indirect
- code GC:
- - discard the free block at the end of the code heap on save
- minor GC takes too long now, card mark
+ ui:
\ setenv { object fixnum } { } <effect> "infer-effect" set-word-prop
\ stat { string } { object } <effect> "infer-effect" set-word-prop
\ (directory) { string } { array } <effect> "infer-effect" set-word-prop
-\ gc { integer } { } <effect> "infer-effect" set-word-prop
+\ gc { integer object } { } <effect> "infer-effect" set-word-prop
\ gc-time { } { integer } <effect> "infer-effect" set-word-prop
\ save-image { string } { } <effect> "infer-effect" set-word-prop
\ exit { integer } { } <effect> "infer-effect" set-word-prop
kernel-internals math namespaces parser prettyprint sequences
strings styles vectors words ;
-: full-gc ( -- ) generations 1- gc ;
+: full-gc ( -- ) generations 1- f gc ;
! Printing an overview of heap usage.
--- /dev/null
+#include "factor.h"
+
+/* This malloc-style heap code is reasonably generic. Maybe in the future, it
+will be used for the data heap too, if we ever get incremental
+mark/sweep/compact GC. */
+void new_heap(HEAP *heap, CELL size)
+{
+ heap->base = (CELL)(alloc_bounded_block(size)->start);
+ if(heap->base == 0)
+ fatal_error("Cannot allocate code heap",size);
+ heap->limit = heap->base + size;
+ heap->free_list = NULL;
+}
+
+void init_code_heap(CELL size)
+{
+ new_heap(&compiling,size);
+}
+
+INLINE void update_free_list(HEAP *heap, F_BLOCK *prev, F_BLOCK *next_free)
+{
+ if(prev)
+ prev->next_free = next_free;
+ else
+ heap->free_list = next_free;
+}
+
+/* called after reading the code heap from the image file. we must build the
+free list, and add a large free block from compiling.base + size to
+compiling.limit. */
+void build_free_list(HEAP *heap, CELL size)
+{
+ F_BLOCK *prev = NULL;
+ F_BLOCK *scan = (F_BLOCK *)heap->base;
+ F_BLOCK *end = (F_BLOCK *)(heap->base + size);
+
+ while(scan && scan < end)
+ {
+ if(scan->status == B_FREE)
+ {
+ update_free_list(heap,prev,scan);
+ prev = scan;
+ }
+
+ scan = next_block(heap,scan);
+ }
+
+ if((CELL)(end + 1) <= heap->limit)
+ {
+ end->status = B_FREE;
+ end->next_free = NULL;
+ end->size = heap->limit - (CELL)end;
+ }
+ else
+ {
+ end = NULL;
+
+ if(prev)
+ prev->size = heap->limit - (CELL)prev;
+ }
+
+ update_free_list(heap,prev,end);
+}
+
+CELL heap_allot(HEAP *heap, CELL size)
+{
+ F_BLOCK *prev = NULL;
+ F_BLOCK *scan = heap->free_list;
+
+ while(scan)
+ {
+ CELL this_size = scan->size - sizeof(F_BLOCK);
+
+ if(this_size < size)
+ {
+ prev = scan;
+ scan = scan->next_free;
+ continue;
+ }
+
+ /* we found a candidate block */
+ F_BLOCK *next_free;
+
+ if(this_size - size <= sizeof(F_BLOCK))
+ {
+ /* too small to be split */
+ next_free = scan->next_free;
+ }
+ else
+ {
+ /* split the block in two */
+ CELL new_size = size + sizeof(F_BLOCK);
+ F_BLOCK *split = (F_BLOCK *)((CELL)scan + new_size);
+ split->status = B_FREE;
+ split->size = scan->size - new_size;
+ split->next_free = scan->next_free;
+ scan->size = new_size;
+ next_free = split;
+ }
+
+ /* update the free list */
+ update_free_list(heap,prev,next_free);
+
+ /* this is our new block */
+ scan->status = B_ALLOCATED;
+
+ return (CELL)(scan + 1);
+ }
+
+ if(heap->base == 0)
+ critical_error("Code heap is full",size);
+
+ return 0; /* can't happen */
+}
+
+/* free blocks which are allocated and not marked */
+void free_unmarked(HEAP *heap)
+{
+ F_BLOCK *prev = NULL;
+ F_BLOCK *scan = (F_BLOCK *)heap->base;
+
+ while(scan)
+ {
+ if(scan->status == B_ALLOCATED)
+ {
+ /* merge blocks? */
+ if(next_block(heap,prev) == scan)
+ prev->size += scan->size;
+ else
+ {
+ scan->status = B_FREE;
+ update_free_list(heap,prev,scan);
+ prev = scan;
+ }
+ }
+
+ scan = next_block(heap,scan);
+ }
+
+ if(prev)
+ prev->next_free = NULL;
+}
+
+CELL heap_free_space(HEAP *heap)
+{
+ CELL size = 0;
+ F_BLOCK *scan = (F_BLOCK *)heap->base;
+
+ while(scan)
+ {
+ if(scan->status == B_FREE)
+ size += scan->size;
+ scan = next_block(heap,scan);
+ }
+
+ return size;
+}
+
+CELL heap_size(HEAP *heap)
+{
+ CELL start = heap->base;
+ F_BLOCK *scan = (F_BLOCK *)start;
+ while(next_block(heap,scan))
+ scan = next_block(heap,scan);
+ return (CELL)scan - (CELL)start;
+}
+
+void iterate_code_heap(CODE_HEAP_ITERATOR iter)
+{
+ F_BLOCK *scan = (F_BLOCK *)compiling.base;
+
+ while(scan)
+ {
+ if(scan->status != B_FREE)
+ iterate_code_heap_step((F_COMPILED *)(scan + 1),iter);
+ scan = next_block(&compiling,scan);
+ }
+}
+
+void collect_literals_step(F_COMPILED *relocating, CELL code_start,
+ CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
+{
+ CELL scan;
+
+ CELL literal_end = literal_start + relocating->literal_length;
+
+ for(scan = literal_start; scan < literal_end; scan += CELLS)
+ copy_handle((CELL*)scan);
+
+ if(!relocating->finalized)
+ {
+ for(scan = words_start; scan < words_end; scan += CELLS)
+ copy_handle((CELL*)scan);
+ }
+}
+
+void collect_literals(void)
+{
+ iterate_code_heap(collect_literals_step);
+}
+
+void mark_sweep_step(F_COMPILED *compiled, CELL code_start,
+ CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
+{
+ CELL scan;
+
+ if(compiled->finalized)
+ {
+ for(scan = words_start; scan < words_end; scan += CELLS)
+ mark_and_sweep(get(scan));
+ }
+}
+
+void mark_and_sweep(CELL xt)
+{
+ F_BLOCK *block = xt_to_block(xt);
+
+ if(block->status == B_MARKED)
+ return;
+ else if(block->status == B_FREE)
+ critical_error("Marking a free block",(CELL)block);
+
+ block->status = B_MARKED;
+
+ F_COMPILED *compiled = xt_to_compiled(xt);
+ iterate_code_heap_step(compiled,collect_literals_step);
+ iterate_code_heap_step(compiled,mark_sweep_step);
+}
+
+void primitive_code_room(void)
+{
+ box_unsigned_cell(heap_free_space(&compiling));
+ box_unsigned_cell(compiling.limit - compiling.base);
+}
--- /dev/null
+typedef enum
+{
+ B_FREE,
+ B_ALLOCATED,
+ B_MARKED
+} F_BLOCK_STATUS;
+
+typedef struct _F_BLOCK
+{
+ F_BLOCK_STATUS status;
+ CELL size;
+ struct _F_BLOCK *next_free;
+} F_BLOCK;
+
+typedef struct {
+ CELL base;
+ CELL limit;
+ F_BLOCK *free_list;
+} HEAP;
+
+void new_heap(HEAP *heap, CELL size);
+void build_free_list(HEAP *heap, CELL size);
+CELL heap_allot(HEAP *heap, CELL size);
+void free_unmarked(HEAP *heap);
+CELL heap_free_space(HEAP *heap);
+CELL heap_size(HEAP *heap);
+
+INLINE F_BLOCK *next_block(HEAP *heap, F_BLOCK *block)
+{
+ CELL next = ((CELL)block + block->size);
+ if(next == heap->limit)
+ return NULL;
+ else
+ return (F_BLOCK *)next;
+}
+
+/* compiled code */
+HEAP compiling;
+
+/* The compiled code heap is structured into blocks. */
+typedef struct
+{
+ CELL code_length; /* # bytes */
+ CELL reloc_length; /* # bytes */
+ CELL literal_length; /* # bytes */
+ CELL words_length; /* # bytes */
+ CELL finalized; /* has finalize_code_block() been called on this yet? */
+} F_COMPILED;
+
+typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
+ CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end);
+
+void init_code_heap(CELL size);
+
+void iterate_code_heap(CODE_HEAP_ITERATOR iter);
+
+void collect_literals(void);
+
+void mark_and_sweep(CELL xt);
+
+void primitive_code_room(void);
+
+INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
+{
+ CELL code_start = (CELL)(compiled + 1);
+ CELL reloc_start = code_start + compiled->code_length;
+ CELL literal_start = reloc_start + compiled->reloc_length;
+ CELL words_start = literal_start + compiled->literal_length;
+ CELL words_end = words_start + compiled->words_length;
+
+ iter(compiled,code_start,reloc_start,literal_start,words_start,words_end);
+}
+
+INLINE F_BLOCK *xt_to_block(CELL xt)
+{
+ return (F_BLOCK *)(xt - sizeof(F_BLOCK) - sizeof(F_COMPILED));
+}
+
+INLINE F_COMPILED *xt_to_compiled(CELL xt)
+{
+ return (F_COMPILED *)(xt - sizeof(F_COMPILED));
+}
#include "factor.h"
-void init_compiler(CELL size)
-{
- new_heap(&compiling,size);
-}
-
-INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
-{
- CELL code_start = (CELL)(compiled + 1);
- CELL reloc_start = code_start + compiled->code_length;
- CELL literal_start = reloc_start + compiled->reloc_length;
- CELL words_start = literal_start + compiled->literal_length;
-
- iter(compiled,code_start,reloc_start,literal_start,words_start);
-}
-
-void iterate_code_heap(CODE_HEAP_ITERATOR iter)
-{
- F_BLOCK *scan = (F_BLOCK *)compiling.base;
-
- while(scan)
- {
- if(scan->status != B_FREE)
- iterate_code_heap_step((F_COMPILED *)(scan + 1),iter);
- scan = next_block(&compiling,scan);
- }
-}
-
void undefined_symbol(void)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
}
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literal_start, CELL words_start)
+ CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
{
F_REL *rel = (F_REL *)reloc_start;
F_REL *rel_end = (F_REL *)literal_start;
}
void finalize_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literal_start, CELL words_start)
+ CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
{
- CELL words_end = words_start + relocating->words_length;
-
CELL scan;
for(scan = words_start; scan < words_end; scan += CELLS)
relocating->finalized = true;
relocate_code_block(relocating,code_start,reloc_start,
- literal_start,words_start);
+ literal_start,words_start,words_end);
flush_icache(code_start,reloc_start - code_start);
}
-void collect_literals_step(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literal_start, CELL words_start)
-{
- CELL scan;
-
- CELL literal_end = literal_start + relocating->literal_length;
- CELL words_end = words_start + relocating->words_length;
-
- for(scan = literal_start; scan < literal_end; scan += CELLS)
- copy_handle((CELL*)scan);
-
- for(scan = words_start; scan < words_end; scan += CELLS)
- {
- if(!relocating->finalized)
- copy_handle((CELL*)scan);
- }
-}
-
-void collect_literals(void)
-{
- iterate_code_heap(collect_literals_step);
-}
-
void deposit_integers(CELL here, F_VECTOR *vector, CELL format)
{
CELL count = untag_fixnum_fast(vector->top);
{
F_ARRAY *pair = untag_array(get(AREF(array,i)));
CELL xt = to_cell(get(AREF(pair,1)));
- iterate_code_heap_step((F_COMPILED*)xt - 1,finalize_code_block);
+ iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
}
}
-
-void primitive_code_room(void)
-{
- box_unsigned_cell(heap_free_space(&compiling));
- box_unsigned_cell(compiling.limit - compiling.base);
-}
-/* compiled code */
-HEAP compiling;
-
-/* The compiled code heap is structured into blocks. */
-typedef struct
-{
- CELL code_length; /* # bytes */
- CELL reloc_length; /* # bytes */
- CELL literal_length; /* # bytes */
- CELL words_length; /* # bytes */
- CELL finalized; /* has finalize_code_block() been called on this yet? */
-} F_COMPILED;
-
-typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literal_start, CELL words_start);
-
-void iterate_code_heap(CODE_HEAP_ITERATOR iter);
-
typedef enum {
/* arg is a primitive number */
RT_PRIMITIVE,
} F_REL;
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literal_start, CELL words_start);
-void collect_literals(void);
-void init_compiler(CELL size);
+ CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end);
void primitive_add_compiled_block(void);
void primitive_finalize_compile(void);
-void primitive_code_room(void);
--- /dev/null
+#include "factor.h"
+
+/* this function tests if a given faulting location is in a poison page. The
+page address is taken from area + round_up_to_page_size(area_size) +
+ pagesize*offset */
+bool in_page(void *fault, void *i_area, CELL area_size, int offset)
+{
+ const int pagesize = getpagesize();
+ intptr_t area = (intptr_t) i_area;
+ area += pagesize * ((area_size + (pagesize - 1)) / pagesize);
+ area += offset * pagesize;
+
+ const int page = area / pagesize;
+ const int fault_page = (intptr_t)fault / pagesize;
+ return page == fault_page;
+}
+
+void *safe_malloc(size_t size)
+{
+ void *ptr = malloc(size);
+ if(ptr == 0)
+ fatal_error("malloc() failed", 0);
+ return ptr;
+}
+
+CELL object_size(CELL tagged)
+{
+ if(tagged == F || TAG(tagged) == FIXNUM_TYPE)
+ return 0;
+ else
+ return untagged_object_size(UNTAG(tagged));
+}
+
+CELL untagged_object_size(CELL pointer)
+{
+ return align8(unaligned_object_size(pointer));
+}
+
+CELL unaligned_object_size(CELL pointer)
+{
+ switch(untag_header(get(pointer)))
+ {
+ case WORD_TYPE:
+ return sizeof(F_WORD);
+ case ARRAY_TYPE:
+ case TUPLE_TYPE:
+ case BIGNUM_TYPE:
+ case BYTE_ARRAY_TYPE:
+ case QUOTATION_TYPE:
+ return array_size(array_capacity((F_ARRAY*)(pointer)));
+ case HASHTABLE_TYPE:
+ return sizeof(F_HASHTABLE);
+ case VECTOR_TYPE:
+ return sizeof(F_VECTOR);
+ case STRING_TYPE:
+ return string_size(string_capacity((F_STRING*)(pointer)));
+ case SBUF_TYPE:
+ return sizeof(F_SBUF);
+ 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(DLL);
+ case ALIEN_TYPE:
+ return sizeof(ALIEN);
+ case WRAPPER_TYPE:
+ return sizeof(F_WRAPPER);
+ default:
+ critical_error("Cannot determine untagged_object_size",pointer);
+ return -1; /* can't happen */
+ }
+}
+
+void primitive_size(void)
+{
+ drepl(tag_fixnum(object_size(dpeek())));
+}
+
+/* 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)
+{
+ switch(untag_header(get(pointer)))
+ {
+ /* these objects do not refer to other objects at all */
+ case STRING_TYPE:
+ case FLOAT_TYPE:
+ case BYTE_ARRAY_TYPE:
+ case BIGNUM_TYPE:
+ return 0;
+ /* these objects have some binary data at the end */
+ case WORD_TYPE:
+ return sizeof(F_WORD) - CELLS;
+ case ALIEN_TYPE:
+ case DLL_TYPE:
+ return CELLS * 2;
+ /* everything else consists entirely of pointers */
+ default:
+ return unaligned_object_size(pointer);
+ }
+}
+
+void primitive_data_room(void)
+{
+ F_ARRAY *a = array(ARRAY_TYPE,gen_count,F);
+ int gen;
+ box_unsigned_cell(cards_end - cards);
+ box_unsigned_cell(prior.limit - prior.base);
+ for(gen = 0; gen < gen_count; gen++)
+ {
+ ZONE *z = &generations[gen];
+ put(AREF(a,gen),make_array_2(tag_cell(z->limit - z->here),
+ tag_cell(z->limit - z->base)));
+ }
+ dpush(tag_object(a));
+}
+
+/* Disables GC and activates next-object ( -- obj ) primitive */
+void primitive_begin_scan(void)
+{
+ garbage_collection(TENURED,false);
+ heap_scan_ptr = tenured.base;
+ heap_scan = true;
+}
+
+/* Push object at heap scan cursor and advance; pushes f when done */
+void primitive_next_object(void)
+{
+ CELL value = get(heap_scan_ptr);
+ CELL obj = heap_scan_ptr;
+ CELL type;
+
+ if(!heap_scan)
+ general_error(ERROR_HEAP_SCAN,F,F,true);
+
+ if(heap_scan_ptr >= tenured.here)
+ {
+ dpush(F);
+ return;
+ }
+
+ type = untag_header(value);
+ heap_scan_ptr += untagged_object_size(heap_scan_ptr);
+
+ if(type <= HEADER_TYPE)
+ dpush(RETAG(obj,type));
+ else
+ dpush(RETAG(obj,OBJECT_TYPE));
+}
+
+/* Re-enables GC */
+void primitive_end_scan(void)
+{
+ heap_scan = false;
+}
+
+/* scan all the objects in the card */
+INLINE void collect_card(CARD *ptr, CELL here)
+{
+ CARD c = *ptr;
+ CELL offset = (c & CARD_BASE_MASK);
+ CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
+ CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
+
+ if(offset == 0x7f)
+ {
+ if(c == 0xff)
+ critical_error("bad card",(CELL)ptr);
+ else
+ return;
+ }
+
+ while(card_scan < card_end && card_scan < here)
+ card_scan = collect_next(card_scan);
+
+ cards_scanned++;
+}
+
+INLINE void collect_gen_cards(CELL gen)
+{
+ CARD *ptr = ADDR_TO_CARD(generations[gen].base);
+ CELL here = generations[gen].here;
+ CARD *last_card = ADDR_TO_CARD(here);
+
+ if(generations[gen].here == generations[gen].limit)
+ last_card--;
+
+ for(; ptr <= last_card; ptr++)
+ {
+ if(card_marked(*ptr))
+ collect_card(ptr,here);
+ }
+}
+
+void unmark_cards(CELL from, CELL to)
+{
+ CARD *ptr = ADDR_TO_CARD(generations[from].base);
+ CARD *last_card = ADDR_TO_CARD(generations[to].here);
+ if(generations[to].here == generations[to].limit)
+ last_card--;
+ for(; ptr <= last_card; ptr++)
+ unmark_card(ptr);
+}
+
+void clear_cards(CELL from, CELL to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ CARD *last_card = ADDR_TO_CARD(generations[from].limit);
+ CARD *ptr = ADDR_TO_CARD(generations[to].base);
+ for(; ptr < last_card; ptr++)
+ clear_card(ptr);
+}
+
+/* scan cards in all generations older than the one being collected */
+void collect_cards(CELL gen)
+{
+ int i;
+ for(i = gen + 1; i < gen_count; i++)
+ collect_gen_cards(i);
+}
+
+/* Generational copying garbage collector */
+
+CELL init_zone(ZONE *z, CELL size, CELL base)
+{
+ z->base = z->here = base;
+ z->limit = z->base + size;
+ z->alarm = z->base + (size * 3) / 4;
+ return z->limit;
+}
+
+/* update this global variable. since it is stored in a non-volatile register,
+we need to save its contents and re-initialize it when entering a callback,
+and restore its contents when leaving the callback. see stack.c */
+void update_cards_offset(void)
+{
+ cards_offset = (CELL)cards - (data_heap_start >> CARD_BITS);
+}
+
+/* input parameters must be 8 byte aligned */
+/* the data heap layout is important:
+- two semispaces: tenured and prior
+- younger generations follow
+there are two reasons for this:
+- we can easily check if a pointer is in some generation or a younger one
+- the nursery grows into the guard page, so allot() does not have to
+check for out of memory, whereas allot_zone() (used by the GC) longjmp()s
+back to collecting a higher generation */
+void init_data_heap(CELL gens, CELL young_size, CELL aging_size)
+{
+ int i;
+ CELL alloter;
+
+ CELL total_size = (gens - 1) * young_size + 2 * aging_size;
+ CELL cards_size = total_size / CARD_SIZE;
+
+ gen_count = gens;
+ generations = safe_malloc(sizeof(ZONE) * gen_count);
+
+ data_heap_start = (CELL)(alloc_bounded_block(total_size)->start);
+ data_heap_end = data_heap_start + total_size;
+
+ cards = safe_malloc(cards_size);
+ cards_end = cards + cards_size;
+ update_cards_offset();
+
+ alloter = data_heap_start;
+
+ alloter = init_zone(&tenured,aging_size,alloter);
+ alloter = init_zone(&prior,aging_size,alloter);
+
+ for(i = gen_count - 2; i >= 0; i--)
+ alloter = init_zone(&generations[i],young_size,alloter);
+
+ clear_cards(NURSERY,TENURED);
+
+ if(alloter != data_heap_start + total_size)
+ fatal_error("Oops",alloter);
+
+ heap_scan = false;
+ gc_time = 0;
+ minor_collections = 0;
+ cards_scanned = 0;
+}
+
+void collect_callframe_triple(CELL *callframe,
+ CELL *callframe_scan, CELL *callframe_end)
+{
+ *callframe_scan -= *callframe;
+ *callframe_end -= *callframe;
+ copy_handle(callframe);
+ *callframe_scan += *callframe;
+ *callframe_end += *callframe;
+}
+
+void collect_stack(BOUNDED_BLOCK *region, CELL top)
+{
+ CELL bottom = region->start;
+ CELL ptr;
+
+ for(ptr = bottom; ptr <= top; ptr += CELLS)
+ copy_handle((CELL*)ptr);
+}
+
+void collect_callstack(BOUNDED_BLOCK *region, CELL top)
+{
+ CELL bottom = region->start;
+ CELL ptr;
+
+ for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
+ collect_callframe_triple((CELL*)ptr,
+ (CELL*)ptr + 1, (CELL*)ptr + 2);
+}
+
+void collect_roots(void)
+{
+ int i;
+ STACKS *stacks;
+
+ copy_handle(&T);
+ copy_handle(&bignum_zero);
+ copy_handle(&bignum_pos_one);
+ copy_handle(&bignum_neg_one);
+ collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
+
+ save_stacks();
+ stacks = stack_chain;
+
+ while(stacks)
+ {
+ collect_stack(stacks->data_region,stacks->data);
+ collect_stack(stacks->retain_region,stacks->retain);
+
+ collect_callstack(stacks->call_region,stacks->call);
+
+ if(stacks->next != NULL)
+ {
+ collect_callframe_triple(&stacks->callframe,
+ &stacks->callframe_scan,&stacks->callframe_end);
+ }
+
+ copy_handle(&stacks->catch_save);
+
+ stacks = stacks->next;
+ }
+
+ for(i = 0; i < USER_ENV; i++)
+ copy_handle(&userenv[i]);
+}
+
+/* Given a pointer to oldspace, copy it to newspace. */
+INLINE void *copy_untagged_object(void *pointer, CELL size)
+{
+ void *newpointer;
+ if(newspace->here + size >= newspace->limit)
+ longjmp(gc_jmp,1);
+ newpointer = allot_zone(newspace,size);
+ memcpy(newpointer,pointer,size);
+ return newpointer;
+}
+
+INLINE CELL copy_object_impl(CELL pointer)
+{
+ CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
+ object_size(pointer));
+
+ /* install forwarding pointer */
+ put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
+
+ return newpointer;
+}
+
+/* follow a chain of forwarding pointers */
+CELL resolve_forwarding(CELL untagged, CELL tag)
+{
+ CELL header = get(untagged);
+ /* another forwarding pointer */
+ if(TAG(header) == GC_COLLECTED)
+ return resolve_forwarding(UNTAG(header),tag);
+ /* we've found the destination */
+ else
+ {
+ CELL pointer = RETAG(untagged,tag);
+ if(should_copy(untagged))
+ pointer = RETAG(copy_object_impl(pointer),tag);
+ return pointer;
+ }
+}
+
+/*
+Given a pointer to a tagged pointer to oldspace, copy it to newspace.
+If the object has already been copied, return the forwarding
+pointer address without copying anything; otherwise, install
+a new forwarding pointer.
+*/
+CELL copy_object(CELL pointer)
+{
+ CELL tag;
+ CELL header;
+
+ if(pointer == F)
+ return F;
+
+ tag = TAG(pointer);
+
+ if(tag == FIXNUM_TYPE)
+ return pointer;
+
+ header = get(UNTAG(pointer));
+ if(TAG(header) == GC_COLLECTED)
+ return resolve_forwarding(UNTAG(header),tag);
+ else
+ return RETAG(copy_object_impl(pointer),tag);
+}
+
+INLINE void collect_object(CELL scan)
+{
+ CELL payload_start = binary_payload_start(scan);
+ CELL end = scan + payload_start;
+
+ scan += CELLS;
+
+ while(scan < end)
+ {
+ copy_handle((CELL*)scan);
+ scan += CELLS;
+ }
+}
+
+CELL collect_next(CELL scan)
+{
+ CELL size = untagged_object_size(scan);
+ collect_object(scan);
+ return scan + size;
+}
+
+void reset_generations(CELL from, CELL to)
+{
+ CELL i;
+ for(i = from; i <= to; i++)
+ generations[i].here = generations[i].base;
+ clear_cards(from,to);
+}
+
+void begin_gc(CELL gen)
+{
+ collecting_gen = gen;
+ collecting_gen_start = generations[gen].base;
+
+ if(gen == TENURED)
+ {
+ /* when collecting the oldest generation, rotate it
+ with the semispace */
+ ZONE z = generations[gen];
+ generations[gen] = prior;
+ prior = z;
+ generations[gen].here = generations[gen].base;
+ newspace = &generations[gen];
+ clear_cards(TENURED,TENURED);
+ }
+ else
+ {
+ /* when collecting a younger generation, we copy
+ reachable objects to the next oldest generation,
+ so we set the newspace so the next generation. */
+ newspace = &generations[gen + 1];
+ }
+}
+
+void end_gc(CELL gen)
+{
+ if(gen == TENURED)
+ {
+ /* we did a full collection; no more
+ old-to-new pointers remain since everything
+ is in tenured space */
+ unmark_cards(TENURED,TENURED);
+ /* all generations except tenured space are
+ now empty */
+ reset_generations(NURSERY,TENURED - 1);
+
+ fprintf(stderr,"*** Data GC (%ld minor, %ld cards)\n",
+ minor_collections,cards_scanned);
+ minor_collections = 0;
+ cards_scanned = 0;
+ }
+ else
+ {
+ /* we collected a younger generation. so the
+ next-oldest generation no longer has any
+ pointers into the younger generation (the
+ younger generation is empty!) */
+ unmark_cards(gen + 1,gen + 1);
+ /* all generations up to and including the one
+ collected are now empty */
+ reset_generations(NURSERY,gen);
+
+ minor_collections++;
+ }
+}
+
+/* collect gen and all younger generations */
+void garbage_collection(CELL gen, bool code_gc)
+{
+ s64 start = current_millis();
+ CELL scan;
+
+ if(heap_scan)
+ critical_error("GC disabled during heap scan",gen);
+
+ /* we come back here if a generation is full */
+ if(setjmp(gc_jmp))
+ {
+ if(gen == TENURED)
+ {
+ /* oops, out of memory */
+ critical_error("Out of memory",0);
+ }
+ else
+ gen++;
+ }
+
+ begin_gc(gen);
+
+ /* initialize chase pointer */
+ scan = newspace->here;
+
+ /* collect objects referenced from stacks and environment */
+ collect_roots();
+
+ /* collect objects referenced from older generations */
+ collect_cards(gen);
+
+ /* collect literal objects referenced from compiled code */
+ collect_literals();
+
+ while(scan < newspace->here)
+ scan = collect_next(scan);
+
+ end_gc(gen);
+
+ gc_time += (current_millis() - start);
+}
+
+void primitive_gc(void)
+{
+ bool code_gc = unbox_boolean();
+ CELL gen = to_fixnum(dpop());
+ if(gen <= NURSERY || code_gc)
+ gen = NURSERY;
+ else if(gen >= TENURED)
+ gen = TENURED;
+ garbage_collection(gen,code_gc);
+}
+
+/* WARNING: only call this from a context where all local variables
+are also reachable via the GC roots. */
+void maybe_gc(CELL size)
+{
+ if(nursery.here + size > nursery.alarm)
+ {
+ CELL gen = NURSERY;
+ while(gen < TENURED)
+ {
+ ZONE *z = &generations[gen + 1];
+ if(z->here < z->alarm)
+ break;
+ gen++;
+ }
+
+ garbage_collection(gen,false);
+ }
+}
+
+void simple_gc(void)
+{
+ maybe_gc(0);
+}
+
+void primitive_gc_time(void)
+{
+ simple_gc();
+ dpush(tag_bignum(s48_long_long_to_bignum(gc_time)));
+}
--- /dev/null
+bool in_page(void *fault, void *i_area, CELL area_size, int offset);
+
+void *safe_malloc(size_t size);
+
+typedef struct {
+ CELL start;
+ CELL size;
+} BOUNDED_BLOCK;
+
+/* set up guard pages to check for under/overflow.
+size must be a multiple of the page size */
+BOUNDED_BLOCK *alloc_bounded_block(CELL size);
+void dealloc_bounded_block(BOUNDED_BLOCK *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 primitive_data_room(void);
+void primitive_size(void);
+void primitive_begin_scan(void);
+void primitive_next_object(void);
+void primitive_end_scan(void);
+
+CELL data_heap_start;
+CELL data_heap_end;
+
+/* 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.
+*/
+#define CARD_MARK_MASK 0x80
+#define CARD_BASE_MASK 0x7f
+typedef u8 CARD;
+
+CARD *cards;
+CARD *cards_end;
+
+/* A card is 16 bytes (128 bits), 5 address bits per card.
+it is important that 7 bits is sufficient to represent every
+offset within the card */
+#define CARD_SIZE 128
+#define CARD_BITS 7
+#define ADDR_CARD_MASK (CARD_SIZE-1)
+
+INLINE CARD card_marked(CARD c)
+{
+ return c & CARD_MARK_MASK;
+}
+
+INLINE void unmark_card(CARD *c)
+{
+ *c &= CARD_BASE_MASK;
+}
+
+INLINE void clear_card(CARD *c)
+{
+ *c = CARD_BASE_MASK; /* invalid value */
+}
+
+INLINE u8 card_base(CARD c)
+{
+ return c & CARD_BASE_MASK;
+}
+
+#define ADDR_TO_CARD(a) (CARD*)(((CELL)a >> CARD_BITS) + cards_offset)
+#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)<<CARD_BITS)
+
+/* this is an inefficient write barrier. compiled definitions use a more
+efficient one hand-coded in assembly. 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)
+{
+ CARD *c = ADDR_TO_CARD(address);
+ *c |= CARD_MARK_MASK;
+}
+
+/* we need to remember the first object allocated in the card */
+INLINE void allot_barrier(CELL address)
+{
+ CARD *ptr = ADDR_TO_CARD(address);
+ CARD c = *ptr;
+ CELL b = card_base(c);
+ CELL a = (address & ADDR_CARD_MASK);
+ *ptr = (card_marked(c) | ((b < a) ? b : a));
+}
+
+void unmark_cards(CELL from, CELL to);
+void clear_cards(CELL from, CELL to);
+void collect_cards(CELL gen);
+
+/* generational copying GC divides memory into zones */
+typedef struct {
+ /* start of zone */
+ CELL base;
+ /* allocation pointer */
+ CELL here;
+ /* only for nursery: when it gets this full, call GC */
+ CELL alarm;
+ /* end of zone */
+ CELL limit;
+} ZONE;
+
+/* total number of generations. */
+CELL gen_count;
+
+/* the 0th generation is where new objects are allocated. */
+#define NURSERY 0
+/* the oldest generation */
+#define TENURED (gen_count-1)
+
+DLLEXPORT ZONE *generations;
+
+/* used during garbage collection only */
+ZONE *newspace;
+
+#define tenured generations[TENURED]
+#define nursery generations[NURSERY]
+
+/* spare semi-space; rotates with tenured. */
+ZONE prior;
+
+INLINE bool in_zone(ZONE* z, CELL pointer)
+{
+ return pointer >= z->base && pointer < z->limit;
+}
+
+CELL init_zone(ZONE *z, CELL size, CELL base);
+
+void init_data_heap(CELL gen_count, CELL young_size, CELL aging_size);
+
+/* statistics */
+s64 gc_time;
+CELL minor_collections;
+CELL cards_scanned;
+
+/* only meaningful during a GC */
+CELL collecting_gen;
+CELL collecting_gen_start;
+
+/* test if the pointer is in generation being collected, or a younger one.
+init_data_heap() arranges things so that the older generations are first,
+so we have to check that the pointer occurs after the beginning of
+the requested generation. */
+#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
+
+INLINE bool should_copy(CELL untagged)
+{
+ if(collecting_gen == TENURED)
+ return !in_zone(newspace,untagged);
+ else
+ return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
+}
+
+CELL copy_object(CELL pointer);
+#define COPY_OBJECT(lvalue) if(should_copy(lvalue)) lvalue = copy_object(lvalue)
+
+INLINE void copy_handle(CELL *handle)
+{
+ COPY_OBJECT(*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 heap_scan;
+
+INLINE void *allot_zone(ZONE *z, CELL a)
+{
+ CELL h = z->here;
+ z->here = h + align8(a);
+ if(z->here > z->limit)
+ {
+ fprintf(stderr,"Nursery space exhausted\n");
+ factorbug();
+ }
+
+ allot_barrier(h);
+ return (void*)h;
+}
+
+INLINE void *allot(CELL a)
+{
+ return allot_zone(&nursery,a);
+}
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+INLINE void* allot_object(CELL type, CELL length)
+{
+ CELL* object = allot(length);
+ *object = tag_header(type);
+ return object;
+}
+
+void update_cards_offset(void);
+CELL collect_next(CELL scan);
+void garbage_collection(CELL gen, bool code_gc);
+void primitive_gc(void);
+void maybe_gc(CELL size);
+DLLEXPORT void simple_gc(void);
+void primitive_gc_time(void);
}
else if(strcmp(cmd,"g") == 0)
dump_generations();
- else if(strcmp(cmd,"c") == 0)
- {
- CELL gen;
- scanf("%lu",&gen);
- garbage_collection(gen);
- }
else if(strcmp(cmd,"card") == 0)
{
CELL addr;
CELL gen_count, CELL young_size, CELL aging_size, CELL code_size)
{
init_ffi();
- init_arena(gen_count,young_size,aging_size);
- init_compiler(code_size);
+ init_data_heap(gen_count,young_size,aging_size);
+ init_code_heap(code_size);
init_stacks(ds_size,rs_size,cs_size);
/* callframe must be valid in case load_image() does GC */
callframe = F;
#include "platform.h"
#include "debug.h"
#include "run.h"
-#include "memory.h"
#include "bignumint.h"
#include "bignum.h"
+#include "data_gc.h"
#include "math.h"
#include "types.h"
#include "io.h"
-#include "heap.h"
+#include "code_gc.h"
#include "compiler.h"
#include "image.h"
#include "primitives.h"
+++ /dev/null
-#include "factor.h"
-
-void new_heap(HEAP *heap, CELL size)
-{
- heap->base = (CELL)(alloc_bounded_block(size)->start);
- if(heap->base == 0)
- fatal_error("Cannot allocate code heap",size);
- heap->limit = heap->base + size;
- heap->free_list = NULL;
-}
-
-INLINE void update_free_list(HEAP *heap, F_BLOCK *prev, F_BLOCK *next_free)
-{
- if(prev)
- prev->next_free = next_free;
- else
- heap->free_list = next_free;
-}
-
-/* called after reading the code heap from the image file. we must build the
-free list, and add a large free block from compiling.base + size to
-compiling.limit. */
-void build_free_list(HEAP *heap, CELL size)
-{
- F_BLOCK *prev = NULL;
- F_BLOCK *scan = (F_BLOCK *)heap->base;
- F_BLOCK *end = (F_BLOCK *)(heap->base + size);
-
- while(scan && scan < end)
- {
- if(scan->status == B_FREE)
- {
- update_free_list(heap,prev,scan);
- prev = scan;
- }
-
- scan = next_block(heap,scan);
- }
-
- if((CELL)(end + 1) <= heap->limit)
- {
- end->status = B_FREE;
- end->next_free = NULL;
- end->size = heap->limit - (CELL)end;
- }
- else
- {
- end = NULL;
-
- if(prev)
- prev->size = heap->limit - (CELL)prev;
- }
-
- update_free_list(heap,prev,end);
-}
-
-CELL heap_allot(HEAP *heap, CELL size)
-{
- F_BLOCK *prev = NULL;
- F_BLOCK *scan = heap->free_list;
-
- while(scan)
- {
- CELL this_size = scan->size - sizeof(F_BLOCK);
-
- if(this_size < size)
- {
- prev = scan;
- scan = scan->next_free;
- continue;
- }
-
- /* we found a candidate block */
- F_BLOCK *next_free;
-
- if(this_size - size <= sizeof(F_BLOCK))
- {
- /* too small to be split */
- next_free = scan->next_free;
- }
- else
- {
- /* split the block in two */
- CELL new_size = size + sizeof(F_BLOCK);
- F_BLOCK *split = (F_BLOCK *)((CELL)scan + new_size);
- split->status = B_FREE;
- split->size = scan->size - new_size;
- split->next_free = scan->next_free;
- scan->size = new_size;
- next_free = split;
- }
-
- /* update the free list */
- update_free_list(heap,prev,next_free);
-
- /* this is our new block */
- scan->status = B_ALLOCATED;
-
- return (CELL)(scan + 1);
- }
-
- if(heap->base == 0)
- critical_error("Code heap is full",size);
-
- return 0; /* can't happen */
-}
-
-/* free blocks which are allocated and not marked */
-void free_unmarked(HEAP *heap)
-{
- F_BLOCK *prev = NULL;
- F_BLOCK *scan = (F_BLOCK *)heap->base;
-
- while(scan)
- {
- if(scan->status == B_ALLOCATED)
- {
- /* merge blocks? */
- if(next_block(heap,prev) == scan)
- prev->size += scan->size;
- else
- {
- scan->status = B_FREE;
- update_free_list(heap,prev,scan);
- prev = scan;
- }
- }
-
- scan = next_block(heap,scan);
- }
-
- if(prev)
- prev->next_free = NULL;
-}
-
-CELL heap_free_space(HEAP *heap)
-{
- CELL size = 0;
- F_BLOCK *scan = (F_BLOCK *)heap->base;
-
- while(scan)
- {
- if(scan->status == B_FREE)
- size += scan->size;
- scan = next_block(heap,scan);
- }
-
- return size;
-}
-
-CELL heap_size(HEAP *heap)
-{
- CELL start = heap->base;
- F_BLOCK *scan = (F_BLOCK *)start;
- while(next_block(heap,scan))
- scan = next_block(heap,scan);
- return (CELL)scan - (CELL)start;
-}
+++ /dev/null
-typedef enum
-{
- B_FREE,
- B_ALLOCATED,
- B_MARKED
-} F_BLOCK_STATUS;
-
-typedef struct _F_BLOCK
-{
- F_BLOCK_STATUS status;
- CELL size;
- struct _F_BLOCK *next_free;
-} F_BLOCK;
-
-typedef struct {
- CELL base;
- CELL limit;
- F_BLOCK *free_list;
-} HEAP;
-
-void new_heap(HEAP *heap, CELL size);
-void build_free_list(HEAP *heap, CELL size);
-CELL heap_allot(HEAP *heap, CELL size);
-void free_unmarked(HEAP *heap);
-CELL heap_free_space(HEAP *heap);
-CELL heap_size(HEAP *heap);
-
-INLINE F_BLOCK *next_block(HEAP *heap, F_BLOCK *block)
-{
- CELL next = ((CELL)block + block->size);
- if(next == heap->limit)
- return NULL;
- else
- return (F_BLOCK *)next;
-}
{
F_STRING* filename;
/* do a full GC to push everything into tenured space */
- garbage_collection(TENURED);
+ garbage_collection(TENURED,false);
filename = untag_string(dpop());
save_image(to_char_string(filename,true));
}
}
void fixup_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literal_start, CELL words_start)
+ CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end)
{
/* relocate literal table data */
CELL scan;
CELL literal_end = literal_start + relocating->literal_length;
- CELL words_end = words_start + relocating->words_length;
for(scan = literal_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan);
}
relocate_code_block(relocating,code_start,reloc_start,
- literal_start,words_start);
+ literal_start,words_start,words_end);
}
void relocate_code()
+++ /dev/null
-#include "factor.h"
-
-/* this function tests if a given faulting location is in a poison page. The
-page address is taken from area + round_up_to_page_size(area_size) +
- pagesize*offset */
-bool in_page(void *fault, void *i_area, CELL area_size, int offset)
-{
- const int pagesize = getpagesize();
- intptr_t area = (intptr_t) i_area;
- area += pagesize * ((area_size + (pagesize - 1)) / pagesize);
- area += offset * pagesize;
-
- const int page = area / pagesize;
- const int fault_page = (intptr_t)fault / pagesize;
- return page == fault_page;
-}
-
-void *safe_malloc(size_t size)
-{
- void *ptr = malloc(size);
- if(ptr == 0)
- fatal_error("malloc() failed", 0);
- return ptr;
-}
-
-CELL object_size(CELL tagged)
-{
- if(tagged == F || TAG(tagged) == FIXNUM_TYPE)
- return 0;
- else
- return untagged_object_size(UNTAG(tagged));
-}
-
-CELL untagged_object_size(CELL pointer)
-{
- return align8(unaligned_object_size(pointer));
-}
-
-CELL unaligned_object_size(CELL pointer)
-{
- switch(untag_header(get(pointer)))
- {
- case WORD_TYPE:
- return sizeof(F_WORD);
- case ARRAY_TYPE:
- case TUPLE_TYPE:
- case BIGNUM_TYPE:
- case BYTE_ARRAY_TYPE:
- case QUOTATION_TYPE:
- return array_size(array_capacity((F_ARRAY*)(pointer)));
- case HASHTABLE_TYPE:
- return sizeof(F_HASHTABLE);
- case VECTOR_TYPE:
- return sizeof(F_VECTOR);
- case STRING_TYPE:
- return string_size(string_capacity((F_STRING*)(pointer)));
- case SBUF_TYPE:
- return sizeof(F_SBUF);
- 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(DLL);
- case ALIEN_TYPE:
- return sizeof(ALIEN);
- case WRAPPER_TYPE:
- return sizeof(F_WRAPPER);
- default:
- critical_error("Cannot determine untagged_object_size",pointer);
- return -1; /* can't happen */
- }
-}
-
-/* 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)
-{
- switch(untag_header(get(pointer)))
- {
- /* these objects do not refer to other objects at all */
- case STRING_TYPE:
- case FLOAT_TYPE:
- case BYTE_ARRAY_TYPE:
- case BIGNUM_TYPE:
- return 0;
- /* these objects have some binary data at the end */
- case WORD_TYPE:
- return sizeof(F_WORD) - CELLS;
- case ALIEN_TYPE:
- case DLL_TYPE:
- return CELLS * 2;
- /* everything else consists entirely of pointers */
- default:
- return unaligned_object_size(pointer);
- }
-}
-
-void primitive_type(void)
-{
- drepl(tag_fixnum(type_of(dpeek())));
-}
-
-void primitive_tag(void)
-{
- drepl(tag_fixnum(TAG(dpeek())));
-}
-
-void primitive_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- dpush(get(SLOT(obj,slot)));
-}
-
-void primitive_set_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- CELL value = dpop();
- put(SLOT(obj,slot),value);
- write_barrier(obj);
-}
-
-void primitive_integer_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- dpush(tag_cell(get(SLOT(obj,slot))));
-}
-
-void primitive_set_integer_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- F_FIXNUM value = to_cell(dpop());
- put(SLOT(obj,slot),value);
-}
-
-void primitive_size(void)
-{
- drepl(tag_fixnum(object_size(dpeek())));
-}
-
-CELL clone(CELL obj)
-{
- CELL size = object_size(obj);
- CELL tag = TAG(obj);
- void *new_obj = allot(size);
- return RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag);
-}
-
-void primitive_clone(void)
-{
- maybe_gc(0);
- drepl(clone(dpeek()));
-}
-
-void primitive_data_room(void)
-{
- F_ARRAY *a = array(ARRAY_TYPE,gen_count,F);
- int gen;
- box_unsigned_cell(cards_end - cards);
- box_unsigned_cell(prior.limit - prior.base);
- for(gen = 0; gen < gen_count; gen++)
- {
- ZONE *z = &generations[gen];
- put(AREF(a,gen),make_array_2(tag_cell(z->limit - z->here),
- tag_cell(z->limit - z->base)));
- }
- dpush(tag_object(a));
-}
-
-/* Disables GC and activates next-object ( -- obj ) primitive */
-void primitive_begin_scan(void)
-{
- garbage_collection(TENURED);
- heap_scan_ptr = tenured.base;
- heap_scan = true;
-}
-
-/* Push object at heap scan cursor and advance; pushes f when done */
-void primitive_next_object(void)
-{
- CELL value = get(heap_scan_ptr);
- CELL obj = heap_scan_ptr;
- CELL type;
-
- if(!heap_scan)
- general_error(ERROR_HEAP_SCAN,F,F,true);
-
- if(heap_scan_ptr >= tenured.here)
- {
- dpush(F);
- return;
- }
-
- type = untag_header(value);
- heap_scan_ptr += untagged_object_size(heap_scan_ptr);
-
- if(type <= HEADER_TYPE)
- dpush(RETAG(obj,type));
- else
- dpush(RETAG(obj,OBJECT_TYPE));
-}
-
-/* Re-enables GC */
-void primitive_end_scan(void)
-{
- heap_scan = false;
-}
-
-/* scan all the objects in the card */
-INLINE void collect_card(CARD *ptr, CELL here)
-{
- CARD c = *ptr;
- CELL offset = (c & CARD_BASE_MASK);
- CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
- CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
- if(offset == 0x7f)
- {
- if(c == 0xff)
- critical_error("bad card",(CELL)ptr);
- else
- return;
- }
-
- while(card_scan < card_end && card_scan < here)
- card_scan = collect_next(card_scan);
-
- cards_scanned++;
-}
-
-INLINE void collect_gen_cards(CELL gen)
-{
- CARD *ptr = ADDR_TO_CARD(generations[gen].base);
- CELL here = generations[gen].here;
- CARD *last_card = ADDR_TO_CARD(here);
-
- if(generations[gen].here == generations[gen].limit)
- last_card--;
-
- for(; ptr <= last_card; ptr++)
- {
- if(card_marked(*ptr))
- collect_card(ptr,here);
- }
-}
-
-void unmark_cards(CELL from, CELL to)
-{
- CARD *ptr = ADDR_TO_CARD(generations[from].base);
- CARD *last_card = ADDR_TO_CARD(generations[to].here);
- if(generations[to].here == generations[to].limit)
- last_card--;
- for(; ptr <= last_card; ptr++)
- unmark_card(ptr);
-}
-
-void clear_cards(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- CARD *last_card = ADDR_TO_CARD(generations[from].limit);
- CARD *ptr = ADDR_TO_CARD(generations[to].base);
- for(; ptr < last_card; ptr++)
- clear_card(ptr);
-}
-
-/* scan cards in all generations older than the one being collected */
-void collect_cards(CELL gen)
-{
- int i;
- for(i = gen + 1; i < gen_count; i++)
- collect_gen_cards(i);
-}
-
-/* Generational copying garbage collector */
-
-CELL init_zone(ZONE *z, CELL size, CELL base)
-{
- z->base = z->here = base;
- z->limit = z->base + size;
- z->alarm = z->base + (size * 3) / 4;
- return z->limit;
-}
-
-/* update this global variable. since it is stored in a non-volatile register,
-we need to save its contents and re-initialize it when entering a callback,
-and restore its contents when leaving the callback. see stack.c */
-void update_cards_offset(void)
-{
- cards_offset = (CELL)cards - (data_heap_start >> CARD_BITS);
-}
-
-/* input parameters must be 8 byte aligned */
-/* the heap layout is important:
-- two semispaces: tenured and prior
-- younger generations follow
-there are two reasons for this:
-- we can easily check if a pointer is in some generation or a younger one
-- the nursery grows into the guard page, so allot() does not have to
-check for out of memory, whereas allot_zone() (used by the GC) longjmp()s
-back to collecting a higher generation */
-void init_arena(CELL gens, CELL young_size, CELL aging_size)
-{
- int i;
- CELL alloter;
-
- CELL total_size = (gens - 1) * young_size + 2 * aging_size;
- CELL cards_size = total_size / CARD_SIZE;
-
- gen_count = gens;
- generations = safe_malloc(sizeof(ZONE) * gen_count);
-
- data_heap_start = (CELL)(alloc_bounded_block(total_size)->start);
- data_heap_end = data_heap_start + total_size;
-
- cards = safe_malloc(cards_size);
- cards_end = cards + cards_size;
- update_cards_offset();
-
- alloter = data_heap_start;
-
- alloter = init_zone(&tenured,aging_size,alloter);
- alloter = init_zone(&prior,aging_size,alloter);
-
- for(i = gen_count - 2; i >= 0; i--)
- alloter = init_zone(&generations[i],young_size,alloter);
-
- clear_cards(NURSERY,TENURED);
-
- if(alloter != data_heap_start + total_size)
- fatal_error("Oops",alloter);
-
- heap_scan = false;
- gc_time = 0;
- minor_collections = 0;
- cards_scanned = 0;
-}
-
-void collect_callframe_triple(CELL *callframe,
- CELL *callframe_scan, CELL *callframe_end)
-{
- *callframe_scan -= *callframe;
- *callframe_end -= *callframe;
- copy_handle(callframe);
- *callframe_scan += *callframe;
- *callframe_end += *callframe;
-}
-
-void collect_stack(BOUNDED_BLOCK *region, CELL top)
-{
- CELL bottom = region->start;
- CELL ptr;
-
- for(ptr = bottom; ptr <= top; ptr += CELLS)
- copy_handle((CELL*)ptr);
-}
-
-void collect_callstack(BOUNDED_BLOCK *region, CELL top)
-{
- CELL bottom = region->start;
- CELL ptr;
-
- for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
- collect_callframe_triple((CELL*)ptr,
- (CELL*)ptr + 1, (CELL*)ptr + 2);
-}
-
-void collect_roots(void)
-{
- int i;
- STACKS *stacks;
-
- copy_handle(&T);
- copy_handle(&bignum_zero);
- copy_handle(&bignum_pos_one);
- copy_handle(&bignum_neg_one);
- collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
-
- save_stacks();
- stacks = stack_chain;
-
- while(stacks)
- {
- collect_stack(stacks->data_region,stacks->data);
- collect_stack(stacks->retain_region,stacks->retain);
-
- collect_callstack(stacks->call_region,stacks->call);
-
- if(stacks->next != NULL)
- {
- collect_callframe_triple(&stacks->callframe,
- &stacks->callframe_scan,&stacks->callframe_end);
- }
-
- copy_handle(&stacks->catch_save);
-
- stacks = stacks->next;
- }
-
- for(i = 0; i < USER_ENV; i++)
- copy_handle(&userenv[i]);
-}
-
-/* Given a pointer to oldspace, copy it to newspace. */
-INLINE void *copy_untagged_object(void *pointer, CELL size)
-{
- void *newpointer;
- if(newspace->here + size >= newspace->limit)
- longjmp(gc_jmp,1);
- newpointer = allot_zone(newspace,size);
- memcpy(newpointer,pointer,size);
- return newpointer;
-}
-
-INLINE CELL copy_object_impl(CELL pointer)
-{
- CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
- object_size(pointer));
-
- /* install forwarding pointer */
- put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
-
- return newpointer;
-}
-
-/* follow a chain of forwarding pointers */
-CELL resolve_forwarding(CELL untagged, CELL tag)
-{
- CELL header = get(untagged);
- /* another forwarding pointer */
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- /* we've found the destination */
- else
- {
- CELL pointer = RETAG(untagged,tag);
- if(should_copy(untagged))
- pointer = RETAG(copy_object_impl(pointer),tag);
- return pointer;
- }
-}
-
-/*
-Given a pointer to a tagged pointer to oldspace, copy it to newspace.
-If the object has already been copied, return the forwarding
-pointer address without copying anything; otherwise, install
-a new forwarding pointer.
-*/
-CELL copy_object(CELL pointer)
-{
- CELL tag;
- CELL header;
-
- if(pointer == F)
- return F;
-
- tag = TAG(pointer);
-
- if(tag == FIXNUM_TYPE)
- return pointer;
-
- header = get(UNTAG(pointer));
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- else
- return RETAG(copy_object_impl(pointer),tag);
-}
-
-INLINE void collect_object(CELL scan)
-{
- CELL payload_start = binary_payload_start(scan);
- CELL end = scan + payload_start;
-
- scan += CELLS;
-
- while(scan < end)
- {
- copy_handle((CELL*)scan);
- scan += CELLS;
- }
-}
-
-CELL collect_next(CELL scan)
-{
- CELL size = untagged_object_size(scan);
- collect_object(scan);
- return scan + size;
-}
-
-void reset_generations(CELL from, CELL to)
-{
- CELL i;
- for(i = from; i <= to; i++)
- generations[i].here = generations[i].base;
- clear_cards(from,to);
-}
-
-void begin_gc(CELL gen)
-{
- collecting_gen = gen;
- collecting_gen_start = generations[gen].base;
-
- if(gen == TENURED)
- {
- /* when collecting the oldest generation, rotate it
- with the semispace */
- ZONE z = generations[gen];
- generations[gen] = prior;
- prior = z;
- generations[gen].here = generations[gen].base;
- newspace = &generations[gen];
- clear_cards(TENURED,TENURED);
- }
- else
- {
- /* when collecting a younger generation, we copy
- reachable objects to the next oldest generation,
- so we set the newspace so the next generation. */
- newspace = &generations[gen + 1];
- }
-}
-
-void end_gc(CELL gen)
-{
- if(gen == TENURED)
- {
- /* we did a full collection; no more
- old-to-new pointers remain since everything
- is in tenured space */
- unmark_cards(TENURED,TENURED);
- /* all generations except tenured space are
- now empty */
- reset_generations(NURSERY,TENURED - 1);
-
- fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
- minor_collections,cards_scanned);
- minor_collections = 0;
- cards_scanned = 0;
- }
- else
- {
- /* we collected a younger generation. so the
- next-oldest generation no longer has any
- pointers into the younger generation (the
- younger generation is empty!) */
- unmark_cards(gen + 1,gen + 1);
- /* all generations up to and including the one
- collected are now empty */
- reset_generations(NURSERY,gen);
-
- minor_collections++;
- }
-}
-
-/* collect gen and all younger generations */
-void garbage_collection(CELL gen)
-{
- s64 start = current_millis();
- CELL scan;
-
- if(heap_scan)
- critical_error("GC disabled during heap scan",gen);
-
- /* we come back here if a generation is full */
- if(setjmp(gc_jmp))
- {
- if(gen == TENURED)
- {
- /* oops, out of memory */
- critical_error("Out of memory",0);
- }
- else
- gen++;
- }
-
- begin_gc(gen);
-
- /* initialize chase pointer */
- scan = newspace->here;
-
- /* collect objects referenced from stacks and environment */
- collect_roots();
-
- /* collect objects referenced from older generations */
- collect_cards(gen);
-
- /* collect literal objects referenced from compiled code */
- collect_literals();
-
- while(scan < newspace->here)
- scan = collect_next(scan);
-
- end_gc(gen);
-
- gc_time += (current_millis() - start);
-}
-
-void primitive_gc(void)
-{
- CELL gen = to_fixnum(dpop());
- if(gen <= NURSERY)
- gen = NURSERY;
- else if(gen >= TENURED)
- gen = TENURED;
- garbage_collection(gen);
-}
-
-/* WARNING: only call this from a context where all local variables
-are also reachable via the GC roots. */
-void maybe_gc(CELL size)
-{
- if(nursery.here + size > nursery.alarm)
- {
- CELL gen = NURSERY;
- while(gen < TENURED)
- {
- ZONE *z = &generations[gen + 1];
- if(z->here < z->alarm)
- break;
- gen++;
- }
-
- garbage_collection(gen);
- }
-}
-
-void simple_gc(void)
-{
- maybe_gc(0);
-}
-
-void primitive_gc_time(void)
-{
- simple_gc();
- dpush(tag_bignum(s48_long_long_to_bignum(gc_time)));
-}
+++ /dev/null
-bool in_page(void *fault, void *i_area, CELL area_size, int offset);
-
-void *safe_malloc(size_t size);
-
-typedef struct {
- CELL start;
- CELL size;
-} BOUNDED_BLOCK;
-
-/* set up guard pages to check for under/overflow.
-size must be a multiple of the page size */
-BOUNDED_BLOCK *alloc_bounded_block(CELL size);
-void dealloc_bounded_block(BOUNDED_BLOCK *block);
-
-/* macros for reading/writing memory, useful when working around
-C's type system */
-INLINE CELL get(CELL where)
-{
- return *((CELL*)where);
-}
-
-INLINE void put(CELL where, CELL what)
-{
- *((CELL*)where) = what;
-}
-
-INLINE u16 cget(CELL where)
-{
- return *((u16*)where);
-}
-
-INLINE void cput(CELL where, u16 what)
-{
- *((u16*)where) = what;
-}
-
-INLINE CELL align8(CELL a)
-{
- return (a + 7) & ~7;
-}
-
-/* Canonical T object. It's just a word */
-CELL T;
-
-#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
-
-INLINE CELL tag_header(CELL cell)
-{
- return RETAG(cell << TAG_BITS,OBJECT_TYPE);
-}
-
-INLINE CELL untag_header(CELL cell)
-{
- /* if((cell & TAG_MASK) != OBJECT_TYPE)
- critical_error("Corrupt object header",cell); */
-
- return cell >> TAG_BITS;
-}
-
-INLINE CELL tag_object(void* cell)
-{
- return RETAG(cell,OBJECT_TYPE);
-}
-
-INLINE CELL object_type(CELL tagged)
-{
- return untag_header(get(UNTAG(tagged)));
-}
-
-INLINE CELL type_of(CELL tagged)
-{
- if(tagged == F)
- return F_TYPE;
- else if(TAG(tagged) == FIXNUM_TYPE)
- return FIXNUM_TYPE;
- else
- return object_type(tagged);
-}
-
-INLINE void type_check(CELL type, CELL tagged)
-{
- if(type_of(tagged) != type)
- type_error(type,tagged);
-}
-
-CELL untagged_object_size(CELL pointer);
-CELL unaligned_object_size(CELL pointer);
-CELL object_size(CELL pointer);
-CELL binary_payload_start(CELL pointer);
-void primitive_data_room(void);
-void primitive_type(void);
-void primitive_tag(void);
-void primitive_slot(void);
-void primitive_set_slot(void);
-void primitive_integer_slot(void);
-void primitive_set_integer_slot(void);
-void primitive_size(void);
-CELL clone(CELL obj);
-void primitive_clone(void);
-void primitive_begin_scan(void);
-void primitive_next_object(void);
-void primitive_end_scan(void);
-
-CELL data_heap_start;
-CELL data_heap_end;
-
-/* 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.
-*/
-#define CARD_MARK_MASK 0x80
-#define CARD_BASE_MASK 0x7f
-typedef u8 CARD;
-
-CARD *cards;
-CARD *cards_end;
-
-/* A card is 16 bytes (128 bits), 5 address bits per card.
-it is important that 7 bits is sufficient to represent every
-offset within the card */
-#define CARD_SIZE 128
-#define CARD_BITS 7
-#define ADDR_CARD_MASK (CARD_SIZE-1)
-
-INLINE CARD card_marked(CARD c)
-{
- return c & CARD_MARK_MASK;
-}
-
-INLINE void unmark_card(CARD *c)
-{
- *c &= CARD_BASE_MASK;
-}
-
-INLINE void clear_card(CARD *c)
-{
- *c = CARD_BASE_MASK; /* invalid value */
-}
-
-INLINE u8 card_base(CARD c)
-{
- return c & CARD_BASE_MASK;
-}
-
-#define ADDR_TO_CARD(a) (CARD*)(((CELL)a >> CARD_BITS) + cards_offset)
-#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)<<CARD_BITS)
-
-/* this is an inefficient write barrier. compiled definitions use a more
-efficient one hand-coded in assembly. 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)
-{
- CARD *c = ADDR_TO_CARD(address);
- *c |= CARD_MARK_MASK;
-}
-
-/* we need to remember the first object allocated in the card */
-INLINE void allot_barrier(CELL address)
-{
- CARD *ptr = ADDR_TO_CARD(address);
- CARD c = *ptr;
- CELL b = card_base(c);
- CELL a = (address & ADDR_CARD_MASK);
- *ptr = (card_marked(c) | ((b < a) ? b : a));
-}
-
-void unmark_cards(CELL from, CELL to);
-void clear_cards(CELL from, CELL to);
-void collect_cards(CELL gen);
-
-/* generational copying GC divides memory into zones */
-typedef struct {
- /* start of zone */
- CELL base;
- /* allocation pointer */
- CELL here;
- /* only for nursery: when it gets this full, call GC */
- CELL alarm;
- /* end of zone */
- CELL limit;
-} ZONE;
-
-/* total number of generations. */
-CELL gen_count;
-
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-/* the oldest generation */
-#define TENURED (gen_count-1)
-
-DLLEXPORT ZONE *generations;
-
-/* used during garbage collection only */
-ZONE *newspace;
-
-#define tenured generations[TENURED]
-#define nursery generations[NURSERY]
-
-/* spare semi-space; rotates with tenured. */
-ZONE prior;
-
-INLINE bool in_zone(ZONE* z, CELL pointer)
-{
- return pointer >= z->base && pointer < z->limit;
-}
-
-CELL init_zone(ZONE *z, CELL size, CELL base);
-
-void init_arena(CELL gen_count, CELL young_size, CELL aging_size);
-
-/* statistics */
-s64 gc_time;
-CELL minor_collections;
-CELL cards_scanned;
-
-/* only meaningful during a GC */
-CELL collecting_gen;
-CELL collecting_gen_start;
-
-/* test if the pointer is in generation being collected, or a younger one.
-init_arena() arranges things so that the older generations are first,
-so we have to check that the pointer occurs after the beginning of
-the requested generation. */
-#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
-
-INLINE bool should_copy(CELL untagged)
-{
- if(collecting_gen == TENURED)
- return !in_zone(newspace,untagged);
- else
- return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
-}
-
-CELL copy_object(CELL pointer);
-#define COPY_OBJECT(lvalue) if(should_copy(lvalue)) lvalue = copy_object(lvalue)
-
-INLINE void copy_handle(CELL *handle)
-{
- COPY_OBJECT(*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 heap_scan;
-
-INLINE void *allot_zone(ZONE *z, CELL a)
-{
- CELL h = z->here;
- z->here = h + align8(a);
- if(z->here > z->limit)
- {
- fprintf(stderr,"Nursery space exhausted\n");
- factorbug();
- }
-
- allot_barrier(h);
- return (void*)h;
-}
-
-INLINE void *allot(CELL a)
-{
- return allot_zone(&nursery,a);
-}
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-INLINE void* allot_object(CELL type, CELL length)
-{
- CELL* object = allot(length);
- *object = tag_header(type);
- return object;
-}
-
-void update_cards_offset(void);
-CELL collect_next(CELL scan);
-void garbage_collection(CELL gen);
-void primitive_gc(void);
-void maybe_gc(CELL size);
-DLLEXPORT void simple_gc(void);
-void primitive_gc_time(void);
dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
}
+void primitive_type(void)
+{
+ drepl(tag_fixnum(type_of(dpeek())));
+}
+
+void primitive_tag(void)
+{
+ drepl(tag_fixnum(TAG(dpeek())));
+}
+
+void primitive_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ dpush(get(SLOT(obj,slot)));
+}
+
+void primitive_set_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ CELL value = dpop();
+ put(SLOT(obj,slot),value);
+ write_barrier(obj);
+}
+
+void primitive_integer_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ dpush(tag_cell(get(SLOT(obj,slot))));
+}
+
+void primitive_set_integer_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ F_FIXNUM value = to_cell(dpop());
+ put(SLOT(obj,slot),value);
+}
+
+CELL clone(CELL obj)
+{
+ CELL size = object_size(obj);
+ CELL tag = TAG(obj);
+ void *new_obj = allot(size);
+ return RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag);
+}
+
+void primitive_clone(void)
+{
+ maybe_gc(0);
+ drepl(clone(dpeek()));
+}
+
void fatal_error(char* msg, CELL tagged)
{
fprintf(stderr,"Fatal error: %s %lx\n",msg,tagged);
/* TAGGED user environment data; see getenv/setenv prims */
DLLEXPORT CELL userenv[USER_ENV];
+/* macros for reading/writing memory, useful when working around
+C's type system */
+INLINE CELL get(CELL where)
+{
+ return *((CELL*)where);
+}
+
+INLINE void put(CELL where, CELL what)
+{
+ *((CELL*)where) = what;
+}
+
+INLINE u16 cget(CELL where)
+{
+ return *((u16*)where);
+}
+
+INLINE void cput(CELL where, u16 what)
+{
+ *((u16*)where) = what;
+}
+
+INLINE CELL align8(CELL a)
+{
+ return (a + 7) & ~7;
+}
+
+/* Canonical T object. It's just a word */
+CELL T;
+
+#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
+
+INLINE CELL tag_header(CELL cell)
+{
+ return RETAG(cell << TAG_BITS,OBJECT_TYPE);
+}
+
+INLINE CELL untag_header(CELL cell)
+{
+ /* if((cell & TAG_MASK) != OBJECT_TYPE)
+ critical_error("Corrupt object header",cell); */
+
+ return cell >> TAG_BITS;
+}
+
+INLINE CELL tag_object(void* cell)
+{
+ return RETAG(cell,OBJECT_TYPE);
+}
+
+INLINE CELL object_type(CELL tagged)
+{
+ return untag_header(get(UNTAG(tagged)));
+}
+
+INLINE CELL type_of(CELL tagged)
+{
+ if(tagged == F)
+ return F_TYPE;
+ else if(TAG(tagged) == FIXNUM_TYPE)
+ return FIXNUM_TYPE;
+ else
+ return object_type(tagged);
+}
+
void call(CELL quot);
void handle_error();
void primitive_os_env(void);
void primitive_eq(void);
void primitive_millis(void);
+void primitive_type(void);
+void primitive_tag(void);
+void primitive_slot(void);
+void primitive_set_slot(void);
+void primitive_integer_slot(void);
+void primitive_set_integer_slot(void);
+CELL clone(CELL obj);
+void primitive_clone(void);
/* Runtime errors */
typedef enum
void type_error(CELL type, CELL tagged);
void primitive_throw(void);
void primitive_die(void);
+
+INLINE void type_check(CELL type, CELL tagged)
+{
+ if(type_of(tagged) != type)
+ type_error(type,tagged);
+}
projects / factor.git / commitdiff