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

Runtime code cleanups, implemented mark and sweep code GC

slava 2006-09-26 22:44:18 +00:00
parent f55cfd918a
commit 39d363f265
17 changed files with 325 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -32,11 +32,11 @@ OBJS = $(PLAF_OBJS) \
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 \

1
TODO.FACTOR.txt
View File

@ -3,7 +3,6 @@
- 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:

2
library/compiler/inference/known-words.factor
View File

@ -235,7 +235,7 @@ t over set-effect-terminated?
\ 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

2
library/tools/memory.factor
View File

@ -5,7 +5,7 @@ USING: arrays errors generic hashtables io kernel
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.

76
vm/heap.c → vm/code_gc.c
View File

@ -1,5 +1,8 @@
#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);
@ -9,6 +12,11 @@ void new_heap(HEAP *heap, CELL 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)
@ -156,3 +164,71 @@ CELL heap_size(HEAP *heap)
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);
}

82
vm/code_gc.h Normal file
View File

@ -0,0 +1,82 @@
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));
}

66
vm/compiler.c
View File

@ -1,32 +1,5 @@
#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);
@ -139,7 +112,7 @@ void apply_relocation(F_REL *rel,
}
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;
@ -150,10 +123,8 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_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)
@ -162,34 +133,11 @@ void finalize_code_block(F_COMPILED *relocating, CELL code_start,
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);
@ -291,12 +239,6 @@ void primitive_finalize_compile(void)
{
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);
}

23
vm/compiler.h
View File

@ -1,21 +1,3 @@
/* 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,
@ -57,9 +39,6 @@ typedef struct {
} 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);

82
vm/memory.c → vm/data_gc.c
View File

@ -74,6 +74,11 @@ CELL unaligned_object_size(CELL pointer)
}
}
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. */
@ -99,66 +104,6 @@ CELL binary_payload_start(CELL 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);
@ -177,7 +122,7 @@ void primitive_data_room(void)
/* Disables GC and activates next-object ( -- obj ) primitive */
void primitive_begin_scan(void)
{
garbage_collection(TENURED);
garbage_collection(TENURED,false);
heap_scan_ptr = tenured.base;
heap_scan = true;
}
@ -297,7 +242,7 @@ void update_cards_offset(void)
}
/* input parameters must be 8 byte aligned */
/* the heap layout is important:
/* the data heap layout is important:
- two semispaces: tenured and prior
- younger generations follow
there are two reasons for this:
@ -305,7 +250,7 @@ there are two reasons for this:
- 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)
void init_data_heap(CELL gens, CELL young_size, CELL aging_size)
{
int i;
CELL alloter;
@ -538,7 +483,7 @@ void end_gc(CELL gen)
now empty */
reset_generations(NURSERY,TENURED - 1);
fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
fprintf(stderr,"*** Data GC (%ld minor, %ld cards)\n",
minor_collections,cards_scanned);
minor_collections = 0;
cards_scanned = 0;
@ -559,7 +504,7 @@ void end_gc(CELL gen)
}
/* collect gen and all younger generations */
void garbage_collection(CELL gen)
void garbage_collection(CELL gen, bool code_gc)
{
s64 start = current_millis();
CELL scan;
@ -603,12 +548,13 @@ void garbage_collection(CELL gen)
void primitive_gc(void)
{
bool code_gc = unbox_boolean();
CELL gen = to_fixnum(dpop());
if(gen <= NURSERY)
if(gen <= NURSERY || code_gc)
gen = NURSERY;
else if(gen >= TENURED)
gen = TENURED;
garbage_collection(gen);
garbage_collection(gen,code_gc);
}
/* WARNING: only call this from a context where all local variables
@ -626,7 +572,7 @@ void maybe_gc(CELL size)
gen++;
}
garbage_collection(gen);
garbage_collection(gen,false);
}
}

85
vm/memory.h → vm/data_gc.h
View File

@ -12,91 +12,12 @@ 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);
@ -211,7 +132,7 @@ INLINE bool in_zone(ZONE* z, CELL pointer)
CELL init_zone(ZONE *z, CELL size, CELL base);
void init_arena(CELL gen_count, CELL young_size, CELL aging_size);
void init_data_heap(CELL gen_count, CELL young_size, CELL aging_size);
/* statistics */
s64 gc_time;
@ -223,7 +144,7 @@ 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,
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)
@ -287,7 +208,7 @@ INLINE void* allot_object(CELL type, CELL length)
void update_cards_offset(void);
CELL collect_next(CELL scan);
void garbage_collection(CELL gen);
void garbage_collection(CELL gen, bool code_gc);
void primitive_gc(void);
void maybe_gc(CELL size);
DLLEXPORT void simple_gc(void);

6
vm/debug.c
View File

@ -223,12 +223,6 @@ void factorbug(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;

4
vm/factor.c
View File

@ -5,8 +5,8 @@ void init_factor(const char* image,
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;

4
vm/factor.h
View File

@ -18,13 +18,13 @@
#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"

35
vm/heap.h
View File

@ -1,35 +0,0 @@
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;
}

7
vm/image.c
View File

@ -116,7 +116,7 @@ void primitive_save_image(void)
{
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));
}
@ -173,12 +173,11 @@ void relocate_data()
}
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);
@ -192,7 +191,7 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
}
relocate_code_block(relocating,code_start,reloc_start,
literal_start,words_start);
literal_start,words_start,words_end);
}
void relocate_code()

55
vm/run.c
View File

@ -191,6 +191,61 @@ void primitive_millis(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);

79
vm/run.h
View File

@ -33,6 +33,71 @@ CELL callframe_end;
/* 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();
@ -53,6 +118,14 @@ void primitive_exit(void);
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
@ -97,3 +170,9 @@ void signal_error(int signal);
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);
}