From 9e789dce14e3eece09b5cea32c0c09dc3e848e2a Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sat, 14 Jul 2012 12:59:27 -0500 Subject: [PATCH] First version of simplified garbage collector. For now, this GC is non-generational, and much slower than the old version. It tracks objects by a fixed object ID rather than changeable memory address. Small object (eight bytes or less) are stored directly in the array, indexed by object ID, while larger object are allocated with malloc() (for now) and stored in the array as a pointer. Object IDs are stored as 32-bit integers, even on 64-bit platforms. Advantages: - Simpler design - Requires less memory on 64-bit platforms - Object IDs don't change when running the GC - No need to store a random "hash" value in vectors/strings/structs - Can hash pairs by identity, not just value - Can move objects individually, without fixing up all references - Can determine object type from value, without another memory access Disadvantages: - Lower initial performance (non-generational, relies on malloc()) - 32-bit values place a (high) limit on total number of objects - Must explicitly free unreachable object IDs after GC --- builtin.c | 195 ++- builtin.h | 2 + doc/bytecode.txt | 2 +- gc.c | 1957 +++++++++++----------------- gc.h | 605 ++++----- interp.c | 172 ++- libcompiler/primitives.scm | 2 +- libcompiler/writer.scm | 2 +- mods/mod_io.c | 46 +- reader.c | 90 +- rosella.c | 36 +- src/compiler.rls | 7 +- src/examples/annotated-structs.rla | 8 +- src/lib/hash-table.rls | 4 +- src/lib/keywords.rls | 2 +- src/lib/names.rls | 2 +- src/lib/parameters.rls | 14 +- src/lib/port.rls | 2 +- src/lib/primitives.rls | 5 +- src/lib/util.rls | 6 +- 20 files changed, 1415 insertions(+), 1744 deletions(-) diff --git a/builtin.c b/builtin.c index 0f74138..5a9be2a 100644 --- a/builtin.c +++ b/builtin.c @@ -9,6 +9,12 @@ #include "builtin.h" #include "interp.h" +typedef struct seen_value +{ + value_t value; + struct seen_value *prev; +} seen_value_t; + static gc_root_t builtin_list; static gc_root_t lambda_type_root; static gc_root_t template_type_root; @@ -27,11 +33,14 @@ static void bi_call_with_context(interp_state_t *state); static void bi_exit(interp_state_t *state); static void bi_float_to_string(interp_state_t *state); +static void bi_hash_by_id(interp_state_t *state); +static void bi_hash_by_value(interp_state_t *state); + void builtin_init(void) { register_gc_root(&builtin_list, NIL); - register_gc_root(&lambda_type_root, make_struct_type(NIL, LAMBDA_SLOTS, FALSE_VALUE)); - register_gc_root(&template_type_root, make_struct_type(NIL, TEMPLATE_SLOTS, FALSE_VALUE)); + register_gc_root(&lambda_type_root, make_struct_type(FALSE_VALUE, LAMBDA_SLOTS, FALSE_VALUE)); + register_gc_root(&template_type_root, make_struct_type(FALSE_VALUE, TEMPLATE_SLOTS, FALSE_VALUE)); register_builtin(BI_UNDEFINED, UNDEFINED); register_builtin(BI_STRUCTURE, get_structure_type()); @@ -65,6 +74,9 @@ void builtin_init(void) register_builtin(BI_EXIT, make_builtin_fn(bi_exit)); register_builtin(BI_FLOAT_TO_STRING, make_builtin_fn(bi_float_to_string)); + + register_builtin(BI_HASH_BY_ID, make_builtin_fn(bi_hash_by_id)); + register_builtin(BI_HASH_BY_VALUE, make_builtin_fn(bi_hash_by_value)); } void register_builtin(const char *name, value_t value) @@ -72,8 +84,8 @@ void register_builtin(const char *name, value_t value) gc_root_t name_root; register_gc_root(&name_root, string_to_value(name)); - builtin_list.value = cons(value, builtin_list.value); - builtin_list.value = cons(name_root.value, builtin_list.value); + builtin_list.value = make_pair(value, builtin_list.value); + builtin_list.value = make_pair(name_root.value, builtin_list.value); unregister_gc_root(&name_root); } @@ -82,11 +94,11 @@ value_t lookup_builtin(const char *name) value_t name_val = string_to_value(name); for (value_t list = builtin_list.value; !is_nil(list); - list = _CDDR(list)) + list = CDDR(list)) { - if (byte_strcmp(_CAR(list), name_val) == 0) + if (byte_strcmp(CAR(list), name_val) == 0) { - return _CADR(list); + return CADR(list); } } @@ -96,11 +108,11 @@ value_t lookup_builtin(const char *name) value_t reverse_lookup_builtin(value_t value) { for (value_t list = builtin_list.value; !is_nil(list); - list = _CDDR(list)) + list = CDDR(list)) { - if (_CADR(list) == value) + if (CADR(list) == value) { - return _CAR(list); + return CAR(list); } } @@ -126,13 +138,13 @@ static void bi_string_to_builtin(interp_state_t *state) rval = lookup_builtin(str); free(str); - interp_return_values(state, cons(rval, NIL)); + interp_return_values(state, make_pair(rval, NIL)); } static void bi_builtin_to_string(interp_state_t *state) { value_t rval = reverse_lookup_builtin(CAR(state->argv.value)); - interp_return_values(state, cons(rval, NIL)); + interp_return_values(state, make_pair(rval, NIL)); } static void bi_values(interp_state_t *state) @@ -146,18 +158,18 @@ static void bi_freeze(interp_state_t *state) if (is_vector(val)) { - _get_vector(val)->immutable = true; + get_vector(val)->immutable = true; } else if (is_byte_string(val)) { - _get_byte_string(val)->immutable = true; + get_byte_string(val)->immutable = true; } else if (is_struct(val)) { - _get_struct(val)->immutable = true; + get_struct(val)->immutable = true; } - interp_return_values(state, cons(val, NIL)); + interp_return_values(state, make_pair(val, NIL)); } static void bi_immutable_p(interp_state_t *state) @@ -169,15 +181,15 @@ static void bi_immutable_p(interp_state_t *state) if (is_vector(val)) { - frozen = _get_vector(val)->immutable; + frozen = get_vector(val)->immutable; } else if (is_byte_string(val)) { - frozen = _get_byte_string(val)->immutable; + frozen = get_byte_string(val)->immutable; } else if (is_struct(val)) { - frozen = _get_struct(val)->immutable; + frozen = get_struct(val)->immutable; } else { @@ -185,7 +197,7 @@ static void bi_immutable_p(interp_state_t *state) frozen = !is_object(val) || is_float(val) || is_builtin_fn(val); } - interp_return_values(state, cons(boolean_value(frozen), NIL)); + interp_return_values(state, make_pair(make_boolean(frozen), NIL)); } static void bi_string_to_number(interp_state_t *state) @@ -198,13 +210,13 @@ static void bi_string_to_number(interp_state_t *state) str = value_to_string(CAR(state->argv.value)); num = (fixnum_t)strtoll(str, &end, 0); - if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num)) - rval = fixnum_value(num); + if ((*end == '\0') && (get_fixnum(make_fixnum(num)) == num)) + rval = make_fixnum(num); else rval = FALSE_VALUE; free(str); - interp_return_values(state, cons(rval, NIL)); + interp_return_values(state, make_pair(rval, NIL)); } static void bi_display(interp_state_t *state) @@ -216,19 +228,19 @@ static void bi_display(interp_state_t *state) static void bi_register_finalizer(interp_state_t *state) { - register_finalizer(CAR(state->argv.value), CAR(_CDR(state->argv.value))); + register_finalizer(CAR(state->argv.value), CAR(CDR(state->argv.value))); interp_return_values(state, NIL); } static void bi_current_context(interp_state_t *state) { - interp_return_values(state, cons(state->ctx.value, NIL)); + interp_return_values(state, make_pair(state->ctx.value, NIL)); } static void bi_call_with_context(interp_state_t *state) { state->ctx.value = CAR(state->argv.value); - state->lambda.value = CAR(_CDR(state->argv.value)); + state->lambda.value = CAR(CDR(state->argv.value)); state->argv.value = NIL; state->kw_args.value = NIL; state->kw_vals.value = NIL; @@ -245,11 +257,138 @@ static void bi_exit(interp_state_t *state) static void bi_float_to_string(interp_state_t *state) { char buffer[32]; - native_float_t flt = get_float(CAR(state->argv.value)); + fpnum_t flt = get_float(CAR(state->argv.value)); snprintf(buffer, sizeof buffer, "%.18g", (double)flt); - interp_return_values(state, cons(string_to_value(buffer), NIL)); + interp_return_values(state, make_pair(string_to_value(buffer), NIL)); +} + +static fixnum_t dbj2_hash(uint8_t *bytes, size_t size) +{ + fixnum_t hash = 5381; + + for (size_t i = 0; i < size; ++i) + { + hash = (33 * hash) ^ (size_t)bytes[i]; + } + + return hash; +} + +static void bi_hash_by_id(interp_state_t *state) +{ + value_t value = CAR(state->argv.value); + fixnum_t hash; + + if (is_float(value)) + { + fpnum_t fpnum = get_float(value); + hash = dbj2_hash((uint8_t*)&fpnum, sizeof fpnum); + } + else if (is_builtin_fn(value)) + { + builtin_fn_t *fn = get_builtin_fn(value); + hash = dbj2_hash((uint8_t*)&fn, sizeof fn); + } + else + { + hash = dbj2_hash((uint8_t*)&value, sizeof value); + } + + interp_return_values(state, make_pair(make_fixnum((value_t)hash >> 1), NIL)); +} + +static fixnum_t combine_hashes(fixnum_t h1, fixnum_t h2) +{ + return h1 ^ (h2 + 0x9e3779b9 + (h1 << 6) + (h1 >> 2)); +} + +static fixnum_t hash_by_value(value_t v, seen_value_t *seen) +{ + if (is_float(v)) + { + fpnum_t fpnum = get_float(v); + return dbj2_hash((uint8_t*)&fpnum, sizeof fpnum); + } + else if (is_builtin_fn(v)) + { + builtin_fn_t *fn = get_builtin_fn(v); + return dbj2_hash((uint8_t*)&fn, sizeof fn); + } + else if (is_byte_string(v)) + { + byte_string_t *str = get_byte_string(v); + return dbj2_hash(str->bytes, str->nbytes); + } + else if (!is_object(v)) + { + /* Non-objects compare by value */ + return dbj2_hash((uint8_t*)&v, sizeof v); + } + else + { + seen_value_t new_seen = { v, seen }; + + for (seen_value_t *sv = seen; sv; sv = sv->prev) + { + if (v == sv->value) + { + return 0; + } + } + + if (is_box(v)) + { + return combine_hashes(OBJECT_TAG_BOX, + hash_by_value(get_box(v)->value, &new_seen)); + } + else if (is_weak_box(v)) + { + return combine_hashes(OBJECT_TAG_WEAK_BOX, + hash_by_value(get_weak_box(v)->value, &new_seen)); + } + else if (is_pair(v)) + { + return combine_hashes(OBJECT_TAG_PAIR, + combine_hashes(hash_by_value(CAR(v), &new_seen), + hash_by_value(CDR(v), &new_seen))); + } + else if (is_vector(v)) + { + vector_t *vec = get_vector(v); + fixnum_t hash = OBJECT_TAG_VECTOR; + int i; + + for (i = 0; i < vec->nelements; ++i) + hash = combine_hashes(hash, hash_by_value(vec->elements[i], &new_seen)); + + return hash; + } + else if (is_struct(v)) + { + struct_t *str = get_struct(v); + fixnum_t hash = combine_hashes(OBJECT_TAG_STRUCT, hash_by_value(str->type, &new_seen)); + int i; + + for (i = 0; i < str->nslots; ++i) + hash = combine_hashes(hash, hash_by_value(str->slots[i], &new_seen)); + + return hash; + } + else + { + /* Shouldn't encounter anything else, but if so, use the object ID */ + return dbj2_hash((uint8_t*)&v, sizeof v); + } + } +} + +static void bi_hash_by_value(interp_state_t *state) +{ + value_t value = CAR(state->argv.value); + fixnum_t hash = hash_by_value(value, NULL); + interp_return_values(state, make_pair(make_fixnum((value_t)hash >> 1), NIL)); } /* vim:set sw=2 expandtab: */ diff --git a/builtin.h b/builtin.h index 04927a4..3749042 100644 --- a/builtin.h +++ b/builtin.h @@ -30,6 +30,8 @@ #define BI_CALL_WITH_CONTEXT "call-with-context" #define BI_EXIT "exit" #define BI_FLOAT_TO_STRING "float->string" +#define BI_HASH_BY_ID "hash-by-id" +#define BI_HASH_BY_VALUE "hash-by-value" /* Lambda: Instances of this structure are fundamental callable objects. */ #define LAMBDA_SLOT_GLOBAL_VARS 0 diff --git a/doc/bytecode.txt b/doc/bytecode.txt index 4beac74..d7c5570 100644 --- a/doc/bytecode.txt +++ b/doc/bytecode.txt @@ -100,7 +100,7 @@ unary-expr: up to 256, 1 in, prefix = 00 00 29 (byte-string-size in) 2a (struct-nslots in) 2b (struct-type in) - 2c (hash-value in) + 2c (object-id in) ; ISO C floating-point 30 (acos in) diff --git a/gc.c b/gc.c index df58cfb..e2119d0 100644 --- a/gc.c +++ b/gc.c @@ -18,21 +18,33 @@ #include #endif +/****************************************************************************/ + #if _CLOCK_MONOTONIC # define TIMING_CLOCK CLOCK_MONOTONIC #else # define TIMING_CLOCK CLOCK_REALTIME #endif -gc_stats_t gc_stats; +#define FLAG_PROC_BIT ((uint8_t)0x20) +#define FLAG_LIVE_BIT ((uint8_t)0x10) + +#define FLAG_GC_BITS ((uint8_t)0x30) +#define FLAG_TAG_BITS ((uint8_t)0x0f) + +/* Helper macros to reduce duplication */ +#define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem))) +#define BYTESTR_BYTES(nbytes) (sizeof(byte_string_t) + (nbytes)) +#define STRUCT_BYTES(nslots) (sizeof(struct_t) + (sizeof(value_t) * (nslots))) + +#define GC_MIN(x, y) (((y)<(x))?(y):(x)) +#define GC_MAX(x, y) (((y)>(x))?(y):(x)) #define GC_DEBUG_LEVEL_TRACE 3 #define GC_DEBUG_LEVEL_INFO 2 #define GC_DEBUG_LEVEL_WARN 1 #define GC_DEBUG_LEVEL_QUIET 0 -static int gc_debug_level = GC_DEBUG_LEVEL_QUIET; - #define debug_warn(fmt, args...) \ ((gc_debug_level >= GC_DEBUG_LEVEL_WARN) ? (void)(fprintf(stderr,fmt,##args)) : (void)0) @@ -42,18 +54,7 @@ static int gc_debug_level = GC_DEBUG_LEVEL_QUIET; #define debug_trace(fmt, args...) \ ((gc_debug_level >= GC_DEBUG_LEVEL_TRACE) ? (void)(fprintf(stderr,fmt,##args)) : (void)0) -/* Helper macros to reduce duplication */ -#define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem))) -#define BYTESTR_BYTES(size) (sizeof(byte_string_t) + (size)) -#define STRUCT_BYTES(nslots) (sizeof(struct_t) + (sizeof(value_t) * (nslots))) - -/* Alignment must ensure each object has enough room to hold a forwarding object */ -#define GC_ALIGNMENT ((size_t)(sizeof(object_t))) - -/* Smaller block sizes allow for more precise GC, but require more memory for the bitmap. */ -/* The block bitmap will be allocated at startup assuming a max. heap size of 2GB. */ -/* The default of 128 KB/block should require a 2 KB bitmap. */ -#define GC_DIRTY_BLOCK_SIZE (128UL << 10) +/****************************************************************************/ typedef struct seen_value { @@ -63,9 +64,24 @@ typedef struct seen_value /****************************************************************************/ +const char *const object_tag_names[16] = { + "special", "box", "weak box", "pair", "fpnum", "builtin", "(6)", "(7)", + "vector", "byte string", "struct", "will", "(12)", "(13)", "(14)", "(15)" +}; + +object_block_t object_blocks[OBJECT_BLOCK_MAX + 1]; +gc_stats_t gc_stats; + +static value_t gc_free_list; static value_t gc_weak_box_list; static value_t gc_will_list; static value_t gc_will_active_list; +static value_t gc_next_live_value; + +static size_t gc_live_bytes; /* as of last GC pass */ +static size_t gc_total_bytes; /* as of last allocate_object()/free_object() or GC pass */ + +static bool gc_enabled; static gc_root_t gc_root_list = { .value = UNDEFINED, @@ -75,6 +91,232 @@ static gc_root_t gc_root_list = { static gc_root_t structure_type_root; +static int gc_debug_level = GC_DEBUG_LEVEL_QUIET; + +/****************************************************************************/ + +static inline value_t value_from_index(int blk, int idx); + +static void allocate_block(void); +static value_t allocate_object(int tag); +static void free_object(value_t value); +static void clear_gc_flag_bits(void); + +static inline bool is_object_live(value_t value); +static inline bool is_object_processed(value_t value); +static inline void set_object_live(value_t value); +static inline void set_object_processed(value_t value); +static inline void clear_object_live(value_t value); +static inline void clear_object_processed(value_t value); + +/* The 'will' accessors are private to the GC, unlike other similar routines. */ +static inline bool is_will(value_t value); +static inline will_t *get_will(value_t value); +static value_t make_will(value_t value, value_t finalizer); + +/****************************************************************************/ + +static inline uint8_t *_get_flags(value_t value) +{ + return &object_blocks[OBJECT_BLOCK(value)].flag_bits[OBJECT_INDEX(value)]; +} + +static inline value_t value_from_index(int blk, int idx) +{ + int tag = (int)object_blocks[blk].flag_bits[idx] & FLAG_TAG_BITS; + + /* Unallocated objects have zeroed flag bitfields */ + if (tag == 0) return UNDEFINED; + + return OBJECT(blk, idx, tag); +} + +static void allocate_block(void) +{ + int blk; + + for (blk = 0; blk <= OBJECT_BLOCK_MAX; ++blk) + { + object_block_t *block = &object_blocks[blk]; + + /* stop at first unallocated block */ + if (!block->objects) + { + int idx; + + block->objects = (object_t*)calloc(OBJECT_INDEX_MAX+1, sizeof(object_t)); + + if (!block->objects) + { + release_assert(NOTREACHED("out of memory")); + return; + } + + block->flag_bits = (uint8_t*)calloc(OBJECT_INDEX_MAX+1, sizeof(uint8_t)); + + if (!block->flag_bits) + { + free(block->objects); + block->objects = NULL; + release_assert(NOTREACHED("out of memory")); + return; + } + + /* Connect the objects inside the block into a linked list */ + for (idx = 0; idx < OBJECT_INDEX_MAX; ++idx) + { + /* Any object type would work here; box is simplest */ + block->objects[idx].next = OBJECT(blk, idx+1, OBJECT_TAG_BOX); + } + + /* Prepend the list of objects in the block to the free list */ + block->objects[OBJECT_INDEX_MAX].next = gc_free_list; + gc_free_list = OBJECT(blk, 0, OBJECT_TAG_BOX); + + return; + } + } + + /* reached end of block array without finding any unallocated */ + release_assert(NOTREACHED("out of object blocks")); +} + +static value_t allocate_object(int tag) +{ + assert((0 <= tag) && (tag <= 15)); + + /* + ** Run GC when total memory used is 75% more than either total + ** live after last GC pass, or 4MB, whichever is greater. + */ + if ((4 * gc_total_bytes) >= (7 * GC_MAX(gc_live_bytes, 4 * 1024 * 1024))) + { + if (gc_enabled) + { + collect_garbage(); + } + } + + if (is_nil(gc_free_list)) + { + allocate_block(); + assert(!is_nil(gc_free_list)); + } + + { + int blk = OBJECT_BLOCK(gc_free_list); + int idx = OBJECT_INDEX(gc_free_list); + value_t result = OBJECT(blk, idx, tag); + + gc_free_list = _get_object(gc_free_list)->next; + gc_total_bytes += sizeof(object_t); + + *_get_flags(result) = (uint8_t)tag; + memset(_get_object(result), 0, sizeof(object_t)); + + return result; + } +} + +static void free_object(value_t value) +{ + object_t *obj = _get_object(value); + + if (is_vector(value)) + { + gc_total_bytes -= VECTOR_BYTES(obj->vector->nelements); + free(obj->vector); + } + else if (is_byte_string(value)) + { + gc_total_bytes -= BYTESTR_BYTES(obj->byte_string->nbytes); + free(obj->byte_string); + } + else if (is_struct(value)) + { + gc_total_bytes -= STRUCT_BYTES(obj->structure->nslots); + free(obj->structure); + } + else if (is_will(value)) + { + gc_total_bytes -= sizeof(will_t); + free(obj->will); + } + + *_get_flags(value) = 0; + obj->next = gc_free_list; + + gc_total_bytes -= sizeof(object_t); + gc_free_list = value; +} + +/* Prepare for GC by clearing all "live" and "processed" bits */ +static void clear_gc_flag_bits(void) +{ + int blk; + + for (blk = 0; (blk <= OBJECT_BLOCK_MAX) && object_blocks[blk].objects; ++blk) + { + object_block_t *block = &object_blocks[blk]; + int idx; + + for (idx = 0; idx <= OBJECT_INDEX_MAX; ++idx) + { + block->flag_bits[idx] &= ~FLAG_GC_BITS; + } + } +} + +static inline bool is_object_live(value_t v) +{ + /* non-objects can't be added to the free list, so they're always "live" */ + return !is_object(v) || (*_get_flags(v) & FLAG_LIVE_BIT) != 0; +} + +static inline bool is_object_processed(value_t v) +{ + /* non-objects don't need to be processed */ + return !is_object(v) || (*_get_flags(v) & FLAG_PROC_BIT) != 0; +} + +static inline void set_object_live(value_t v) +{ + assert(is_object(v)); + *_get_flags(v) |= FLAG_LIVE_BIT; +} + +static inline void set_object_processed(value_t v) +{ + assert(is_object(v)); + *_get_flags(v) |= FLAG_PROC_BIT; +} + +static inline void clear_object_live(value_t v) +{ + assert(is_object(v)); + *_get_flags(v) &= ~FLAG_LIVE_BIT; +} + +static inline void clear_object_processed(value_t v) +{ + assert(is_object(v)); + *_get_flags(v) &= ~FLAG_PROC_BIT; +} + +/****************************************************************************/ + +static inline bool is_will(value_t value) +{ + return is_object_type(value, OBJECT_TAG_WILL); +} + +static inline will_t *get_will(value_t value) +{ + return _get_typed_object(value, OBJECT_TAG_WILL)->will; +} + +/****************************************************************************/ + void register_gc_root(gc_root_t *root, value_t v) { root->value = v; @@ -99,218 +341,218 @@ void unregister_gc_root(gc_root_t *root) /****************************************************************************/ -static value_t make_hash_value(void) +value_t make_box(value_t init) { - static fixnum_t hash_seed = (fixnum_t)0x5e1dd160053438c6uLL; - hash_seed = (33 * hash_seed) ^ (fixnum_t)clock(); - hash_seed ^= hash_seed << 31; - hash_seed ^= hash_seed << 13; - hash_seed ^= hash_seed << 7; - return fixnum_value(hash_seed); + gc_root_t init_root; + value_t result; + + register_gc_root(&init_root, init); + result = allocate_object(OBJECT_TAG_BOX); + unregister_gc_root(&init_root); + + get_box(result)->value = init; + + return result; } -bool get_boolean(value_t v) +value_t make_weak_box(value_t init) { - release_assert(is_boolean(v)); - return (v != FALSE_VALUE); + gc_root_t init_root; + value_t result; + + register_gc_root(&init_root, init); + result = allocate_object(OBJECT_TAG_WEAK_BOX); + unregister_gc_root(&init_root); + + get_weak_box(result)->value = init; + get_weak_box(result)->next = gc_weak_box_list; + + gc_weak_box_list = result; + + return result; } -fixnum_t get_fixnum(value_t v) +value_t make_pair(value_t car, value_t cdr) { - release_assert(is_fixnum(v)); - return _get_fixnum(v); -} - -object_t *get_object(value_t v) -{ - release_assert(is_object(v)); - return _get_object(v); -} - -/* No one outside this module should care... */ -static inline bool is_broken_heart(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == BROKEN_HEART); -} - -value_t cons(value_t car, value_t cdr) -{ - gc_root_t car_root, cdr_root; - pair_t *p; + gc_root_t car_root; + gc_root_t cdr_root; + value_t result; register_gc_root(&car_root, car); register_gc_root(&cdr_root, cdr); - p = (pair_t*)gc_alloc(sizeof(pair_t)); - p->car = car_root.value; - p->cdr = cdr_root.value; + result = allocate_object(OBJECT_TAG_PAIR); unregister_gc_root(&car_root); unregister_gc_root(&cdr_root); - return pair_value(p); + get_pair(result)->car = car; + get_pair(result)->cdr = cdr; + + return result; } -pair_t *get_pair(value_t v) +value_t make_float(fpnum_t value) { - release_assert(is_pair(v)); - return _get_pair(v); + value_t result = allocate_object(OBJECT_TAG_FPNUM); + _get_object(result)->fpnum = value; + return result; } -value_t make_box(value_t initial_value) +value_t make_builtin_fn(builtin_fn_t *fn) { - gc_root_t iv_root; - box_t *box; - - register_gc_root(&iv_root, initial_value); - - box = (box_t*)gc_alloc(sizeof(box_t)); - box->tag = TYPE_TAG_BOX; - box->value = iv_root.value; - - unregister_gc_root(&iv_root); - - return object_value(box); + value_t result = allocate_object(OBJECT_TAG_BUILTIN_FN); + _get_object(result)->builtin_fn = fn; + return result; } -box_t *get_box(value_t v) +value_t make_vector(size_t nelem, value_t init) { - release_assert(is_box(v)); - return _get_box(v); -} + gc_root_t init_root; + value_t result; + vector_t *vec; -value_t make_vector(size_t nelem, value_t initial_value) -{ - gc_root_t iv_root; - vector_t *vec; + register_gc_root(&init_root, init); + result = allocate_object(OBJECT_TAG_VECTOR); + unregister_gc_root(&init_root); - register_gc_root(&iv_root, initial_value); + vec = (vector_t*)malloc(VECTOR_BYTES(nelem)); + release_assert(vec != NULL); + + gc_total_bytes += VECTOR_BYTES(nelem); + _get_object(result)->vector = vec; - vec = (vector_t*)gc_alloc(VECTOR_BYTES(nelem)); - vec->tag = TYPE_TAG_VECTOR; - vec->size = nelem; - vec->hash = make_hash_value(); vec->immutable = false; + vec->nelements = nelem; - for (int i = 0; i < nelem; ++i) - vec->elements[i] = iv_root.value; + for (size_t i = 0; i < nelem; ++i) + vec->elements[i] = init; - unregister_gc_root(&iv_root); - - return object_value(vec); + return result; } -vector_t *get_vector(value_t v) +value_t make_byte_string(size_t nbytes, int init) { - release_assert(is_vector(v)); - return _get_vector(v); + value_t result; + byte_string_t *bstr; + + result = allocate_object(OBJECT_TAG_BYTE_STRING); + + bstr = (byte_string_t*)malloc(BYTESTR_BYTES(nbytes)); + release_assert(bstr != NULL); + + gc_total_bytes += BYTESTR_BYTES(nbytes); + _get_object(result)->byte_string = bstr; + + bstr->immutable = false; + bstr->nbytes = nbytes; + + memset(bstr->bytes, init, nbytes); + + return result; } -value_t make_byte_string(size_t size, int default_value) +value_t make_struct(value_t type) { - const size_t nbytes = BYTESTR_BYTES(size); - byte_string_t *str; - - str = (byte_string_t*)gc_alloc(nbytes); - str->tag = TYPE_TAG_BYTESTR; - str->size = size; + gc_root_t type_root; + fixnum_t nslots; + value_t result; + struct_t *str; + + register_gc_root(&type_root, type); + + release_assert(struct_is_a(type, get_structure_type())); + release_assert(get_struct(type)->immutable); + + nslots = get_fixnum(SLOT_VALUE(STRUCTURE, type, NSLOTS)); + + result = allocate_object(OBJECT_TAG_STRUCT); + + unregister_gc_root(&type_root); + + str = (struct_t*)malloc(STRUCT_BYTES(nslots)); + release_assert(str != NULL); + + gc_total_bytes += STRUCT_BYTES(nslots); + _get_object(result)->structure = str; + str->immutable = false; + str->nslots = nslots; + str->type = type; - memset(str->bytes, default_value, size); + for (int i = 0; i < nslots; ++i) + str->slots[i] = UNDEFINED; - return object_value(str); + return result; } -byte_string_t *get_byte_string(value_t v) +/* wills can only be created in this module, via register_finalizer() */ +static value_t make_will(value_t value, value_t finalizer) { - release_assert(is_byte_string(v)); - return _get_byte_string(v); + gc_root_t value_root; + gc_root_t finalizer_root; + value_t result; + will_t *will; + + register_gc_root(&value_root, value); + register_gc_root(&finalizer_root, finalizer); + + result = allocate_object(OBJECT_TAG_WILL); + + unregister_gc_root(&value_root); + unregister_gc_root(&finalizer_root); + + will = (will_t*)malloc(sizeof(will_t)); + release_assert(will != NULL); + + gc_total_bytes += sizeof(will_t); + _get_object(result)->will = will; + + will->value = value; + will->finalizer = finalizer; + will->next = gc_will_list; + gc_will_list = result; + + return result; } +/****************************************************************************/ + value_t string_to_value(const char *s) { size_t len = strlen(s); value_t v = make_byte_string(len, '\0'); - memcpy(_get_byte_string(v)->bytes, s, len); + memcpy(get_byte_string(v)->bytes, s, len); return v; } char *value_to_string(value_t v) { byte_string_t *str = get_byte_string(v); - char *s = (char*)malloc(str->size + 1); + char *s = (char*)malloc(str->nbytes + 1); - memcpy(s, str->bytes, str->size); - s[str->size] = '\0'; + memcpy(s, str->bytes, str->nbytes); + s[str->nbytes] = '\0'; return s; } int byte_strcmp(value_t s1, value_t s2) { - byte_string_t *str1 = get_byte_string(s1); - byte_string_t *str2 = get_byte_string(s2); + byte_string_t *bstr1 = get_byte_string(s1); + byte_string_t *bstr2 = get_byte_string(s2); + int cmp = memcmp(bstr1->bytes, bstr2->bytes, GC_MIN(bstr1->nbytes, bstr2->nbytes)); - if (str1->size < str2->size) - return -1; - else if (str1->size > str2->size) - return 1; - else - return memcmp(str1->bytes, str2->bytes, str1->size); -} + if (cmp == 0) + { + /* Prefix is the same, so compare lengths */ + if (bstr1->nbytes < bstr2->nbytes) + cmp = -1; + else if (bstr1->nbytes > bstr2->nbytes) + cmp = 1; + } -value_t make_struct(value_t type) -{ - gc_root_t type_root; - fixnum_t nslots; - struct_t *s; - - register_gc_root(&type_root, type); - - release_assert(struct_is_a(type_root.value, get_structure_type())); - release_assert(_get_struct(type_root.value)->immutable); - nslots = get_fixnum(_SLOT_VALUE(STRUCTURE, type_root.value, NSLOTS)); - - s = (struct_t*)gc_alloc(STRUCT_BYTES(nslots)); - s->tag = TYPE_TAG_STRUCT; - s->type = type_root.value; - s->nslots = nslots; - s->hash = make_hash_value(); - s->immutable = false; - - for (int i = 0; i < nslots; ++i) - s->slots[i] = UNDEFINED; - - unregister_gc_root(&type_root); - - return object_value(s); -} - -static void structure_init(void) -{ - struct_t *s; - - /* Instances of this structure describe structures. */ - /* It is both a structure and a structure description, and thus an instance of itself. */ - s = (struct_t*)gc_alloc(STRUCT_BYTES(STRUCTURE_SLOTS)); - s->tag = TYPE_TAG_STRUCT; - s->type = object_value(s); - s->nslots = STRUCTURE_SLOTS; - s->hash = make_hash_value(); - - register_gc_root(&structure_type_root, object_value(s)); - - /* Slot 1: List of superclasses, most to least specific */ - _get_struct(structure_type_root.value)->slots[STRUCTURE_SLOT_SUPERS] = NIL; - - /* Slot 2: Total number of slots (excl. type) */ - _get_struct(structure_type_root.value)->slots[STRUCTURE_SLOT_NSLOTS] = fixnum_value(STRUCTURE_SLOTS); - - /* Slot 3: Callable object used as proxy when structure is APPLY'd. */ - /* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */ - _get_struct(structure_type_root.value)->slots[STRUCTURE_SLOT_CALLABLE] = FALSE_VALUE; - - _get_struct(structure_type_root.value)->immutable = true; + return cmp; } value_t get_structure_type(void) @@ -318,24 +560,31 @@ value_t get_structure_type(void) return structure_type_root.value; } -value_t make_struct_type(value_t supers, fixnum_t nslots, value_t callable) +value_t make_struct_type(value_t super, fixnum_t nslots, value_t callable) { - gc_root_t supers_root; + gc_root_t super_root; gc_root_t callable_root; - value_t result; + value_t result; - register_gc_root(&supers_root, supers); + register_gc_root(&super_root, super); register_gc_root(&callable_root, callable); - result = make_struct(get_structure_type()); - _get_struct(result)->slots[STRUCTURE_SLOT_SUPERS] = supers; - _get_struct(result)->slots[STRUCTURE_SLOT_NSLOTS] = fixnum_value(nslots); - _get_struct(result)->slots[STRUCTURE_SLOT_CALLABLE] = callable; - _get_struct(result)->immutable = true; + if (super != FALSE_VALUE) + { + release_assert(struct_is_a(super, get_structure_type())); + release_assert(get_struct(super)->immutable); + } - unregister_gc_root(&supers_root); + result = make_struct(get_structure_type()); + + unregister_gc_root(&super_root); unregister_gc_root(&callable_root); + get_struct(result)->slots[STRUCTURE_SLOT_SUPER] = super; + get_struct(result)->slots[STRUCTURE_SLOT_NSLOTS] = make_fixnum(nslots); + get_struct(result)->slots[STRUCTURE_SLOT_CALLABLE] = callable; + get_struct(result)->immutable = true; + return result; } @@ -345,294 +594,98 @@ bool struct_is_a(value_t value, value_t type) /* The trivial cases: non-struct and exact match */ if (!is_struct(value)) return false; - if (_get_struct(value)->type == type) return true; + if (get_struct(value)->type == type) return true; - /* Look for type in supers; detect cycles using "tortoise and hare" algorithm */ - tortoise = _SLOT_VALUE(STRUCTURE, _get_struct(value)->type, SUPERS); - hare = tortoise; + /* Look for type in superclasses; detect cycles using "tortoise and hare" algorithm */ + tortoise = hare = SLOT_VALUE(STRUCTURE, get_struct(value)->type, SUPER); - if (is_nil(hare)) return false; - if (CAR(hare) == type) return true; + do { + if (hare == type) return true; + if (hare == FALSE_VALUE) return false; - hare = _CDR(hare); + release_assert(is_struct(hare)); + hare = SLOT_VALUE(STRUCTURE, hare, SUPER); - if (is_nil(hare)) return false; - if (CAR(hare) == type) return true; + if (hare == type) return true; + if (hare == FALSE_VALUE) return false; - while (hare != tortoise) - { - hare = _CDR(hare); + release_assert(is_struct(hare)); + hare = SLOT_VALUE(STRUCTURE, hare, SUPER); - if (is_nil(hare)) return false; - if (CAR(hare) == type) return true; - - hare = _CDR(hare); - - if (is_nil(hare)) return false; - if (CAR(hare) == type) return true; - - tortoise = CDR(tortoise); - } + /* Tortoise moves ahead one item for every two items covered by hare. */ + /* If there are no cycles in the superclass list, it will always be behind. */ + tortoise = SLOT_VALUE(STRUCTURE, tortoise, SUPER); + } while (hare != tortoise); + /* Tortoise caught up with hare, meaning we detected a cycle. */ + /* If type was in the cycle, it would have been found by now. */ return false; } -struct_t *get_struct(value_t v) -{ - release_assert(is_struct(v)); - return _get_struct(v); -} - -value_t make_weak_box(value_t initial_value) -{ - gc_root_t iv_root; - weak_box_t *box; - - register_gc_root(&iv_root, initial_value); - - box = (weak_box_t*)gc_alloc(sizeof(weak_box_t)); - box->tag = TYPE_TAG_WEAK_BOX; - box->value = iv_root.value; - box->next = gc_weak_box_list; - gc_weak_box_list = object_value(box); - - unregister_gc_root(&iv_root); - - return object_value(box); -} - -weak_box_t *get_weak_box(value_t v) -{ - release_assert(is_weak_box(v)); - return _get_weak_box(v); -} - void register_finalizer(value_t value, value_t finalizer) { /* Non-objects are never GC'd, so their finalizers will never be invoked. */ if (is_object(value)) { - gc_root_t value_root, finalizer_root; - will_t *w; - - register_gc_root(&value_root, value); - register_gc_root(&finalizer_root, finalizer); - - w = (will_t*)gc_alloc(sizeof(will_t)); - w->tag = TYPE_TAG_WILL; - w->value = value_root.value; - w->finalizer = finalizer_root.value; - w->next = gc_will_list; - - gc_will_list = object_value(w); - - unregister_gc_root(&value_root); - unregister_gc_root(&finalizer_root); + (void)make_will(value, finalizer); } } -/* The 'will' accessors are private to the GC, unlike other similar routines. */ -static inline will_t *_get_will(value_t v) -{ - return (will_t*)_get_object(v); -} - -static will_t *get_will(value_t v) -{ - release_assert(is_will(v)); - return _get_will(v); -} - -value_t make_float(native_float_t value) -{ - float_object_t *obj; - - obj = (float_object_t*)gc_alloc(sizeof(float_object_t)); - obj->tag = TYPE_TAG_FLOAT; - obj->value = value; - - return object_value(obj); -} - -native_float_t get_float(value_t v) -{ - if (is_fixnum(v)) - { - return (native_float_t)_get_fixnum(v); - } - else - { - release_assert(is_float(v)); - return _get_float(v); - } -} - -value_t make_builtin_fn(builtin_fn_t *fn) -{ - builtin_fn_object_t *obj; - - obj = (builtin_fn_object_t*)gc_alloc(sizeof(builtin_fn_object_t)); - obj->tag = TYPE_TAG_BUILTIN; - obj->fn = fn; - - return object_value(obj); -} - -builtin_fn_t *get_builtin_fn(value_t v) -{ - release_assert(is_builtin_fn(v)); - return _get_builtin_fn(v); -} - -static fixnum_t dbj2_hash(uint8_t *bytes, size_t size) -{ - fixnum_t hash = 5381; - - for (size_t i = 0; i < size; ++i) - { - hash = (33 * hash) ^ (size_t)bytes[i]; - } - - return hash; -} - -static value_t _get_hash_value(value_t v, seen_value_t *seen) -{ - if (is_float(v)) - { - double d = _get_float(v); - return fixnum_value(dbj2_hash((uint8_t*)&d, sizeof d)); - } - else if (is_byte_string(v)) - { - byte_string_t *str = _get_byte_string(v); - return fixnum_value(dbj2_hash(str->bytes, str->size)); - } - else if (is_builtin_fn(v)) - { - return fixnum_value((uintptr_t)_get_builtin_fn(v) >> 2); - } - else if (!is_object(v)) - { - /* Non-objects compare by value */ - return fixnum_value(v + (v >> 2)); - } - else - { - seen_value_t new_seen = { v, seen }; - - for (seen_value_t *sv = seen; sv; sv = sv->prev) - { - if (v == sv->value) - { - return 0; - } - } - - if (is_pair(v)) - { - /* Lists and trees compare by value, not reference. */ - value_t seed = fixnum_value(0); - seed = combine_hash_values(seed, _get_hash_value(_CAR(v), &new_seen)); - seed = combine_hash_values(seed, _get_hash_value(_CDR(v), &new_seen)); - return seed; - } - else if (is_box(v) || is_weak_box(v)) - { - /* Boxes compare by value, not by reference. */ - return _get_hash_value(_get_box(v)->value, &new_seen); - } - else if (is_vector(v)) - { - /* Vectors compare by reference. */ - return _get_vector(v)->hash; - } - else if (is_struct(v)) - { - /* Structures compare by reference. */ - return _get_struct(v)->hash; - } - else /* unknown object type */ - { - return _get_hash_value(_get_object(v)->tag, &new_seen); - } - } -} - -value_t get_hash_value(value_t v) -{ - value_t hv = _get_hash_value(v, NULL); - return fixnum_value(_get_fixnum(hv) & FIXNUM_MAX); -} - -value_t combine_hash_values(value_t f1, value_t f2) -{ - fixnum_t h1 = _get_fixnum(f1); - fixnum_t h2 = _get_fixnum(f2); - return fixnum_value(h1 ^ (h2 + 0x9e3779b9 + (h1 << 6) + (h1 >> 2))); -} - /*************************** Common Collector Code **************************/ -static bool gc_enabled; -static bool gc_in_gen0_collection; -static bool gc_in_gen1_collection; - -/* Also used from Gen-0 code to track new Gen-1 objects */ -static char *gc_gen1_ranges[2]; -static size_t gc_gen1_min_size; -static size_t gc_gen1_max_size; -static size_t gc_gen1_soft_limit; - -static int gc_gen1_current_range; -static char *gc_gen1_free_ptr; -static char *gc_gen1_range_end; - -static size_t gc_gen1_max_blocks; -static uint32_t *gc_gen1_dirty_bits; -static char **gc_gen1_block_starts; - -/* A convenient shorthand */ -#define gc_gen1_other_range() (1-gc_gen1_current_range) - -static inline size_t gc_align(size_t nbytes) __attribute__ ((const)); -static void transfer_roots(void); -static size_t transfer_children(object_t *obj); +static void structure_init(void); +static void mark_roots_live(void); +static void mark_children_live(value_t parent); static void process_weak_boxes(void); static void process_wills(void); static void update_weak_box_list(void); -static void gc_gen0_init(size_t gen0_size); -static void gc_gen1_init(size_t min_size, size_t max_size); - -static int gc_gen1_range_of(void *object) __attribute__ ((const)); -static size_t gc_gen1_block_of(void *obj) __attribute__ ((const)); -static inline size_t gc_gen1_free_space(void); - -static void *gc_alloc_gen1(size_t nbytes); -static void collect_gen1_garbage(size_t min_free); -static void gc_gen1_clear_dirty_bits(void); - -static inline size_t gc_gen1_free_space(void) +static void structure_init(void) { - return gc_gen1_range_end - gc_gen1_free_ptr; + value_t result; + struct_t *str; + + /* Instances of this structure describe structures. */ + /* It is both a structure and a structure description, and thus an instance of itself. */ + result = allocate_object(OBJECT_TAG_STRUCT); + + str = (struct_t*)malloc(STRUCT_BYTES(STRUCTURE_SLOTS)); + release_assert(str != NULL); + + gc_total_bytes += STRUCT_BYTES(STRUCTURE_SLOTS); + _get_object(result)->structure = str; + + str->immutable = true; + str->type = result; + str->nslots = STRUCTURE_SLOTS; + + /* Slot 1: Superclass, if any, or #f */ + str->slots[STRUCTURE_SLOT_SUPER] = FALSE_VALUE; + + /* Slot 2: Total number of slots (excl. type) */ + str->slots[STRUCTURE_SLOT_NSLOTS] = make_fixnum(STRUCTURE_SLOTS); + + /* Slot 3: Callable object used as proxy when structure is APPLY'd. */ + /* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */ + str->slots[STRUCTURE_SLOT_CALLABLE] = FALSE_VALUE; + + register_gc_root(&structure_type_root, result); } -static inline size_t gc_align(size_t nbytes) -{ - return ((nbytes + GC_ALIGNMENT - 1) & ~(GC_ALIGNMENT - 1)); -} - -void gc_init(size_t gen0_size, size_t gen1_min_size, size_t gen1_max_size) +void gc_init(void) { const char *gc_debug_env; - gc_gen0_init(gen0_size); - gc_gen1_init(gen1_min_size, gen1_max_size); + memset(object_blocks, 0, sizeof object_blocks); + gc_free_list = NIL; gc_weak_box_list = NIL; gc_will_list = NIL; gc_will_active_list = NIL; + gc_next_live_value = NIL; + + gc_live_bytes = 0; + gc_total_bytes = 0; clear_gc_stats(); @@ -671,581 +724,189 @@ void gc_init(size_t gen0_size, size_t gen1_min_size, size_t gen1_max_size) void clear_gc_stats(void) { - int i; + gc_stats.passes = 0; + gc_stats.total_ns = 0; + gc_stats.peak_ns = 0; + gc_stats.total_freed = 0; + gc_stats.peak_allocated = 0; +} - for (i = 0; i < 2; ++i) +static inline void mark_object_live(value_t value) +{ + if (is_object(value) && !is_object_live(value)) { - gc_stats.gen[i].passes = 0; - gc_stats.gen[i].total_ns = 0; - gc_stats.gen[i].max_ns = 0; - gc_stats.gen[i].total_freed = 0; - } + set_object_live(value); - gc_stats.gen1_high_water = 0; -} - -#ifndef NDEBUG -static void gc_poison_region(void *start, size_t size, value_t tag) -{ - size_t count = size / GC_ALIGNMENT; - object_t *obj = (object_t*)start; - - while (count--) - *obj++ = (object_t){ .tag = tag, .forward = tag }; -} -#endif - -/****************************** Gen-0 Collector *****************************/ - -/* These private variables are exported ONLY for use by is_gen0_object(). */ -char *gc_gen0_range; -char *gc_gen0_range_end; - -static size_t gc_gen0_size; -static char *gc_gen0_free_ptr; - -/* Used to signal that Gen-0 pass has been obviated by Gen-1 collection. */ -static jmp_buf gc_gen0_end_ctx; - -static inline size_t gc_gen0_free_space(void) -{ - return gc_gen0_range_end - gc_gen0_free_ptr; -} - -static void gc_gen0_init(size_t gen0_size) -{ - assert(gen0_size >= GC_ALIGNMENT); - - gc_gen0_size = gen0_size; - gc_gen0_range = (char*)malloc(gc_gen0_size); - release_assert(gc_gen0_range); - - gc_gen0_free_ptr = gc_gen0_range; - gc_gen0_range_end = gc_gen0_range + gc_gen0_size; -} - -static void collect_gen0_garbage(void) -{ - if (gc_enabled) - { - size_t initial_gen1_free_space; - -#ifndef NO_STATS - size_t initial_free_space; -#ifndef NO_TIMING_STATS - struct timespec start_time; - clock_gettime(TIMING_CLOCK, &start_time); -#endif - initial_free_space = gc_gen0_free_space() + gc_gen1_free_space(); -#endif - - debug_info("Performing Gen-0 garbage collection pass...\n"); - - assert(!gc_in_gen0_collection); - assert(!gc_in_gen1_collection); - - initial_gen1_free_space = gc_gen1_free_space(); - - /* If we trigger a Gen-1 collection at any point then we are done. */ - /* Full collection will pull in any current Gen-0 objects. */ - if (setjmp(gc_gen0_end_ctx) == 0) + if ((gc_next_live_value > value) || + (gc_next_live_value == NIL)) { - char *object_ptr = gc_gen1_free_ptr; - const size_t used_bytes = gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range]; - const int current_blocks = (used_bytes + GC_DIRTY_BLOCK_SIZE - 1) / GC_DIRTY_BLOCK_SIZE; - const int current_block_groups = (current_blocks + 31) / 32; - int group; - - gc_in_gen0_collection = true; - - /* 1. Transfer Gen-0 roots (ignore Gen-1). */ - transfer_roots(); - - /* 2. Locate and transfer Gen-0 references from dirty Gen-1 blocks. */ - for (group = 0; group < current_block_groups; ++group) - { - uint32_t bits = gc_gen1_dirty_bits[group]; - - if (bits) - { - int block; - - for (block = group * 32; bits; bits >>= 1, ++block) - { - if (bits & 1) - { - /* Find first object in the block */ - char *block_obj = gc_gen1_block_starts[block]; - char *block_end = gc_gen1_ranges[gc_gen1_current_range] - + ((block+1) * GC_DIRTY_BLOCK_SIZE); - - assert(block_obj && (gc_gen1_block_of(block_obj) == block)); - - /* For each object in block: transfer children */ - do { - block_obj += gc_align(transfer_children((object_t*)block_obj)); - assert(gc_gen1_range_of(block_obj) == gc_gen1_current_range); - } while (block_obj < block_end); - } - } - } - } - - gc_gen1_clear_dirty_bits(); - - /* Transfer Gen-0 children of objects newly moved to Gen-1 */ - while (object_ptr < gc_gen1_free_ptr) - { - object_ptr += gc_align(transfer_children((object_t*)object_ptr)); - assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range); - } - - /* These have to be examined after normal reachability has been determined */ - process_weak_boxes(); - process_wills(); - - /* - * Keep transferring until no more objects in the new range refer to the old one. - * This is so that values which are otherwise unreachable, but have finalizers which - * may be able to reach them, are not collected prematurely. process_wills() transfers - * the value of any will newly placed on the active list. Note that these values may - * be finalized in any order, and that any weak references have already been cleared. - */ - while (object_ptr < gc_gen1_free_ptr) - { - object_ptr += gc_align(transfer_children((object_t*)object_ptr)); - assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range); - } - - update_weak_box_list(); - -#ifndef NDEBUG - /* Clear old range, to make it easier to detect bugs. */ - gc_poison_region(gc_gen0_range, gc_gen0_size, GC_GEN0_POISON); -#endif - - /* 4. Reset Gen-0 range to 'empty' state. */ - gc_gen0_free_ptr = gc_gen0_range; - - debug_info("Finished Gen-0 collection; added %ld bytes to Gen-1 heap.\n", - (long int)(initial_gen1_free_space - gc_gen1_free_space())); - -#ifndef NO_STATS -#ifndef NO_TIMING_STATS - { - struct timespec end_time; - nsec_t nsec; - - clock_gettime(TIMING_CLOCK, &end_time); - - nsec = (end_time.tv_sec - start_time.tv_sec) * 1000000000LL; - nsec += (end_time.tv_nsec - start_time.tv_nsec); - - gc_stats.gen[0].total_ns += nsec; - - if (nsec > gc_stats.gen[0].max_ns) - gc_stats.gen[0].max_ns = nsec; - } -#endif - gc_stats.gen[0].total_freed -= initial_free_space; - gc_stats.gen[0].total_freed += gc_gen0_free_space(); - gc_stats.gen[0].total_freed += gc_gen1_free_space(); - ++gc_stats.gen[0].passes; -#endif - } - - gc_in_gen0_collection = false; - } -} - -void *gc_alloc(size_t nbytes) -{ - nbytes = gc_align(nbytes); - - assert(!gc_in_gen0_collection); - assert(!gc_in_gen1_collection); - - if (nbytes >= gc_gen0_size) - { - debug_warn("Allocating directly from Gen-1...\n"); - return gc_alloc_gen1(nbytes); - } - else - { - if (nbytes > gc_gen0_free_space()) - { - if (gc_enabled) - collect_gen0_garbage(); - else - return gc_alloc_gen1(nbytes); - } - - assert(nbytes <= gc_gen0_free_space()); - - { - void *const p = gc_gen0_free_ptr; - gc_gen0_free_ptr += nbytes; - return p; + gc_next_live_value = value; } } } -/****************************** Gen-1 Collector *****************************/ - -static int gc_gen1_range_of(void *object) +static void mark_roots_live(void) { - const char *const ptr = (char*)object; - - if ((ptr >= gc_gen1_ranges[0]) && (ptr < (gc_gen1_ranges[0] + gc_gen1_max_size))) - return 0; - else if ((ptr >= gc_gen1_ranges[1]) && (ptr < (gc_gen1_ranges[1] + gc_gen1_max_size))) - return 1; - else - return -1; -} - -static inline bool gc_object_has_moved(value_t v) -{ - return is_broken_heart(v) && - (gc_gen1_range_of(_get_object(_get_object(v)->forward)) == gc_gen1_current_range); -} - -/* Only useful AFTER all reachable objects have been processed. */ -static inline bool gc_object_left_behind(value_t v) -{ - /* Must provide a reference to the original location, not the new one (if moved). */ - assert(!is_object(v) || - is_gen0_object(v) || - gc_in_gen0_collection || - (gc_gen1_range_of(_get_object(v)) != gc_gen1_current_range)); - - return is_object(v) && - (gc_in_gen1_collection || is_gen0_object(v)) && - (!is_broken_heart(v) || (gc_gen1_range_of(_get_object(_get_object(v)->forward)) != - gc_gen1_current_range)); -} - -static void gc_gen1_init(size_t min_size, size_t max_size) -{ - release_assert(gc_gen0_size > 0); - release_assert(max_size >= gc_gen0_size); - release_assert(min_size <= (max_size - gc_gen0_size)); - - gc_gen1_ranges[0] = (char*)malloc(max_size); - gc_gen1_ranges[1] = (char*)malloc(max_size); - - release_assert(gc_gen1_ranges[0] && gc_gen1_ranges[1]); - - gc_gen1_current_range = 0; - gc_gen1_free_ptr = gc_gen1_ranges[gc_gen1_current_range]; - - gc_gen1_min_size = min_size; - gc_gen1_max_size = max_size; - gc_gen1_soft_limit = min_size + gc_gen0_size; - gc_gen1_range_end = gc_gen1_free_ptr + gc_gen1_soft_limit; - - gc_gen1_max_blocks = ((size_t)2 << 30) / GC_DIRTY_BLOCK_SIZE; - - gc_gen1_dirty_bits = (uint32_t*)calloc((gc_gen1_max_blocks + 31) / 32, sizeof(uint32_t)); - release_assert(gc_gen1_dirty_bits); - - gc_gen1_block_starts = (char**)calloc(gc_gen1_max_blocks, sizeof(char*)); - release_assert(gc_gen1_block_starts); -} - -static void gc_gen1_clear_dirty_bits(void) -{ - const size_t block_groups = (gc_gen1_max_blocks + 31) / 32; - memset(gc_gen1_dirty_bits, 0, sizeof(uint32_t) * block_groups); -} - -static void *gc_alloc_gen1(size_t nbytes) -{ - size_t min_free; - - min_free = nbytes = gc_align(nbytes); - - /* Ensure there is always enough room for a full collection. */ - if (!gc_in_gen1_collection) - min_free += gc_gen0_size; - - if (gc_gen1_free_space() < min_free) - collect_gen1_garbage(min_free); - - assert(nbytes <= gc_gen1_free_space()); - - { - void *const p = gc_gen1_free_ptr; - const size_t block = gc_gen1_block_of(p); - - if (!gc_gen1_block_starts[block]) - gc_gen1_block_starts[block] = (char*)p; - - gc_gen1_free_ptr += nbytes; - return p; - } -} - -static void transfer_object(value_t *value) -{ - /* During Gen-0 collection pass, leave Gen-1 objects alone. Always ignore non-objects. */ - if (is_object(*value) && (gc_in_gen1_collection || is_gen0_object(*value))) - { - object_t *obj = _get_object(*value); - size_t nbytes; - void *newobj; - - assert(is_gen0_object(*value) || - (gc_gen1_range_of(obj) == gc_gen1_other_range())); - - if (obj->tag == BROKEN_HEART) - { - if (gc_gen1_range_of(_get_object(obj->forward)) != gc_gen1_current_range) - { - /* Gen-0 object was transferred into old range; needs to move to current range */ - transfer_object(&obj->forward); - } - - assert(gc_gen1_range_of(_get_object(obj->forward)) == gc_gen1_current_range); - - /* Object has already been moved; just update the reference */ - *value = obj->forward; - return; - } - - switch (obj->tag) - { - case TYPE_TAG_BOX: - nbytes = sizeof(box_t); - break; - case TYPE_TAG_VECTOR: - nbytes = VECTOR_BYTES(((const vector_t*)obj)->size); - break; - case TYPE_TAG_BYTESTR: - nbytes = BYTESTR_BYTES(((const byte_string_t*)obj)->size); - break; - case TYPE_TAG_STRUCT: - nbytes = STRUCT_BYTES(((const struct_t*)obj)->nslots); - break; - case TYPE_TAG_WEAK_BOX: - nbytes = sizeof(weak_box_t); - break; - case TYPE_TAG_WILL: - nbytes = sizeof(will_t); - break; - case TYPE_TAG_FLOAT: - nbytes = sizeof(float_object_t); - break; - case TYPE_TAG_BUILTIN: - nbytes = sizeof(builtin_fn_object_t); - break; - default: /* pair */ - nbytes = sizeof(pair_t); - break; - } - - newobj = gc_alloc_gen1(nbytes); - memcpy(newobj, obj, nbytes); - - /* Keep the original tag bits (pair or object) */ - obj->tag = BROKEN_HEART; - *value = obj->forward = (object_value(newobj) & ~2) | (*value & 2); - } -} - -static size_t transfer_vector(vector_t *vec) -{ - assert(vec->tag == TYPE_TAG_VECTOR); - - /* Should be fixnum, but just in case... */ - transfer_object(&vec->hash); - - for (size_t i = 0; i < vec->size; ++i) - transfer_object(&vec->elements[i]); - - return VECTOR_BYTES(vec->size); -} - -static size_t transfer_struct(struct_t *s) -{ - assert(s->tag == TYPE_TAG_STRUCT); - - transfer_object(&s->type); - - /* Should be fixnum, but just in case... */ - transfer_object(&s->hash); - - for (size_t i = 0; i < s->nslots; ++i) - transfer_object(&s->slots[i]); - - return STRUCT_BYTES(s->nslots); -} - -static size_t transfer_box(box_t *b) -{ - transfer_object(&b->value); - return sizeof(box_t); -} - -static size_t transfer_pair(pair_t *p) -{ - transfer_object(&p->car); - transfer_object(&p->cdr); - return sizeof(pair_t); -} - -static size_t transfer_will(will_t *w) -{ - assert(w->tag == TYPE_TAG_WILL); - - transfer_object(&w->finalizer); - - /* Weak boxes are discarded when there are no other references, - * but wills need to remain until their finalizers are invoked. */ - transfer_object(&w->next); - - return sizeof(will_t); -} - -static size_t transfer_children(object_t *obj) -{ - switch (obj->tag) - { - case TYPE_TAG_BOX: - return transfer_box((box_t*)obj); - case TYPE_TAG_VECTOR: - return transfer_vector((vector_t*)obj); - case TYPE_TAG_BYTESTR: - return BYTESTR_BYTES(((const byte_string_t*)obj)->size); - case TYPE_TAG_STRUCT: - return transfer_struct((struct_t*)obj); - case TYPE_TAG_WEAK_BOX: - return sizeof(weak_box_t); - case TYPE_TAG_WILL: - return transfer_will((will_t*)obj); - case TYPE_TAG_FLOAT: - return sizeof(float_object_t); - case TYPE_TAG_BUILTIN: - return sizeof(builtin_fn_object_t); - default: /* pair */ - return transfer_pair((pair_t*)obj); - } -} - -static void swap_gen1_gc_ranges(void) -{ - gc_gen1_current_range = gc_gen1_other_range(); - gc_gen1_free_ptr = gc_gen1_ranges[gc_gen1_current_range]; - gc_gen1_range_end = gc_gen1_free_ptr + gc_gen1_soft_limit; -} - -static void transfer_roots(void) -{ - /* Transfer registered GC roots */ + /* Mark registered GC roots as live */ for (gc_root_t *root = gc_root_list.next; root != &gc_root_list; root = root->next) - transfer_object(&root->value); + { + mark_object_live(root->value); + } - /* Ensure pending will list is transferred */ - transfer_object(&gc_will_list); + /* Pending wills and associated finalizers are also roots */ + for (value_t will = gc_will_list; !is_nil(will); will = get_will(will)->next) + { + mark_object_live(will); + mark_object_live(get_will(will)->finalizer); - /* The values associated with active wills are also roots */ - for (value_t will = gc_will_active_list; !is_nil(will); will = _get_will(will)->next) - transfer_object(&get_will(will)->value); + /* Processing for values of pending wills occurs separately from the main GC */ + set_object_processed(will); + } - /* Ensure active list itself is transferred */ - transfer_object(&gc_will_active_list); + /* Active wills and associated values and finalizers are also roots */ + for (value_t will = gc_will_active_list; !is_nil(will); will = get_will(will)->next) + { + mark_object_live(will); + mark_object_live(get_will(will)->value); + mark_object_live(get_will(will)->finalizer); + + /* No further processing is required for active wills */ + set_object_processed(will); + } +} + +static void mark_children_live(value_t value) +{ + if (is_box(value)) + { + mark_object_live(get_box(value)->value); + } + else if (is_pair(value)) + { + mark_object_live(get_pair(value)->car); + mark_object_live(get_pair(value)->cdr); + } + else if (is_vector(value)) + { + vector_t *vec = get_vector(value); + int i; + + for (i = 0; i < vec->nelements; ++i) + mark_object_live(vec->elements[i]); + } + else if (is_struct(value)) + { + struct_t *str = get_struct(value); + int i; + + mark_object_live(str->type); + + for (i = 0; i < str->nslots; ++i) + mark_object_live(str->slots[i]); + } +} + +static value_t next_live_object(void) +{ + int blk; + int idx; + + if (is_nil(gc_next_live_value)) + return NIL; + + blk = OBJECT_BLOCK(gc_next_live_value); + + for (idx = OBJECT_INDEX(gc_next_live_value); idx <= OBJECT_INDEX_MAX; ++idx) + { + uint8_t flags = object_blocks[blk].flag_bits[idx]; + + if ((flags & (FLAG_LIVE_BIT | FLAG_PROC_BIT)) == FLAG_LIVE_BIT) + { + gc_next_live_value = value_from_index(blk, idx);; + return gc_next_live_value;; + } + } + + for (++blk; (blk <= OBJECT_BLOCK_MAX) && object_blocks[blk].objects; ++blk) + { + for (idx = 0; idx <= OBJECT_INDEX_MAX; ++idx) + { + uint8_t flags = object_blocks[blk].flag_bits[idx]; + + if ((flags & (FLAG_LIVE_BIT | FLAG_PROC_BIT)) == FLAG_LIVE_BIT) + { + gc_next_live_value = value_from_index(blk, idx); + return gc_next_live_value; + } + } + } + + gc_next_live_value = NIL; + return NIL; +} + +static void process_live_objects(void) +{ + value_t next; + + while (!is_nil(next = next_live_object())) + { + mark_children_live(next); + set_object_processed(next); + } } static void process_weak_boxes(void) { - value_t wb = gc_weak_box_list; - - while (!is_nil(wb)) + value_t wb; + + for (wb = gc_weak_box_list; !is_nil(wb); wb = get_weak_box(wb)->next) { - weak_box_t *box; + weak_box_t *box = get_weak_box(wb); - if (gc_object_has_moved(wb)) - { - /* Box has been moved; get a pointer to the new location, but don't update list yet. */ - value_t fw = _get_object(wb)->forward; - assert(is_weak_box(fw)); - box = _get_weak_box(fw); - } - else - { - /* Box hasn't been moved. Could be Gen-0 pass, or may live on as the value of a will. */ - assert(is_weak_box(wb)); - box = _get_weak_box(wb); - } - - if (gc_object_left_behind(box->value)) + if (!is_object_live(box->value)) { /* The value in the box is an unreachable object; change to #f. */ /* - * NOTE: An object is considered unreachable via weak box when it could be finalized, even - * though it will be kept alive until any finalizers are removed from the 'active' list. - * The finalizer(s) may restore the object to a reachable state, in which case it will not - * be collected--but the weak reference will remain broken. - * - * Restoring references to otherwise GC'able objects is not recommended. - * - * The only known alternative would have been to invoke the finalizer while other objects - * may still be able to access the object (and create new references) via the weak box. - */ + ** NOTE: An object is considered unreachable via weak box when it + ** could be finalized, even though it will be kept alive until any + ** finalizers are removed from the 'active' list. The finalizers + ** may restore the object to a reachable state, in which case it + ** will not be collected--but the weak reference will remain broken. + ** + ** Restoring references to otherwise GC'able objects is not recommended. + */ box->value = FALSE_VALUE; } - else if (gc_object_has_moved(box->value)) - { - /* The value in the box is reachable; update w/ new location. */ - box->value = _get_object(box->value)->forward; - } - - /* Move on to this box's 'next' pointer */ - wb = box->next; } } -/* Precondition: The wills themselves, and their finalizers, - * have already been transferred (recursively). */ static void process_wills(void) { - /* - * Was value transferred (broken heart), and thus reachable? - * Yes ==> update value. - * No ==> transfer value and move will to active list. - */ value_t *will = &gc_will_list; while (!is_nil(*will)) { will_t *w = get_will(*will); - if (gc_object_left_behind(w->value)) + if (!is_object_live(w->value)) { - /* - * The will is associated with an unreachable object; activate it. - */ + /* The will is associated with an unreachable object; activate it. */ - /* First, ensure that the value remains reachable for the finalizer. */ - transfer_object(&w->value); - - /* Remove the will from the 'pending' list. */ - *will = w->next; + /* First, ensure the object remains reachable for the finalizer. */ + mark_object_live(w->value); /* Insert the will into the 'active' list. */ w->next = gc_will_active_list; - gc_will_active_list = object_value(w); + gc_will_active_list = *will; + + /* Remove the will from the 'pending' list. */ + *will = w->next; } else { - /* The value associated with the will is still reachable; update w/ new location. */ - if (gc_object_has_moved(w->value)) - { - w->value = _get_object(w->value)->forward; - } - /* Move on to this will's 'next' pointer */ will = &w->next; } @@ -1258,74 +919,36 @@ static void update_weak_box_list(void) while (!is_nil(*wb)) { - if (gc_object_left_behind(*wb)) + if (!is_object_live(*wb)) { /* Box is no longer reachable; remove it from the list by updating *wb. */ *wb = get_weak_box(*wb)->next; } else { - /* The box itself is reachable; may need to update *wb to new location */ - if (gc_object_has_moved(*wb)) - { - *wb = _get_object(*wb)->forward; - } - /* Move on to next box */ wb = &get_weak_box(*wb)->next; } } } -#define GC_DEFLATE_SIZE (64*1024) - -static void update_soft_limit(size_t min_free) +static void free_unreachable_objects(void) { - size_t bytes_used = gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range]; - size_t min_limit = bytes_used + min_free; - size_t new_limit = 2 * min_limit; + int blk; - if (gc_gen1_soft_limit > GC_DEFLATE_SIZE) + for (blk = 0; (blk <= OBJECT_BLOCK_MAX) && object_blocks[blk].objects; ++blk) { - size_t deflate_limit = gc_gen1_soft_limit - GC_DEFLATE_SIZE; + int idx; - if (new_limit < deflate_limit) - new_limit = deflate_limit; - } + for (idx = 0; idx <= OBJECT_INDEX_MAX; ++idx) + { + value_t value = value_from_index(blk, idx); - if (new_limit < gc_gen1_min_size) - new_limit = gc_gen1_min_size; - else if (new_limit > gc_gen1_max_size) - new_limit = gc_gen1_max_size; - - gc_gen1_soft_limit = new_limit; - - /* Update end of range to reflect new limit */ - gc_gen1_range_end = gc_gen1_ranges[gc_gen1_current_range] + gc_gen1_soft_limit; - -#ifndef NO_STATS - if (gc_gen1_soft_limit > gc_stats.gen1_high_water) - { - gc_stats.gen1_high_water = gc_gen1_soft_limit; - } -#endif -} - -static size_t gc_gen1_block_of(void *obj) -{ - const intptr_t offset = (uintptr_t)obj - - (uintptr_t)gc_gen1_ranges[gc_gen1_current_range]; - - return (offset & (((uintptr_t)2 << 30) - 1)) / GC_DIRTY_BLOCK_SIZE; -} - -void _gc_mark_updated_gen1_object(value_t v) -{ - assert(is_object(v)); - { - const size_t block = gc_gen1_block_of(_get_object(v)); - assert(is_object(v) && !is_gen0_object(v) && gc_gen1_block_starts[block]); - gc_gen1_dirty_bits[block / 32] |= (1UL << (block % 32)); + if (is_object(value) && !is_object_live(value)) + { + free_object(value); + } + } } } @@ -1336,170 +959,79 @@ static void _out_of_memory(void) abort(); } -static void collect_gen1_garbage(size_t min_free) +void collect_garbage(void) { - bool was_in_gen0_collection = gc_in_gen0_collection; - bool collected_garbage = false; +#ifndef NO_STATS + size_t initial_bytes = gc_total_bytes; +#ifndef NO_TIMING_STATS + struct timespec start_time; + clock_gettime(TIMING_CLOCK, &start_time); +#endif +#endif - /* If Gen-1 free space falls below used portion of Gen-0, chaos may ensue. */ - assert(gc_gen1_free_space() >= (gc_gen0_free_ptr - gc_gen0_range)); - min_free += gc_gen0_size; + debug_info("Performing garbage collection pass...\n"); - if (gc_enabled) - { - char *object_ptr; + /* Start with no live/processed values */ + clear_gc_flag_bits(); + gc_next_live_value = NIL; + + /* Prime the pump */ + mark_roots_live(); + + /* Keep marking children until there are no more live, unprocessed objects. */ + process_live_objects(); + + /* These have to be examined after normal reachability has been determined. */ + process_weak_boxes(); + process_wills(); + + /* + ** Keep marking children until there are no more live, unprocessed objects. + ** + ** This is so that values which are otherwise unreachable, but have + ** finalizers which may be able to reach them, are not collected + ** prematurely. process_wills() marks the value of any will newly placed + ** on the active list as live. Note that these values may be finalized + ** in any order, and that any weak references have already been cleared. + */ + process_live_objects(); + + /* Remove any unreachable weak boxes from the weak box list. */ + update_weak_box_list(); + + /* Finally, return any unreachable objects to the free list. */ + free_unreachable_objects(); + + /* Record total "live" allocation after GC. Determines threshold for next GC. */ + gc_live_bytes = gc_total_bytes; + + debug_info("Finished collection; active set is %ld bytes.\n", (long)gc_live_bytes); #ifndef NO_STATS - size_t initial_free_space = gc_gen0_free_space() + gc_gen1_free_space(); + gc_stats.passes += 1; + #ifndef NO_TIMING_STATS - struct timespec start_time; - clock_gettime(TIMING_CLOCK, &start_time); -#endif -#endif - - debug_info("Performing Gen-1 garbage collection pass...\n"); - - gc_enabled = false; - gc_in_gen0_collection = false; - gc_in_gen1_collection = true; - - gc_gen1_clear_dirty_bits(); - swap_gen1_gc_ranges(); - - /* Record the start of each Gen-1 block as objects are moved to the new range. */ - memset(gc_gen1_block_starts, 0, gc_gen1_max_blocks * sizeof(char*)); - - /* New "current" range is initially empty, old one is full */ - object_ptr = gc_gen1_free_ptr; - - /* Prime the pump */ - transfer_roots(); - - /* Keep transferring until no more objects in the new range refer to the old one, - * other than pending wills and weak boxes. */ - while (object_ptr < gc_gen1_free_ptr) - { - object_ptr += gc_align(transfer_children((object_t*)object_ptr)); - assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range); - } - - /* These have to be examined after normal reachability has been determined */ - process_weak_boxes(); - process_wills(); - - /* Keep transferring until no more objects in the new range refer to the old one. - * This is so that values which are otherwise unreachable, but have finalizers which - * may be able to reach them, are not collected prematurely. process_wills() transfers - * the value of any will newly placed on the active list. Note that these values may - * be finalized in any order, and that any weak references have already been cleared. */ - while (object_ptr < gc_gen1_free_ptr) - { - object_ptr += gc_align(transfer_children((object_t*)object_ptr)); - assert(gc_gen1_range_of(object_ptr) == gc_gen1_current_range); - } - - update_weak_box_list(); - -#ifndef NDEBUG - /* Clear old range, to make it easier to detect bugs. */ - gc_poison_region(gc_gen1_ranges[gc_gen1_other_range()], gc_gen1_soft_limit, GC_GEN1_POISON); - gc_poison_region(gc_gen0_range, gc_gen0_size, GC_GEN0_POISON); -#endif - - /* - * Gen-0 should be empty at this point; all active objects - * have been moved to the Gen-1 memory region. - */ - - gc_gen0_free_ptr = gc_gen0_range; - collected_garbage = true; - - debug_info("Finished Gen-1 collection; active set is %ld bytes.\n", - (long int)(gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range])); - - gc_in_gen1_collection = false; - gc_enabled = true; - -#ifndef NO_STATS -#ifndef NO_TIMING_STATS - { - struct timespec end_time; - nsec_t nsec; - - clock_gettime(TIMING_CLOCK, &end_time); - - nsec = (end_time.tv_sec - start_time.tv_sec) * 1000000000LL; - nsec += (end_time.tv_nsec - start_time.tv_nsec); - - gc_stats.gen[1].total_ns += nsec; - - if (nsec > gc_stats.gen[1].max_ns) - gc_stats.gen[1].max_ns = nsec; - } -#endif - gc_stats.gen[1].total_freed -= initial_free_space; - gc_stats.gen[1].total_freed += gc_gen0_free_space(); - gc_stats.gen[1].total_freed += gc_gen1_free_space(); - ++gc_stats.gen[1].passes; -#endif - } - - update_soft_limit(min_free); - - if (gc_gen1_free_space() < min_free) { - size_t bytes_used = gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range]; - size_t need_bytes = bytes_used + min_free + gc_gen0_size; + struct timespec end_time; + nsec_t nsec; - /* If GC is disabled then we can't move anything, so reallocating is impossible. */ - if (!gc_enabled) - _out_of_memory(); + clock_gettime(TIMING_CLOCK, &end_time); - /* - * Try to get more memory from the C runtime. - */ + nsec = (end_time.tv_sec - start_time.tv_sec) * 1000000000LL; + nsec += (end_time.tv_nsec - start_time.tv_nsec); - debug_warn("Ran out of free memory; will try to allocate more...\n"); + gc_stats.total_ns += nsec; - do { - release_assert(gc_gen1_max_size < (SIZE_MAX/2)); - gc_gen1_max_size *= 2; - } while (gc_gen1_max_size < need_bytes); - - /* Reallocate the unused space. */ - { - char *unused_range = gc_gen1_ranges[gc_gen1_other_range()]; - gc_gen1_ranges[gc_gen1_other_range()] = (char*)malloc(gc_gen1_max_size); - free(unused_range); - } - - /* See if reallocation succeeded. */ - if (!gc_gen1_ranges[gc_gen1_other_range()]) - _out_of_memory(); - - /* Move everything into the newly enlarged space. - * Will update the soft-limit. */ - collect_gen1_garbage(0); - - /* Reallocate the other space, now unused. */ - free(gc_gen1_ranges[gc_gen1_other_range()]); - gc_gen1_ranges[gc_gen1_other_range()] = (char*)malloc(gc_gen1_max_size); - - /* Ensure second reallocation succeeded. */ - if (!gc_gen1_ranges[gc_gen1_other_range()]) - _out_of_memory(); + if (nsec > gc_stats.peak_ns) + gc_stats.peak_ns = nsec; } +#endif - /* If Gen-1 was invoked within Gen-0, skip the rest: Gen-0 is empty, we're done. */ - if (was_in_gen0_collection && collected_garbage) - longjmp(gc_gen0_end_ctx, 1); -} + gc_stats.total_freed += (initial_bytes - gc_live_bytes); -void collect_garbage(size_t min_free) -{ - bool was_enabled = set_gc_enabled(true); - collect_gen1_garbage(min_free); - set_gc_enabled(was_enabled); + if (initial_bytes > gc_stats.peak_allocated) + gc_stats.peak_allocated = initial_bytes; +#endif } bool set_gc_enabled(bool enable) @@ -1526,9 +1058,8 @@ void get_next_finalizer(value_t *value, value_t *finalizer) } else { - will_t *w = get_will(gc_will_active_list); - - *value = w->value; + will_t *w = get_will(gc_will_active_list); + *value = w->value; *finalizer = w->finalizer; /* Remove this finalizer from the list -- up to caller to keep values reachable. */ @@ -1567,7 +1098,7 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) return; } - if (is_object(v) && !(is_float(v) || is_byte_string(v) || is_builtin_fn(v))) + if (is_object(v) && !(is_float(v) || is_builtin_fn(v) || is_byte_string(v))) { for (seen_value_t *sv = seen; sv; sv = sv->prev) { @@ -1585,7 +1116,11 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) } } - if (v == NIL) + if (v == UNDEFINED) + { + fputs("#", f); + } + else if (v == NIL) { fputs("nil", f); } @@ -1597,10 +1132,6 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) { fputs("#t", f); } - else if (v == UNDEFINED) - { - fputs("#", f); - } else if (v == END_PROGRAM) { fputs("#", f); @@ -1612,20 +1143,25 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) else if (is_box(v)) { fputs("#&", f); - _fprint_value(f, _get_box(v)->value, &new_seen); + _fprint_value(f, get_box(v)->value, &new_seen); + } + else if (is_weak_box(v)) + { + fputs("#W&", f); + _fprint_value(f, get_weak_box(v)->value, &new_seen); } else if (is_pair(v)) { fputc('(', f); - _fprint_value(f, _get_pair(v)->car, &new_seen); - v = _get_pair(v)->cdr; + _fprint_value(f, get_pair(v)->car, &new_seen); + v = get_pair(v)->cdr; while (is_pair(v)) { fputc(' ', f); - _fprint_value(f, _get_pair(v)->car, &new_seen); - v = _get_pair(v)->cdr; + _fprint_value(f, get_pair(v)->car, &new_seen); + v = get_pair(v)->cdr; } if (v != NIL) @@ -1636,24 +1172,34 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) fputc(')', f); } + else if (is_float(v)) + { + fprintf(f, "%f", (double)get_float(v)); + } + else if (is_builtin_fn(v)) + { + fprintf(f, "#", get_builtin_fn(v)); + } else if (is_vector(v)) { - if (_get_vector(v)->immutable) + vector_t *vec = get_vector(v); + + if (vec->immutable) fputs("#@", f); fputs("#(", f); - for (size_t i = 0; i < _get_vector(v)->size; ++i) + for (size_t i = 0; i < vec->nelements; ++i) { if (i != 0) fputc(' ', f); - _fprint_value(f, _get_vector(v)->elements[i], &new_seen); + _fprint_value(f, vec->elements[i], &new_seen); } fputc(')', f); } else if (is_byte_string(v)) { - byte_string_t *str = _get_byte_string(v); + byte_string_t *str = get_byte_string(v); size_t written = 0; if (str->immutable) @@ -1661,7 +1207,7 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) fputc('"', f); - for (size_t i = 0; i < str->size; ++i) + for (size_t i = 0; i < str->nbytes; ++i) { int ch = str->bytes[i]; @@ -1687,38 +1233,25 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) } else if (is_struct(v)) { - value_t meta = _get_struct(v)->type; + struct_t *str = get_struct(v); - if (_get_struct(v)->immutable) + if (str->immutable) fputs("#@", f); fputs("#S(", f); - _fprint_value(f, meta, &new_seen); + _fprint_value(f, str->type, &new_seen); - for (size_t i = 0; i < _get_struct(v)->nslots; ++i) + for (size_t i = 0; i < str->nslots; ++i) { fputc(' ', f); - _fprint_value(f, _get_struct(v)->slots[i], &new_seen); + _fprint_value(f, str->slots[i], &new_seen); } fputc(')', f); } - else if (is_weak_box(v)) - { - fputs("#W&", f); - _fprint_value(f, _get_weak_box(v)->value, &new_seen); - } - else if (is_float(v)) - { - fprintf(f, "%f", (double)_get_float(v)); - } - else if (is_builtin_fn(v)) - { - fputs("#", f); - } else { - fputs("#", f); + fprintf(f, "#", (unsigned long)v); } } @@ -1735,29 +1268,15 @@ static double ns2sec(nsec_t ns) void fprint_gc_stats(FILE *f) { - if (gc_stats.gen[0].passes || gc_stats.gen[1].passes) + if (gc_stats.passes) { - const llsize_t total_freed = gc_stats.gen[0].total_freed + gc_stats.gen[1].total_freed; - const nsec_t total_ns = gc_stats.gen[0].total_ns + gc_stats.gen[1].total_ns; - - fprintf(f, "GC: %lld bytes freed by %d GCs in %0.6f sec => %0.3f MB/sec.\n", - total_freed, - gc_stats.gen[0].passes + gc_stats.gen[1].passes, - ns2sec(total_ns), - (total_freed / ns2sec(total_ns)) / (1024*1024)); - - fprintf(f, "GC: %d Gen-0 passes; avg. time was %0.6f sec, max %0.6f.\n", - gc_stats.gen[0].passes, - ns2sec(gc_stats.gen[0].total_ns) / gc_stats.gen[0].passes, - ns2sec(gc_stats.gen[0].max_ns)); - - fprintf(f, "GC: %d Gen-1 passes; avg. time was %0.6f sec, max %0.6f.\n", - gc_stats.gen[1].passes, - ns2sec(gc_stats.gen[1].total_ns) / gc_stats.gen[1].passes, - ns2sec(gc_stats.gen[1].max_ns)); - - fprintf(f, "GC: The Gen-1 soft-limit peaked at %lld bytes out of %lld allocated.\n", - (long long)gc_stats.gen1_high_water, (long long)gc_gen1_max_size); + fprintf(f, "GC: %lld bytes freed by %d GCs in %0.6f sec => %0.3f MB/sec.\n" + "GC: Peak pre-GC memory use was %lld bytes.\n", + gc_stats.total_freed, + gc_stats.passes, + ns2sec(gc_stats.total_ns), + (gc_stats.total_freed / ns2sec(gc_stats.total_ns)) / (1024*1024), + gc_stats.peak_allocated); } else { diff --git a/gc.h b/gc.h index a3a401e..d21a377 100644 --- a/gc.h +++ b/gc.h @@ -7,166 +7,185 @@ #include #include +/* +** Macro Definitions +*/ + +/* +** nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn1 fixnum +** +** sssssssssssssssssssssssssss00000 special +** xxxxxxxxxxyyyyyyyyyyyyyyyyy00010 object_blocks[x].objects[y].box +** xxxxxxxxxxyyyyyyyyyyyyyyyyy00100 object_blocks[x].objects[y].weak_box +** xxxxxxxxxxyyyyyyyyyyyyyyyyy00110 object_blocks[x].objects[y].pair +** xxxxxxxxxxyyyyyyyyyyyyyyyyy01000 object_blocks[x].objects[y].fpnum +** xxxxxxxxxxyyyyyyyyyyyyyyyyy01010 object_blocks[x].objects[y].builtin_fn +** xxxxxxxxxxyyyyyyyyyyyyyyyyy01100 reserved +** xxxxxxxxxxyyyyyyyyyyyyyyyyy01110 reserved +** +** xxxxxxxxxxyyyyyyyyyyyyyyyyy10000 object_blocks[x].objects[y].vector +** xxxxxxxxxxyyyyyyyyyyyyyyyyy10010 object_blocks[x].objects[y].byte_string +** xxxxxxxxxxyyyyyyyyyyyyyyyyy10100 object_blocks[x].objects[y].structure +** xxxxxxxxxxyyyyyyyyyyyyyyyyy10110 object_blocks[x].objects[y].will +** xxxxxxxxxxyyyyyyyyyyyyyyyyy11000 reserved +** xxxxxxxxxxyyyyyyyyyyyyyyyyy11010 reserved +** xxxxxxxxxxyyyyyyyyyyyyyyyyy11100 reserved +** xxxxxxxxxxyyyyyyyyyyyyyyyyy11110 reserved +*/ + +#define FIXNUM_MIN (INT32_MIN/2) +#define FIXNUM_MAX (INT32_MAX/2) + +#define OBJECT_BLOCK_MAX 0x3ff +#define OBJECT_INDEX_MAX 0x1ffff +#define OBJECT_TAG_MAX 0xf + +#define OBJECT_TAG_FIXNUM -1 +#define OBJECT_TAG_SPECIAL 0 +#define OBJECT_TAG_BOX 1 +#define OBJECT_TAG_WEAK_BOX 2 +#define OBJECT_TAG_PAIR 3 +#define OBJECT_TAG_FPNUM 4 +#define OBJECT_TAG_BUILTIN_FN 5 +/* 6 & 7 are reserved */ +#define OBJECT_TAG_VECTOR 8 +#define OBJECT_TAG_BYTE_STRING 9 +#define OBJECT_TAG_STRUCT 10 +#define OBJECT_TAG_WILL 11 +/* 12-15 are reserved */ + +#define OBJECT(blk, idx, tag) \ + ((((value_t)(blk) & 0x3ff) << 22) | \ + (((value_t)(idx) & 0x1ffff) << 5) | \ + (((value_t)(tag) & 0xf) << 1)) + +#define OBJECT_BLOCK(value) ((int)(((value) >> 22) & 0x3ff)) +#define OBJECT_INDEX(value) ((int)(((value) >> 5) & 0x1ffff)) +#define OBJECT_TAG(value) ((int)(((value) >> 1) & 0xf)) + +#define SPECIAL_VALUE(n) ((value_t)(n) << 5) +#define SPECIAL_MAX ((value_t)(-1) << 5) + +#define UNDEFINED SPECIAL_VALUE(0) +#define NIL SPECIAL_VALUE(1) +#define FALSE_VALUE SPECIAL_VALUE(2) +#define TRUE_VALUE SPECIAL_VALUE(3) +#define END_PROGRAM SPECIAL_VALUE(4) + +#define CAR(x) (get_pair(x)->car) +#define CDR(x) (get_pair(x)->cdr) +#define CADR(x) CAR(CDR(x)) +#define CDDR(x) CDR(CDR(x)) + +/* Ex: SLOT_VALUE(STRUCTURE, v, NAME) */ +#define SLOT_VALUE(t,v,s) (get_struct(v)->slots[t ## _SLOT_ ## s]) +#define _SLOT_VALUE(t,v,s) SLOT_VALUE(t,v,s) + +#define STRUCTURE_SLOT_SUPER 0 +#define STRUCTURE_SLOT_NSLOTS 1 +#define STRUCTURE_SLOT_CALLABLE 2 +#define STRUCTURE_SLOTS 3 + +/* Invoke this macro after updating any object with a new object reference. */ +/* Write barriers are required for generational and incremental collectors. */ +/* If unsure, invoke the macro; at most there will be a slight cost in performance. */ +/* Failing to invoke the macro before the next GC pass can lead to incorrect behavior. */ +#define WRITE_BARRIER(value) ((void)0) + /* Like assert(), but for things we want to check even in release builds. */ /* More informative than a simple "if (!x) abort();" statement. */ -#define release_assert(expr) ((expr) ? (void)0 : (void)_release_assert(#expr, __FILE__, __LINE__)) +#define release_assert(expr) \ + ((expr) ? (void)0 : (void)_release_assert(#expr, __FILE__, __LINE__)) /* Evaluates to false, but with an expression that conveys what went wrong. */ #define NOTREACHED(msg) 0 -typedef uintptr_t value_t; -typedef intptr_t fixnum_t; -typedef double native_float_t; +/* +** Type Definitions +*/ -#if INTPTR_MAX - 0 == 0 -/* The INTPTR_ macros are defined, but not given values. */ -# undef INTPTR_MIN -# undef INTPTR_MAX -# ifdef __x86_64__ -# define INTPTR_MIN INT64_MIN -# define INTPTR_MAX INT64_MAX -# else -# define INTPTR_MIN INT32_MIN -# define INTPTR_MAX INT32_MAX -# endif -#endif - -#define FIXNUM_MIN (INTPTR_MIN/2) -#define FIXNUM_MAX (INTPTR_MAX/2) +/* Primitive types */ +typedef uint32_t value_t; +typedef int32_t fixnum_t; +typedef double fpnum_t; /* Builtins replace the normal run_byte_code() and perform_tail_call() steps. * The argv, k, and ctx inputs can be found in the state fields, and should be * updated as necessary (particularly argv) before the builtin returns. The * 'lambda' field will refer to the builtin itself, and in1-in3 are all free. */ struct interp_state; -typedef void (builtin_fn_t)(struct interp_state *state); +typedef void builtin_fn_t(struct interp_state *state); -/* NIL: 00000000 00000000 00000000 00000000 */ -/* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa00 (where aa... >= 1024) */ -/* Pair: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa10 */ -/* Fixnum: snnnnnnn nnnnnnnn nnnnnnnn nnnnnnn1 */ - -#define NIL ((value_t)0) - -/* Special values (0 <= n < 1024) */ -/* These correspond to objects within the first page of memory */ -#define SPECIAL_VALUE(n) ((value_t)(4*(n)+4)) -#define TYPE_TAG(n) SPECIAL_VALUE(768+(n)) -#define MAX_SPECIAL SPECIAL_VALUE(1023) - -#define BROKEN_HEART SPECIAL_VALUE(0) -#define FALSE_VALUE SPECIAL_VALUE(1) -#define TRUE_VALUE SPECIAL_VALUE(2) -#define UNDEFINED SPECIAL_VALUE(3) -#define GC_GEN0_POISON SPECIAL_VALUE(4) -#define GC_GEN1_POISON SPECIAL_VALUE(5) -#define END_PROGRAM SPECIAL_VALUE(6) - -#define TYPE_TAG_BOX TYPE_TAG(0) -#define TYPE_TAG_VECTOR TYPE_TAG(1) -#define TYPE_TAG_BYTESTR TYPE_TAG(2) -#define TYPE_TAG_STRUCT TYPE_TAG(3) -#define TYPE_TAG_WEAK_BOX TYPE_TAG(4) -#define TYPE_TAG_WILL TYPE_TAG(5) -#define TYPE_TAG_FLOAT TYPE_TAG(6) -#define TYPE_TAG_BUILTIN TYPE_TAG(7) - -#define CAR(x) (get_pair(x)->car) -#define CDR(x) (get_pair(x)->cdr) -#define CADR(x) CAR(CDR(x)) -#define CDDR(x) CDR(CDR(x)) - -#define _CAR(x) (_get_pair(x)->car) -#define _CDR(x) (_get_pair(x)->cdr) -#define _CADR(x) _CAR(_CDR(x)) -#define _CDDR(x) _CDR(_CDR(x)) - -/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */ -#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s]) - -#define STRUCTURE_SLOT_SUPERS 0 -#define STRUCTURE_SLOT_NSLOTS 1 -#define STRUCTURE_SLOT_CALLABLE 2 -#define STRUCTURE_SLOTS 3 - -/* Invoke this macro after creating any reference from a Gen-1 GC object to a Gen-0 object. */ -/* If unsure, invoke the macro; at most there will be a slight cost in performance. */ -/* Failing to invoke the macro before the next Gen-0 GC can lead to incorrect behavior. */ -#define WRITE_BARRIER(value) ((void)_gc_write_barrier((value))) - -typedef struct object +typedef struct box { - value_t tag; - value_t forward; /* only if tag == BROKEN_HEART */ -} object_t; + value_t value; +} box_t; + +typedef struct weak_box +{ + value_t value; + value_t next; +} weak_box_t; -/* CAR is anything *other* than a valid type tag or BROKEN_HEART. */ typedef struct pair { value_t car; value_t cdr; } pair_t; -typedef struct box -{ - value_t tag; /* TYPE_TAG_BOX */ - value_t value; -} box_t; - typedef struct vector { - value_t tag; /* TYPE_TAG_VECTOR */ - size_t size; - value_t hash; - bool immutable; + bool immutable; + size_t nelements; value_t elements[0]; } vector_t; typedef struct byte_string { - value_t tag; /* TYPE_TAG_BYTESTR */ - size_t size; - bool immutable; + bool immutable; + size_t nbytes; uint8_t bytes[0]; } byte_string_t; -/* Equivalent to vector_t */ typedef struct structure { - value_t tag; /* TYPE_TAG_STRUCT */ - value_t type; + bool immutable; size_t nslots; - value_t hash; - bool immutable; + value_t type; value_t slots[0]; } struct_t; -typedef struct weak_box -{ - value_t tag; - value_t value; - value_t next; -} weak_box_t; - typedef struct will { - value_t tag; value_t value; value_t finalizer; value_t next; } will_t; -typedef struct float_object +typedef union object { - value_t tag; - native_float_t value; -} float_object_t; + /* free list */ + value_t next; -typedef struct builtin_fn_object + /* direct values */ + box_t box; + weak_box_t weak_box; + pair_t pair; + fpnum_t fpnum; + builtin_fn_t *builtin_fn; + + /* indirect values */ + vector_t *vector; + byte_string_t *byte_string; + struct_t *structure; + will_t *will; +} object_t; + +typedef struct object_block { - value_t tag; - builtin_fn_t *fn; -} builtin_fn_object_t; + object_t *objects; + uint8_t *flag_bits; +} object_block_t; typedef struct gc_root { @@ -181,62 +200,69 @@ typedef unsigned long long llsize_t; typedef struct gc_stats { - struct { - int passes; - nsec_t total_ns; - nsec_t max_ns; - nsec_t max_gen1_ns; - llsize_t total_freed; - } gen[2]; - llsize_t gen1_high_water; + int passes; + nsec_t total_ns; + nsec_t peak_ns; + llsize_t total_freed; + llsize_t peak_allocated; } gc_stats_t; -extern gc_stats_t gc_stats; +/* +** Object Declarations +*/ -/* Must be #t or #f; for generalized booleans use _get_boolean(). */ -bool get_boolean(value_t v); +extern const char *const object_tag_names[16]; +extern object_block_t object_blocks[OBJECT_BLOCK_MAX + 1]; +extern gc_stats_t gc_stats; -fixnum_t get_fixnum(value_t v); +/* +** Function Declarations +*/ -object_t *get_object(value_t v); +static inline bool get_boolean(value_t v); +static inline fixnum_t get_fixnum(value_t v); +static inline fpnum_t get_float(value_t v); +static inline builtin_fn_t *get_builtin_fn(value_t v); -pair_t *get_pair(value_t pair); -value_t cons(value_t car, value_t cdr); +static inline box_t *get_box(value_t v); +static inline weak_box_t *get_weak_box(value_t v); +static inline pair_t *get_pair(value_t v); +static inline vector_t *get_vector(value_t v); +static inline byte_string_t *get_byte_string(value_t v); +static inline struct_t *get_struct(value_t v); +/* wills are deliberately omitted from the public interface */ +static inline value_t make_boolean(bool value); +static inline value_t make_fixnum(fixnum_t value); + +value_t make_float(fpnum_t value); +value_t make_builtin_fn(builtin_fn_t *fn); value_t make_box(value_t initial_value); -box_t *get_box(value_t v); - -value_t make_vector(size_t elements, value_t default_value); -vector_t *get_vector(value_t v); - -value_t make_byte_string(size_t size, int default_value); -byte_string_t *get_byte_string(value_t v); +value_t make_weak_box(value_t value); +value_t make_pair(value_t car, value_t cdr); +value_t make_vector(size_t nelements, value_t init); +value_t make_byte_string(size_t nbytes, int init); +value_t make_struct(value_t type); +/* wills are deliberately omitted from the public interface */ /* Returns a byte string w/ bytes from 's' (excl. terminating NUL). */ value_t string_to_value(const char *s); -/* Return a new C string which must be free()'d by caller. */ +/* Returns a new C string which must be free()'d by caller. */ char *value_to_string(value_t v); /* Like strcmp(), but for byte strings. */ int byte_strcmp(value_t s1, value_t s2); -value_t get_hash_value(value_t val); -value_t combine_hash_values(value_t h1, value_t h2); - -value_t make_struct(value_t type); -struct_t *get_struct(value_t v); +/* Return the structure instance at the root of the structure type hierarchy. */ value_t get_structure_type(void); /* Instantiates a structure type. Result is immutable. */ -value_t make_struct_type(value_t supers, fixnum_t nslots, value_t callable); +value_t make_struct_type(value_t super, fixnum_t nslots, value_t callable); /* True if 'value' is (1) a structure, and (2) an instance of 'type'. */ bool struct_is_a(value_t value, value_t type); -value_t make_weak_box(value_t value); -weak_box_t *get_weak_box(value_t v); - /* Finalizers are register-and-forget; there should be no external references to wills. */ void register_finalizer(value_t value, value_t finalizer); bool are_finalizers_pending(void); @@ -244,13 +270,31 @@ bool are_finalizers_pending(void); /* If *value == #f on return there are no more finalizers. */ void get_next_finalizer(value_t *value, value_t *finalizer); -value_t make_float(native_float_t value); -native_float_t get_float(value_t v); +void register_gc_root(gc_root_t *root, value_t v); +void unregister_gc_root(gc_root_t *root); -value_t make_builtin_fn(builtin_fn_t *fn); -builtin_fn_t *get_builtin_fn(value_t v); +void gc_init(void); +void clear_gc_stats(void); +void collect_garbage(void); +bool set_gc_enabled(bool enable); -/****************************************************************************/ +void fprint_value(FILE *f, value_t v); +void fprint_gc_stats(FILE *f); + +/* Implements the release_assert() macro */ +void _release_assert(const char *str, const char *file, int line) __attribute__((noreturn)); + +/* To be provided by the main application */ +void out_of_memory(void); + +/* +** Static Function Definitions +*/ + +static inline bool is_valid_fixnum(fixnum_t n) +{ + return (FIXNUM_MIN <= n) && (n <= FIXNUM_MAX); +} static inline bool is_nil(value_t v) { @@ -262,169 +306,174 @@ static inline bool is_undefined(value_t v) return v == UNDEFINED; } -static inline value_t boolean_value(bool b) -{ - return b ? TRUE_VALUE : FALSE_VALUE; -} - static inline bool is_boolean(value_t v) { return (v == FALSE_VALUE) || (v == TRUE_VALUE); } -static inline bool _get_boolean(value_t v) +static inline bool is_fixnum(value_t value) +{ + return (value & 1) != 0; +} + +static inline bool is_object_type(value_t value, int tag) +{ + if (tag == OBJECT_TAG_FIXNUM) + return is_fixnum(value); + else if ((tag < 0) || (tag > OBJECT_TAG_MAX)) + return false; + else + return ((value & 0x1f) == ((value_t)tag << 1)); +} + +static inline bool is_special(value_t value) +{ + return is_object_type(value, OBJECT_TAG_SPECIAL); +} + +static inline bool is_object(value_t value) +{ + return !is_fixnum(value) && !is_special(value); +} + +static inline bool is_box(value_t value) +{ + return is_object_type(value, OBJECT_TAG_BOX); +} + +static inline bool is_weak_box(value_t value) +{ + return is_object_type(value, OBJECT_TAG_WEAK_BOX); +} + +static inline bool is_pair(value_t value) +{ + return is_object_type(value, OBJECT_TAG_PAIR); +} + +static inline bool is_list(value_t value) +{ + return is_nil(value) || is_pair(value); +} + +static inline bool is_float(value_t value) +{ + return is_object_type(value, OBJECT_TAG_FPNUM); +} + +static inline bool is_builtin_fn(value_t value) +{ + return is_object_type(value, OBJECT_TAG_BUILTIN_FN); +} + +static inline bool is_vector(value_t value) +{ + return is_object_type(value, OBJECT_TAG_VECTOR); +} + +static inline bool is_byte_string(value_t value) +{ + return is_object_type(value, OBJECT_TAG_BYTE_STRING); +} + +static inline bool is_struct(value_t value) +{ + return is_object_type(value, OBJECT_TAG_STRUCT); +} + +static inline int get_object_type(value_t value) +{ + if (is_fixnum(value)) + return OBJECT_TAG_FIXNUM; + else + return OBJECT_TAG(value); +} + +static inline bool get_boolean(value_t v) { return v != FALSE_VALUE; } -static inline value_t fixnum_value(fixnum_t n) +static inline int32_t get_fixnum(value_t value) { - return (value_t)(n << 1) | 1; + return (int32_t)value >> 1; } -static inline bool is_fixnum(value_t v) +static inline object_t *_get_object(value_t value) { - return (v & 1) != 0; + release_assert(is_object(value)); + return &object_blocks[OBJECT_BLOCK(value)].objects[OBJECT_INDEX(value)]; } -static inline fixnum_t _get_fixnum(value_t n) +static inline object_t *_get_typed_object(value_t value, int tag) { - return ((fixnum_t)n) >> 1; + if (!is_object_type(value, tag)) + { + if (is_fixnum(value)) + { + fprintf(stderr, "ERROR: Expected %s, found fixnum.\n", object_tag_names[tag]); + } + else + { + fprintf(stderr, "ERROR: Expected %s, found %s.\n", + object_tag_names[tag], object_tag_names[OBJECT_TAG(value)]); + } + release_assert(is_object_type(value, tag)); + } + return &object_blocks[OBJECT_BLOCK(value)].objects[OBJECT_INDEX(value)]; } -static inline bool is_valid_fixnum(fixnum_t n) +static inline box_t *get_box(value_t value) { - return _get_fixnum(fixnum_value(n)) == n; + return &_get_typed_object(value, OBJECT_TAG_BOX)->box; } -static inline value_t object_value(void *obj) +static inline weak_box_t *get_weak_box(value_t value) { - assert((uintptr_t)obj >= 4096); - assert(((uintptr_t)obj & 3) == 0); - return (value_t)obj; + return &_get_typed_object(value, OBJECT_TAG_WEAK_BOX)->weak_box; } -static inline bool is_object(value_t v) +static inline pair_t *get_pair(value_t value) { - /* Neither pairs nor other objects can exist below (void*)4096. */ - return ((v & 0x1) == 0) && (v > MAX_SPECIAL); + return &_get_typed_object(value, OBJECT_TAG_PAIR)->pair; } -/* Pairs are a type of object, but the value representation is different */ -static inline object_t *_get_object(value_t v) +static inline fpnum_t get_float(value_t value) { - return (object_t*)(v & ~(value_t)3); + return _get_typed_object(value, OBJECT_TAG_FPNUM)->fpnum; } -static inline value_t pair_value(pair_t *p) +static inline builtin_fn_t *get_builtin_fn(value_t value) { - assert((uintptr_t)p >= 4096); - assert(((uintptr_t)p & 3) == 0); - return (value_t)p + 2; + return _get_typed_object(value, OBJECT_TAG_BUILTIN_FN)->builtin_fn; } -static inline bool is_pair(value_t v) +static inline vector_t *get_vector(value_t value) { - return ((v & 0x3) == 2); + return _get_typed_object(value, OBJECT_TAG_VECTOR)->vector; } -static inline pair_t *_get_pair(value_t v) +static inline byte_string_t *get_byte_string(value_t value) { - return (pair_t*)_get_object(v); + return _get_typed_object(value, OBJECT_TAG_BYTE_STRING)->byte_string; } -static inline bool is_list(value_t v) +static inline struct_t *get_struct(value_t value) { - return is_nil(v) || is_pair(v); + return _get_typed_object(value, OBJECT_TAG_STRUCT)->structure; } -static inline bool is_box(value_t v) +static inline value_t make_boolean(bool b) { - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_BOX); + return b ? TRUE_VALUE : FALSE_VALUE; } -static inline box_t *_get_box(value_t v) +static inline value_t make_fixnum(int32_t n) { - return (box_t*)_get_object(v); + //release_assert(is_valid_fixnum(n)); + return (value_t)((n << 1) | 1); } -static inline bool is_vector(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_VECTOR); -} - -static inline vector_t *_get_vector(value_t v) -{ - return (vector_t*)_get_object(v); -} - -static inline bool is_byte_string(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_BYTESTR); -} - -static inline byte_string_t *_get_byte_string(value_t v) -{ - return (byte_string_t*)_get_object(v); -} - -static inline bool is_struct(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_STRUCT); -} - -static inline struct_t *_get_struct(value_t v) -{ - return (struct_t*)_get_object(v); -} - -static inline bool is_weak_box(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_WEAK_BOX); -} - -static inline weak_box_t *_get_weak_box(value_t v) -{ - return (weak_box_t*)_get_object(v); -} - -static inline bool is_will(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_WILL); -} - -static inline bool is_float(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_FLOAT); -} - -static inline native_float_t _get_float(value_t v) -{ - return ((float_object_t*)_get_object(v))->value; -} - -static inline bool is_builtin_fn(value_t v) -{ - return is_object(v) && (_get_object(v)->tag == TYPE_TAG_BUILTIN); -} - -static inline builtin_fn_t *_get_builtin_fn(value_t v) -{ - return ((builtin_fn_object_t*)_get_object(v))->fn; -} - -void gc_init(size_t gen0_size, size_t gen1_min_size, size_t gen1_max_size); -void clear_gc_stats(void); -void register_gc_root(gc_root_t *root, value_t v); -void unregister_gc_root(gc_root_t *root); -void *gc_alloc(size_t nbytes); -void collect_garbage(size_t min_free); -bool set_gc_enabled(bool enable); -void _gc_mark_updated_gen1_object(value_t v); - -void fprint_value(FILE *f, value_t v); -void fprint_gc_stats(FILE *f); - static inline void print_value(value_t v) { fprint_value(stdout, v); @@ -435,33 +484,5 @@ static inline void print_gc_stats(void) fprint_gc_stats(stderr); } -static inline bool is_gen0_object(value_t v) -{ - /* These private variables are exported ONLY for use by this inline function. */ - extern char *gc_gen0_range; - extern char *gc_gen0_range_end; - - const char const *obj = (const char*)_get_object(v); - return (obj < gc_gen0_range_end) - && (obj >= gc_gen0_range) - && is_object(v); -} - -/* Don't call this directly; use the WRITE_BARRIER macro. */ -static inline void _gc_write_barrier(value_t v) -{ - assert(is_object(v)); - if (!is_gen0_object(v)) - { - _gc_mark_updated_gen1_object(v); - } -} - -/* Implements the release_assert() macro */ -void _release_assert(const char *str, const char *file, int line); - -/* To be provided by the main application */ -void out_of_memory(void); - #endif /* vim:set sw=2 expandtab: */ diff --git a/interp.c b/interp.c index 76ec667..b8624ae 100644 --- a/interp.c +++ b/interp.c @@ -31,8 +31,6 @@ static void vector_set(value_t v, fixnum_t idx, value_t newval); static void byte_string_set(value_t v, fixnum_t idx, char newval); static void struct_set(value_t v, fixnum_t idx, value_t newval); -static int byte_string_cmp(value_t s1, value_t s2); - static value_t make_lambda(interp_state_t *state, value_t templ); static void translate_callable(interp_state_t *state); @@ -86,7 +84,7 @@ value_t run_interpreter(value_t lambda, value_t argv) if (is_builtin_fn(state.lambda.value)) { /* Builtin functions replace the byte-code and tail-call steps. */ - _get_builtin_fn(state.lambda.value)(&state); + get_builtin_fn(state.lambda.value)(&state); } else { @@ -108,7 +106,7 @@ value_t run_interpreter(value_t lambda, value_t argv) /* Clear (used) transient slots so they can be GC'd. */ for (int i = 0; i < state.ntransients; ++i) - _get_vector(state.transients.value)->elements[i] = UNDEFINED; + get_vector(state.transients.value)->elements[i] = UNDEFINED; /* Clear temporaries. */ state.globals.value = UNDEFINED; @@ -129,7 +127,7 @@ value_t run_interpreter(value_t lambda, value_t argv) /* Note that recursion is limited to a single level by the static variable. */ run_finalizers = false; - run_interpreter(f_root.value, cons(v, NIL)); + run_interpreter(f_root.value, make_pair(v, NIL)); run_finalizers = true; unregister_gc_root(&f_root); @@ -146,16 +144,16 @@ value_t run_interpreter(value_t lambda, value_t argv) static value_t vector_ref(value_t v, fixnum_t idx) { vector_t *vec = get_vector(v); - if (!((idx >= 0) && (idx < vec->size))) - fprintf(stderr, "idx=%d, vec->size=%d\n", (int)idx, (int)vec->size); - release_assert((idx >= 0) && (idx < vec->size)); + if (!((idx >= 0) && (idx < vec->nelements))) + fprintf(stderr, "idx=%d, vec->nelements=%d\n", (int)idx, (int)vec->nelements); + release_assert((idx >= 0) && (idx < vec->nelements)); return vec->elements[idx]; } static uint8_t byte_string_ref(value_t v, fixnum_t idx) { byte_string_t *str = get_byte_string(v); - release_assert((idx >= 0) && (idx < str->size)); + release_assert((idx >= 0) && (idx < str->nbytes)); return str->bytes[idx]; } @@ -177,7 +175,7 @@ static void vector_set(value_t v, fixnum_t idx, value_t newval) { vector_t *vec = get_vector(v); release_assert(!vec->immutable); - release_assert((idx >= 0) && (idx < vec->size)); + release_assert((idx >= 0) && (idx < vec->nelements)); vec->elements[idx] = newval; WRITE_BARRIER(v); } @@ -186,7 +184,7 @@ static void byte_string_set(value_t v, fixnum_t idx, char newval) { byte_string_t *str = get_byte_string(v); release_assert(!str->immutable); - release_assert((idx >= 0) && (idx < str->size)); + release_assert((idx >= 0) && (idx < str->nbytes)); str->bytes[idx] = newval; } @@ -199,16 +197,6 @@ static void struct_set(value_t v, fixnum_t idx, value_t newval) WRITE_BARRIER(v); } -static int byte_string_cmp(value_t s1, value_t s2) -{ - byte_string_t *str1 = get_byte_string(s1); - byte_string_t *str2 = get_byte_string(s2); - - if (str1->size < str2->size) return -1; - else if (str1->size > str2->size) return 1; - else return memcmp(str1->bytes, str2->bytes, str1->size); -} - static value_t make_lambda(interp_state_t *state, value_t templ) { gc_root_t templ_root, lambda_root; @@ -227,13 +215,13 @@ static value_t make_lambda(interp_state_t *state, value_t templ) /* Need to do this first, since it can call the garbage collector. */ temp = make_vector(get_byte_string(get_struct(templ_root.value) - ->slots[TEMPLATE_SLOT_INSTANCE_VARS])->size, + ->slots[TEMPLATE_SLOT_INSTANCE_VARS])->nbytes, UNDEFINED); _LAMBDA_SLOT(lambda_root.value, INSTANCE_VARS) = temp; WRITE_BARRIER(lambda_root.value); - ls = _get_struct(lambda_root.value); - ts = _get_struct(templ_root.value); + ls = get_struct(lambda_root.value); + ts = get_struct(templ_root.value); /* All but the instance variables are just shallow-copied. */ ls->slots[LAMBDA_SLOT_GLOBAL_VARS] = ts->slots[TEMPLATE_SLOT_GLOBAL_VARS]; @@ -242,10 +230,10 @@ static value_t make_lambda(interp_state_t *state, value_t templ) ls->immutable = true; WRITE_BARRIER(lambda_root.value); - l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]); + l_inst = get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]); t_inst = get_byte_string(ts->slots[TEMPLATE_SLOT_INSTANCE_VARS]); - for (size_t i = 0; i < t_inst->size; ++i) + for (size_t i = 0; i < t_inst->nbytes; ++i) { l_inst->elements[i] = get_input(state, t_inst->bytes[i]); } @@ -264,7 +252,7 @@ static void translate_callable(interp_state_t *state) !struct_is_a(state->lambda.value, get_lambda_type())) { /* Prepend structure instance to argument list, per proxy protocol. */ - state->argv.value = cons(state->lambda.value, state->argv.value); + state->argv.value = make_pair(state->lambda.value, state->argv.value); /* Follow link to next callable. Must be a structure! */ state->lambda.value = _SLOT_VALUE(STRUCTURE, get_struct(state->lambda.value)->type, CALLABLE); @@ -281,12 +269,12 @@ static void run_byte_code(interp_state_t *state) { byte_string_t *s = get_byte_string(state->byte_code.value); release_assert(s->immutable); - release_assert(s->size <= sizeof byte_code); - release_assert((s->size % 4) == 0); + release_assert(s->nbytes <= sizeof byte_code); + release_assert((s->nbytes % 4) == 0); /* Copy byte code to temporary buffer for faster access. */ - nwords = s->size / 4; - memcpy(byte_code, s->bytes, s->size); + nwords = s->nbytes / 4; + memcpy(byte_code, s->bytes, s->nbytes); } for (int word = 0; word < nwords; ++word) @@ -297,7 +285,7 @@ static void run_byte_code(interp_state_t *state) if (bytes[0] == 0x00 && bytes[1] == 0x70) /* (tail-call-if cond tail-call) */ { /* Must handle this here, as it may end the loop. */ - if (_get_boolean(get_input(state, bytes[2]))) + if (get_boolean(get_input(state, bytes[2]))) { value_t tc = get_input(state, bytes[3]); if (tc != FALSE_VALUE) state->tail_call.value = tc; @@ -320,7 +308,7 @@ static void run_byte_code(interp_state_t *state) fflush(stderr); #endif - _get_vector(state->transients.value)->elements[state->ntransients++] = result; + get_vector(state->transients.value)->elements[state->ntransients++] = result; WRITE_BARRIER(state->transients.value); } } @@ -347,7 +335,7 @@ static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, switch (code) { case 0x10: - return _get_boolean(v1) ? v2 : v3; + return get_boolean(v1) ? v2 : v3; case 0x20: vector_set(v1, get_fixnum(v2), v3); return UNDEFINED; @@ -371,8 +359,8 @@ static void perform_tail_call(interp_state_t *state) value_t new_lambda, new_argv, new_kw_args, new_kw_vals, new_ctx, new_k; release_assert(get_byte_string(state->tail_call.value)->immutable); - release_assert(_get_byte_string(state->tail_call.value)->size == 6); - memcpy(bytes, _get_byte_string(state->tail_call.value)->bytes, 6); + release_assert(get_byte_string(state->tail_call.value)->nbytes == 6); + memcpy(bytes, get_byte_string(state->tail_call.value)->bytes, 6); register_gc_root(&root, make_lambda(state, get_input(state, bytes[0]))); new_k = make_lambda(state, get_input(state, bytes[5])); @@ -406,33 +394,33 @@ static value_t eval_binary_expression(interp_state_t *state, uint8_t code, uint8 switch (code) { - case 0x01: return boolean_value(v1 == v2); - case 0x02: return cons(v1, v2); + case 0x01: return make_boolean(v1 == v2); + case 0x02: return make_pair(v1, v2); case 0x03: return make_vector(get_fixnum(v1), v2); case 0x04: return make_byte_string(get_fixnum(v1), (char)get_fixnum(v2)); case 0x05: return vector_ref(v1, get_fixnum(v2)); - case 0x06: return fixnum_value(byte_string_ref(v1, get_fixnum(v2))); + case 0x06: return make_fixnum(byte_string_ref(v1, get_fixnum(v2))); case 0x07: return struct_ref(v1, get_fixnum(v2)); - case 0x08: return fixnum_value(get_fixnum(v1) + get_fixnum(v2)); - case 0x09: return fixnum_value(get_fixnum(v1) - get_fixnum(v2)); - case 0x0a: return fixnum_value(get_fixnum(v1) * get_fixnum(v2)); - case 0x0b: return fixnum_value(get_fixnum(v1) / get_fixnum(v2)); - case 0x0c: return fixnum_value(get_fixnum(v1) % get_fixnum(v2)); - case 0x0d: return boolean_value(get_fixnum(v1) < get_fixnum(v2)); - case 0x0e: return boolean_value(get_fixnum(v1) >= get_fixnum(v2)); - case 0x10: return fixnum_value(get_fixnum(v1) & get_fixnum(v2)); - case 0x11: return fixnum_value(get_fixnum(v1) | get_fixnum(v2)); - case 0x12: return fixnum_value(get_fixnum(v1) ^ get_fixnum(v2)); - case 0x14: return fixnum_value(get_fixnum(v1) << get_fixnum(v2)); - case 0x15: return fixnum_value(get_fixnum(v1) >> get_fixnum(v2)); - case 0x16: return fixnum_value((unsigned long)get_fixnum(v1) >> get_fixnum(v2)); + case 0x08: return make_fixnum(get_fixnum(v1) + get_fixnum(v2)); + case 0x09: return make_fixnum(get_fixnum(v1) - get_fixnum(v2)); + case 0x0a: return make_fixnum(get_fixnum(v1) * get_fixnum(v2)); + case 0x0b: return make_fixnum(get_fixnum(v1) / get_fixnum(v2)); + case 0x0c: return make_fixnum(get_fixnum(v1) % get_fixnum(v2)); + case 0x0d: return make_boolean(get_fixnum(v1) < get_fixnum(v2)); + case 0x0e: return make_boolean(get_fixnum(v1) >= get_fixnum(v2)); + case 0x10: return make_fixnum(get_fixnum(v1) & get_fixnum(v2)); + case 0x11: return make_fixnum(get_fixnum(v1) | get_fixnum(v2)); + case 0x12: return make_fixnum(get_fixnum(v1) ^ get_fixnum(v2)); + case 0x14: return make_fixnum(get_fixnum(v1) << get_fixnum(v2)); + case 0x15: return make_fixnum(get_fixnum(v1) >> get_fixnum(v2)); + case 0x16: return make_fixnum((unsigned long)get_fixnum(v1) >> get_fixnum(v2)); case 0x18: return make_float(get_float(v1) + get_float(v2)); case 0x19: return make_float(get_float(v1) - get_float(v2)); case 0x1a: return make_float(get_float(v1) * get_float(v2)); case 0x1b: return make_float(get_float(v1) / get_float(v2)); - case 0x1c: return boolean_value(get_float(v1) == get_float(v2)); - case 0x1d: return boolean_value(get_float(v1) < get_float(v2)); - case 0x1e: return boolean_value(get_float(v1) >= get_float(v2)); + case 0x1c: return make_boolean(get_float(v1) == get_float(v2)); + case 0x1d: return make_boolean(get_float(v1) < get_float(v2)); + case 0x1e: return make_boolean(get_float(v1) >= get_float(v2)); case 0x20: return make_float(atan2(get_float(v1), get_float(v2))); case 0x21: return make_float(pow(get_float(v1), get_float(v2))); case 0x22: return make_float(ldexp(get_float(v1), get_fixnum(v2))); @@ -443,10 +431,10 @@ static value_t eval_binary_expression(interp_state_t *state, uint8_t code, uint8 case 0x27: return make_float(nextafter(get_float(v1), get_float(v2))); case 0x28: return make_float(remainder(get_float(v1), get_float(v2))); case 0x29: return make_float(scalb(get_float(v1), get_float(v2))); - case 0x30: return boolean_value(struct_is_a(v1, v2)); - case 0x31: return boolean_value(byte_string_cmp(v1, v2) == 0); - case 0x32: return boolean_value(byte_string_cmp(v1, v2) < 0); - case 0x33: return boolean_value(byte_string_cmp(v1, v2) >= 0); + case 0x30: return make_boolean(struct_is_a(v1, v2)); + case 0x31: return make_boolean(byte_strcmp(v1, v2) == 0); + case 0x32: return make_boolean(byte_strcmp(v1, v2) < 0); + case 0x33: return make_boolean(byte_strcmp(v1, v2) >= 0); case 0x50: get_box(v1)->value = v2; @@ -462,9 +450,9 @@ static value_t eval_binary_expression(interp_state_t *state, uint8_t code, uint8 return UNDEFINED; case 0xff: - if (_get_boolean(v1)) + if (get_boolean(v1)) { - if (_get_boolean(v2)) + if (get_boolean(v2)) { fprint_value(stderr, v2); fputc('\n', stderr); @@ -493,33 +481,33 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_ case 0x03: return get_pair(v1)->car; case 0x04: return get_pair(v1)->cdr; - case 0x08: return boolean_value(is_boolean(v1)); - case 0x09: return boolean_value(is_fixnum(v1)); - case 0x0a: return boolean_value(is_box(v1)); - case 0x0b: return boolean_value(is_pair(v1)); - case 0x0c: return boolean_value(is_vector(v1)); - case 0x0d: return boolean_value(is_byte_string(v1)); - case 0x0e: return boolean_value(is_struct(v1)); - case 0x0f: return boolean_value(is_float(v1)); - case 0x10: return boolean_value(is_builtin_fn(v1)); - case 0x11: return boolean_value(is_weak_box(v1)); + case 0x08: return make_boolean(is_boolean(v1)); + case 0x09: return make_boolean(is_fixnum(v1)); + case 0x0a: return make_boolean(is_box(v1)); + case 0x0b: return make_boolean(is_pair(v1)); + case 0x0c: return make_boolean(is_vector(v1)); + case 0x0d: return make_boolean(is_byte_string(v1)); + case 0x0e: return make_boolean(is_struct(v1)); + case 0x0f: return make_boolean(is_float(v1)); + case 0x10: return make_boolean(is_builtin_fn(v1)); + case 0x11: return make_boolean(is_weak_box(v1)); case 0x18: return make_box(v1); case 0x19: return make_struct(v1); - case 0x1a: return make_float((native_float_t)get_fixnum(v1)); + case 0x1a: return make_float((fpnum_t)get_fixnum(v1)); case 0x1b: return make_lambda(state, v1); case 0x1c: return make_weak_box(v1); - case 0x20: return boolean_value(!_get_boolean(v1)); - case 0x21: return fixnum_value(~get_fixnum(v1)); - case 0x22: return fixnum_value(-get_fixnum(v1)); + case 0x20: return make_boolean(!get_boolean(v1)); + case 0x21: return make_fixnum(~get_fixnum(v1)); + case 0x22: return make_fixnum(-get_fixnum(v1)); case 0x23: return make_float(-get_float(v1)); - case 0x28: return fixnum_value(get_vector(v1)->size); - case 0x29: return fixnum_value(get_byte_string(v1)->size); - case 0x2a: return fixnum_value(get_struct(v1)->nslots); + case 0x28: return make_fixnum(get_vector(v1)->nelements); + case 0x29: return make_fixnum(get_byte_string(v1)->nbytes); + case 0x2a: return make_fixnum(get_struct(v1)->nslots); case 0x2b: return get_struct(v1)->type; - case 0x2c: return get_hash_value(v1); + case 0x2c: return make_fixnum(((int32_t)v1 << 1) >> 1); case 0x30: return make_float(acos(get_float(v1))); case 0x31: return make_float(asin(get_float(v1))); @@ -534,7 +522,7 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_ case 0x3a: { int exp; value_t v2 = make_float(frexp(get_float(v1), &exp)); - return cons(v2, fixnum_value(exp)); + return make_pair(v2, make_fixnum(exp)); } case 0x3b: return make_float(log(get_float(v1))); case 0x3c: return make_float(log10(get_float(v1))); @@ -547,7 +535,7 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_ v3 = make_float(integral_part); unregister_gc_root(&rv2); - return cons(rv2.value, v3); + return make_pair(rv2.value, v3); } case 0x3e: return make_float(sqrt(get_float(v1))); case 0x3f: return make_float(ceil(get_float(v1))); @@ -560,7 +548,7 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_ case 0x54: { int signgamp; value_t v2 = make_float(lgamma_r(get_float(v1), &signgamp)); - return cons(v2, fixnum_value(signgamp)); + return make_pair(v2, make_fixnum(signgamp)); } case 0x55: return make_float(y0(get_float(v1))); case 0x56: return make_float(y1(get_float(v1))); @@ -572,11 +560,11 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_ case 0x5c: return make_float(expm1(get_float(v1))); case 0x5d: return make_float(ilogb(get_float(v1))); case 0x5e: return make_float(log1p(get_float(v1))); - case 0x70: return boolean_value(isnormal(get_float(v1))); - case 0x71: return boolean_value(isfinite(get_float(v1))); - case 0x72: return boolean_value(fpclassify(get_float(v1)) == FP_SUBNORMAL); - case 0x73: return boolean_value(isinf(get_float(v1))); - case 0x74: return boolean_value(isnan(get_float(v1))); + case 0x70: return make_boolean(isnormal(get_float(v1))); + case 0x71: return make_boolean(isfinite(get_float(v1))); + case 0x72: return make_boolean(fpclassify(get_float(v1)) == FP_SUBNORMAL); + case 0x73: return make_boolean(isinf(get_float(v1))); + case 0x74: return make_boolean(isnan(get_float(v1))); default: release_assert(NOTREACHED("Invalid unary bytecode.")); @@ -594,22 +582,22 @@ static value_t get_input(const interp_state_t *state, fixnum_t var) { case 0x00 ... 0x7f: { - vector_t *vec = _get_vector(state->transients.value); + vector_t *vec = get_vector(state->transients.value); release_assert(var < state->ntransients); return vec->elements[var]; } case 0x80 ... 0xbf: { - vector_t *vec = _get_vector(state->globals.value); + vector_t *vec = get_vector(state->globals.value); var -= 0x80; - release_assert(var < vec->size); + release_assert(var < vec->nelements); return vec->elements[var]; } case 0xc0 ... 0xef: { - vector_t *vec = _get_vector(state->instances.value); + vector_t *vec = get_vector(state->instances.value); var -= 0xc0; - release_assert(var < vec->size); + release_assert(var < vec->nelements); return vec->elements[var]; } case 0xf0: return FALSE_VALUE; diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm index 1b3100f..3363f76 100644 --- a/libcompiler/primitives.scm +++ b/libcompiler/primitives.scm @@ -43,7 +43,7 @@ (#%byte-string-size #x29 byte-string-size) (#%struct-nslots #x2a struct-nslots) (#%struct-type #x2b struct-type) - (#%hash-value #x2c hash-value) + (#%object-id #x2c object-id) (#%acos #x30 acos) (#%asin #x31 asin) (#%atan #x32 atan) diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index 2d0f17b..3538522 100644 --- a/libcompiler/writer.scm +++ b/libcompiler/writer.scm @@ -17,7 +17,7 @@ (define next-object-number (make-parameter #f)) (define symbol-structs (make-parameter #f)) -(define symbol-type '(#%immutable (#%struct (#%builtin "structure") () 1 #f))) +(define symbol-type '(#%immutable (#%struct (#%builtin "structure") #f 1 #f))) (define (write-rla-value value (port (current-output-port))) (void (parameterize ([current-output-port port] diff --git a/mods/mod_io.c b/mods/mod_io.c index 8c73876..fbf101e 100644 --- a/mods/mod_io.c +++ b/mods/mod_io.c @@ -54,14 +54,14 @@ static void bi_posix_open(interp_state_t *state) int fd; int saved_errno; - release_assert(is_nil(CDDR(state->argv.value)) || is_nil(CDR(_CDDR(state->argv.value)))); + release_assert(is_nil(CDDR(state->argv.value)) || is_nil(CDR(CDDR(state->argv.value)))); pathname = value_to_string(CAR(state->argv.value)); - flags = get_fixnum(CAR(_CDR(state->argv.value))); + flags = get_fixnum(CAR(CDR(state->argv.value))); - if (!is_nil(_CDDR(state->argv.value))) + if (!is_nil(CDDR(state->argv.value))) { - mode = get_fixnum(CAR(_CDDR(state->argv.value))); + mode = get_fixnum(CAR(CDDR(state->argv.value))); } else { @@ -91,7 +91,7 @@ static void bi_posix_dup(interp_state_t *state) int newfd; int saved_errno; - release_assert(is_nil(_CDR(state->argv.value))); + release_assert(is_nil(CDR(state->argv.value))); errno = 0; newfd = dup(oldfd); @@ -109,10 +109,10 @@ static void bi_posix_dup(interp_state_t *state) static void bi_posix_dup2(interp_state_t *state) { int oldfd = get_fixnum(CAR(state->argv.value)); - int newfd = get_fixnum(CAR(_CDR(state->argv.value))); + int newfd = get_fixnum(CAR(CDR(state->argv.value))); int saved_errno; - release_assert(is_nil(_CDDR(state->argv.value))); + release_assert(is_nil(CDDR(state->argv.value))); errno = 0; newfd = dup2(oldfd, newfd); @@ -130,17 +130,17 @@ static void bi_posix_dup2(interp_state_t *state) static void bi_posix_read(interp_state_t *state) { int fd = get_fixnum(CAR(state->argv.value)); - value_t str = CAR(_CDR(state->argv.value)); - fixnum_t count = get_fixnum(CAR(_CDDR(state->argv.value))); + value_t str = CAR(CDR(state->argv.value)); + fixnum_t count = get_fixnum(CAR(CDDR(state->argv.value))); ssize_t result; int saved_errno; release_assert(is_byte_string(str)); - release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); - release_assert((0 <= count) && (count <= _get_byte_string(str)->size)); + release_assert(is_nil(CDR(CDDR(state->argv.value)))); + release_assert((0 <= count) && (count <= get_byte_string(str)->nbytes)); errno = 0; - result = read(fd, _get_byte_string(str)->bytes, count); + result = read(fd, get_byte_string(str)->bytes, count); saved_errno = errno; release_assert(is_valid_fixnum(result)); @@ -155,27 +155,27 @@ static void bi_posix_read(interp_state_t *state) static void bi_posix_write(interp_state_t *state) { int fd = get_fixnum(CAR(state->argv.value)); - value_t str = CAR(_CDR(state->argv.value)); + value_t str = CAR(CDR(state->argv.value)); fixnum_t count; ssize_t result; int saved_errno; release_assert(is_byte_string(str)); - if (!is_nil(_CDDR(state->argv.value))) + if (!is_nil(CDDR(state->argv.value))) { - count = get_fixnum(CAR(_CDDR(state->argv.value))); - release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); + count = get_fixnum(CAR(CDDR(state->argv.value))); + release_assert(is_nil(CDR(CDDR(state->argv.value)))); } else { - count = _get_byte_string(str)->size; + count = get_byte_string(str)->nbytes; } - release_assert((0 <= count) && (count <= _get_byte_string(str)->size)); + release_assert((0 <= count) && (count <= get_byte_string(str)->nbytes)); errno = 0; - result = write(fd, _get_byte_string(str)->bytes, count); + result = write(fd, get_byte_string(str)->bytes, count); saved_errno = errno; release_assert(is_valid_fixnum(result)); @@ -190,12 +190,12 @@ static void bi_posix_write(interp_state_t *state) static void bi_posix_lseek(interp_state_t *state) { int fd = get_fixnum(CAR(state->argv.value)); - fixnum_t off = get_fixnum(CAR(_CDR(state->argv.value))); - fixnum_t whence = get_fixnum(CAR(_CDDR(state->argv.value))); + fixnum_t off = get_fixnum(CAR(CDR(state->argv.value))); + fixnum_t whence = get_fixnum(CAR(CDDR(state->argv.value))); off_t result; int saved_errno; - release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); + release_assert(is_nil(CDR(CDDR(state->argv.value)))); errno = 0; result = lseek(fd, off, whence); @@ -224,7 +224,7 @@ static void bi_posix_close(interp_state_t *state) ssize_t result; int saved_errno; - release_assert(is_nil(_CDR(state->argv.value))); + release_assert(is_nil(CDR(state->argv.value))); errno = 0; result = close(fd); diff --git a/reader.c b/reader.c index c9613d0..1f8a0a2 100644 --- a/reader.c +++ b/reader.c @@ -105,9 +105,9 @@ static inline void next_char(reader_state_t *state) void reader_init(void) { - register_gc_root(&reference_root, make_struct_type(NIL, REFERENCE_SLOTS, FALSE_VALUE)); - register_gc_root(&struct_ph_root, make_struct_type(NIL, STRUCT_PH_SLOTS, FALSE_VALUE)); - register_gc_root(&immutable_ph_root, make_struct_type(NIL, IMMUTABLE_PH_SLOTS, FALSE_VALUE)); + register_gc_root(&reference_root, make_struct_type(FALSE_VALUE, REFERENCE_SLOTS, FALSE_VALUE)); + register_gc_root(&struct_ph_root, make_struct_type(FALSE_VALUE, STRUCT_PH_SLOTS, FALSE_VALUE)); + register_gc_root(&immutable_ph_root, make_struct_type(FALSE_VALUE, IMMUTABLE_PH_SLOTS, FALSE_VALUE)); } value_t read_value_from_file(FILE *f) @@ -269,8 +269,8 @@ static void reverse_list(value_t *list, value_t newcdr) while (is_pair(lst)) { - value_t temp = _get_pair(lst)->cdr; - _get_pair(lst)->cdr = newcdr; + value_t temp = get_pair(lst)->cdr; + get_pair(lst)->cdr = newcdr; WRITE_BARRIER(lst); newcdr = lst; lst = temp; @@ -318,7 +318,7 @@ static value_t read_list(reader_state_t *state) default: { value_t temp = read_one_value(state); - list_root.value = cons(temp, list_root.value); + list_root.value = make_pair(temp, list_root.value); } break; } @@ -415,14 +415,14 @@ static value_t read_fixnum(reader_state_t *state, int radix) num = -num; release_assert((FIXNUM_MIN <= num) && (num <= FIXNUM_MAX)); - return fixnum_value(num); + return make_fixnum(num); } static value_t read_number(reader_state_t *state) { bool negative = false; fixnum_t num = 0; - native_float_t flt; + fpnum_t flt; int radix; if (state->ch == '-') @@ -493,7 +493,7 @@ static value_t read_number(reader_state_t *state) num = -num; release_assert(!issymbol(state->ch)); release_assert((FIXNUM_MIN <= num) && (num <= FIXNUM_MAX)); - return fixnum_value(num); + return make_fixnum(num); } /* @@ -506,7 +506,7 @@ static value_t read_number(reader_state_t *state) { next_char(state); - for (native_float_t pv = negative ? -0.1 : 0.1; isdigit(state->ch); pv /= 10) + for (fpnum_t pv = negative ? -0.1 : 0.1; isdigit(state->ch); pv /= 10) { flt += (state->ch - '0') * pv; next_char(state); @@ -517,7 +517,7 @@ static value_t read_number(reader_state_t *state) { next_char(state); num = read_fixnum(state, 10); - flt *= pow(10, _get_fixnum(num)); + flt *= pow(10, get_fixnum(num)); } if (negative) @@ -664,7 +664,7 @@ static value_t read_string(reader_state_t *state) next_char(state); value = make_byte_string(length, '\0'); - memcpy(_get_byte_string(value)->bytes, buffer, length); + memcpy(get_byte_string(value)->bytes, buffer, length); free(buffer); return value; @@ -709,9 +709,9 @@ static value_t read_vector(reader_state_t *state) item = list_root.value; for (size_t i = 0; i < length; ++i) { - _get_vector(value)->elements[i] = _CAR(item); + get_vector(value)->elements[i] = CAR(item); /* No write barrier needed here. */ - item = _CDR(item); + item = CDR(item); } unregister_gc_root(&list_root); @@ -744,7 +744,7 @@ static value_t read_weak_box(reader_state_t *state) register_gc_root(&value_root, NIL); value_root.value = read_one_value(state); - state->weak_list.value = cons(value_root.value, state->weak_list.value); + state->weak_list.value = make_pair(value_root.value, state->weak_list.value); unregister_gc_root(&value_root); return make_weak_box(value_root.value); @@ -806,15 +806,15 @@ static value_t freeze(value_t val) { if (is_vector(val)) { - _get_vector(val)->immutable = true; + get_vector(val)->immutable = true; } else if (is_byte_string(val)) { - _get_byte_string(val)->immutable = true; + get_byte_string(val)->immutable = true; } else if (is_struct(val)) { - _get_struct(val)->immutable = true; + get_struct(val)->immutable = true; } else { @@ -832,12 +832,12 @@ static bool is_reference(reader_state_t *state, value_t value) static value_t get_reference(reader_state_t *state, fixnum_t refid) { - value_t refidval = fixnum_value(refid); + value_t refidval = make_fixnum(refid); - for (value_t item = state->ref_list.value; !is_nil(item); item = _CDR(item)) + for (value_t item = state->ref_list.value; !is_nil(item); item = CDR(item)) { - if (REF_IDENT(_CAR(item)) == refidval) - return _CAR(item); + if (REF_IDENT(CAR(item)) == refidval) + return CAR(item); } /* No existing reference with that number; create a new one. */ @@ -846,9 +846,9 @@ static value_t get_reference(reader_state_t *state, fixnum_t refid) REF_IDENT(ref) = refidval; REF_VALUE(ref) = UNDEFINED; REF_PATCHED(ref) = FALSE_VALUE; - state->ref_list.value = cons(ref, state->ref_list.value); + state->ref_list.value = make_pair(ref, state->ref_list.value); } - return _CAR(state->ref_list.value); + return CAR(state->ref_list.value); } static void set_reference(reader_state_t *state, value_t ref, value_t value) @@ -868,9 +868,9 @@ static void finalize_references(reader_state_t *state) changed = false; /* Resolve one level of placeholder-to-placeholder links. */ - for (value_t item = state->ref_list.value; !is_nil(item); item = _CDR(item)) + for (value_t item = state->ref_list.value; !is_nil(item); item = CDR(item)) { - value_t ref = _CAR(item); + value_t ref = CAR(item); if (REF_VALUE(ref) == ref) { /* Self-links indicate cycles. */ @@ -898,7 +898,7 @@ static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen if (struct_is_a(in, reference_root.value)) { - if (!_get_boolean(REF_PATCHED(in))) + if (!get_boolean(REF_PATCHED(in))) { value_t val; @@ -931,7 +931,7 @@ static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen } else if (struct_is_a(in_root.value, struct_ph_root.value)) { - if (_get_boolean(STRUCT_PH_RESULT(in_root.value))) + if (get_boolean(STRUCT_PH_RESULT(in_root.value))) { in_root.value = STRUCT_PH_RESULT(in_root.value); } @@ -946,51 +946,51 @@ static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen values = STRUCT_PH_VALUES(in_root.value); in_root.value = sval; - for (int i = 0; i < _get_struct(in_root.value)->nslots; ++i) + for (int i = 0; i < get_struct(in_root.value)->nslots; ++i) { if (is_nil(values)) break; - _get_struct(in_root.value)->slots[i] = CAR(values); - values = _CDR(values); + get_struct(in_root.value)->slots[i] = CAR(values); + values = CDR(values); } WRITE_BARRIER(in_root.value); - for (int i = 0; i < _get_struct(in_root.value)->nslots; ++i) + for (int i = 0; i < get_struct(in_root.value)->nslots; ++i) { - value_t val = _patch_placeholders(state, _get_struct(in_root.value)->slots[i], &this_seen); - _get_struct(in_root.value)->slots[i] = val; + value_t val = _patch_placeholders(state, get_struct(in_root.value)->slots[i], &this_seen); + get_struct(in_root.value)->slots[i] = val; WRITE_BARRIER(in_root.value); } } } else if (is_box(in_root.value)) { - value_t val = _patch_placeholders(state, _get_box(in_root.value)->value, &this_seen); - _get_box(in_root.value)->value = val; + value_t val = _patch_placeholders(state, get_box(in_root.value)->value, &this_seen); + get_box(in_root.value)->value = val; WRITE_BARRIER(in_root.value); } else if (is_weak_box(in_root.value)) { - value_t val = _patch_placeholders(state, _get_weak_box(in_root.value)->value, &this_seen); - _get_weak_box(in_root.value)->value = val; + value_t val = _patch_placeholders(state, get_weak_box(in_root.value)->value, &this_seen); + get_weak_box(in_root.value)->value = val; WRITE_BARRIER(in_root.value); } else if (is_pair(in_root.value)) { value_t val; - val = _patch_placeholders(state, _CAR(in_root.value), &this_seen); - _CAR(in_root.value) = val; + val = _patch_placeholders(state, CAR(in_root.value), &this_seen); + CAR(in_root.value) = val; WRITE_BARRIER(in_root.value); - val = _patch_placeholders(state, _CDR(in_root.value), &this_seen); - _CDR(in_root.value) = val; + val = _patch_placeholders(state, CDR(in_root.value), &this_seen); + CDR(in_root.value) = val; WRITE_BARRIER(in_root.value); } else if (is_vector(in_root.value)) { - size_t nelem = _get_vector(in_root.value)->size; + size_t nelem = get_vector(in_root.value)->nelements; for (size_t i = 0; i < nelem; ++i) { - value_t val = _patch_placeholders(state, _get_vector(in_root.value)->elements[i], &this_seen); - _get_vector(in_root.value)->elements[i] = val; + value_t val = _patch_placeholders(state, get_vector(in_root.value)->elements[i], &this_seen); + get_vector(in_root.value)->elements[i] = val; WRITE_BARRIER(in_root.value); } } diff --git a/rosella.c b/rosella.c index bf87383..0f6e63e 100644 --- a/rosella.c +++ b/rosella.c @@ -47,7 +47,7 @@ int main(int argc, char **argv) } #endif - gc_init(8*1024*1024, 4*1024*1024, 64*1024*1024); + gc_init(); builtin_init(); interpreter_init(); #ifdef HAVE_MOD_IO @@ -82,7 +82,7 @@ int main(int argc, char **argv) for (int i = argc - 1; i >= 2; --i) { value_t temp = string_to_value(argv[i]); - argv_root.value = cons(temp, argv_root.value); + argv_root.value = make_pair(temp, argv_root.value); } if (argc >= 2) @@ -95,14 +95,14 @@ int main(int argc, char **argv) fflush(stdin); } - collect_garbage(4*1024*1024); + collect_garbage(); unregister_gc_root(&argv_root); unregister_gc_root(&program_root); results = run_interpreter(program_root.value, argv_root.value); - for (value_t result = results; !is_nil(result); result = _CDR(result)) + for (value_t result = results; !is_nil(result); result = CDR(result)) { print_value(CAR(result)); nl(); @@ -145,22 +145,22 @@ static void test_weak_boxes_and_wills(void) register_gc_root(&box_root, UNDEFINED); register_gc_root(&tmp_root, UNDEFINED); - tmp_root.value = cons(fixnum_value(1), cons(fixnum_value(2), NIL)); + tmp_root.value = make_pair(make_fixnum(1), make_pair(make_fixnum(2), NIL)); box_root.value = make_weak_box(tmp_root.value); - register_finalizer(tmp_root.value, fixnum_value(10)); + register_finalizer(tmp_root.value, make_fixnum(10)); print_weak_box_results(box_root.value); - collect_garbage(0); + collect_garbage(); print_weak_box_results(box_root.value); tmp_root.value = UNDEFINED; print_weak_box_results(box_root.value); - collect_garbage(0); + collect_garbage(); print_weak_box_results(box_root.value); - collect_garbage(0); + collect_garbage(); print_weak_box_results(box_root.value); nl(); @@ -180,7 +180,7 @@ static void test_garbage_collection(bool keep_going) /* Construct a large, static tree w/ many links. */ for (int i = 0; i < 1000000; ++i) { - root2.value = cons(root2.value, root2.value); + root2.value = make_pair(root2.value, root2.value); } while (1) @@ -189,35 +189,35 @@ static void test_garbage_collection(bool keep_going) if (r == 0) { - root.value = fixnum_value(rand()); + root.value = make_fixnum(rand()); } else { switch (r & 15) { case 0: - root.value = cons(fixnum_value(rand()), root.value); + root.value = make_pair(make_fixnum(rand()), root.value); break; case 1: - root.value = cons(root.value, make_byte_string(256, '\0')); + root.value = make_pair(root.value, make_byte_string(256, '\0')); break; case 2: root.value = make_box(root.value); break; case 3: - root.value = cons(root.value, cons(fixnum_value(-1), NIL)); - _CDDR(root.value) = root.value; - WRITE_BARRIER(_CDR(root.value)); + root.value = make_pair(root.value, make_pair(make_fixnum(-1), NIL)); + CDDR(root.value) = root.value; + WRITE_BARRIER(CDR(root.value)); break; case 4: { value_t s = make_vector(4, FALSE_VALUE); - _get_vector(s)->elements[r & 3] = root.value; + get_vector(s)->elements[r & 3] = root.value; root.value = s; } break; default: - (void)cons(make_box(NIL), cons(NIL, cons(NIL, NIL))); + (void)make_pair(make_box(NIL), make_pair(NIL, make_pair(NIL, NIL))); break; } } diff --git a/src/compiler.rls b/src/compiler.rls index 7ee71e3..c919ccc 100644 --- a/src/compiler.rls +++ b/src/compiler.rls @@ -17,7 +17,7 @@ (load "lib/reader.rls") (load "lib/writer.rls") -(define s:evaluation-environment (make-structure '() 2)) +(define s:evaluation-environment (make-structure #f 2)) (define (make-evaluation-environment parent-env n-vars) (let ([env (make-struct s:evaluation-environment)]) @@ -38,7 +38,7 @@ (define (evaluation-environment-local-variable-values env) (struct-ref (type-check s:evaluation-environment env) 1)) -(define s:compilation-environment (make-structure '() 5)) +(define s:compilation-environment (make-structure #f 5)) (define (make-compilation-environment parent-env @@ -686,7 +686,6 @@ (register-top-level-binding 'byte-string-size (lambda (x) (#%byte-string-size x))) (register-top-level-binding 'struct-nslots (lambda (x) (#%struct-nslots x))) (register-top-level-binding 'struct-type (lambda (x) (#%struct-type x))) -(register-top-level-binding 'hash-value (lambda (x) (#%hash-value x))) (register-top-level-binding 'acos (lambda (x) (#%acos x))) (register-top-level-binding 'asin (lambda (x) (#%asin x))) (register-top-level-binding 'atan (lambda (x) (#%atan x))) @@ -808,6 +807,8 @@ (register-top-level-binding 'call-with-context (#%builtin "call-with-context")) (register-top-level-binding 'exit (#%builtin "exit")) (register-top-level-binding 'float->string (#%builtin "float->string")) +(register-top-level-binding 'hash-by-id (#%builtin "hash-by-id")) +(register-top-level-binding 'hash-by-value (#%builtin "hash-by-value")) (register-top-level-binding 'posix-open (#%builtin "posix-open")) (register-top-level-binding 'posix-dup (#%builtin "posix-dup")) (register-top-level-binding 'posix-dup2 (#%builtin "posix-dup2")) diff --git a/src/examples/annotated-structs.rla b/src/examples/annotated-structs.rla index d19f980..0f4ef1e 100644 --- a/src/examples/annotated-structs.rla +++ b/src/examples/annotated-structs.rla @@ -2,17 +2,17 @@ #@#( ( #@#0=#S(#="structure" - (#="structure") + #="structure" 5 #f ) #@#1=#S(#=0 - (#="structure") + #="structure" 5 #f #@"annotated-structure" #@#( - #@"supers" + #@"super" #@"nslots" #@"callable" #@"name" @@ -20,7 +20,7 @@ ) ) #@#2=#S(#=1 - (#="lambda") + #="lambda" 4 #f #@"annotated-lambda" diff --git a/src/lib/hash-table.rls b/src/lib/hash-table.rls index 570de50..c0c9f2e 100644 --- a/src/lib/hash-table.rls +++ b/src/lib/hash-table.rls @@ -5,9 +5,9 @@ (define @minimum-buckets@ 17) -(define s:hash-table (make-structure '() 4)) +(define s:hash-table (make-structure #f 4)) (define (make-hash-table [eq-fn (lambda (x y) (equal? x y))] - [hash-fn (lambda (x) (hash-value x))]) + [hash-fn (lambda (x) (hash-by-value x))]) (let ([ht (make-struct s:hash-table)]) (struct-set! ht 0 eq-fn) (struct-set! ht 1 hash-fn) diff --git a/src/lib/keywords.rls b/src/lib/keywords.rls index fa68407..39a733d 100644 --- a/src/lib/keywords.rls +++ b/src/lib/keywords.rls @@ -1,4 +1,4 @@ -(define s:keyword (make-structure '() 1)) +(define s:keyword (make-structure #f 1)) (define *keywords* (make-hash-table)) (define (make-keyword name) diff --git a/src/lib/names.rls b/src/lib/names.rls index dc2a712..042a837 100644 --- a/src/lib/names.rls +++ b/src/lib/names.rls @@ -15,7 +15,7 @@ (and v1 (eq? v1 (weak-unbox wb2))))) (define (weak-hash-value wb) - (hash-value (weak-unbox wb))) + (hash-by-id (weak-unbox wb))) (define *name-table* (make-hash-table weak-eq? weak-hash-value)) diff --git a/src/lib/parameters.rls b/src/lib/parameters.rls index 2aa1a98..a03e9bd 100644 --- a/src/lib/parameters.rls +++ b/src/lib/parameters.rls @@ -1,4 +1,4 @@ -(define s:dynamic-environment (make-structure '() 1)) +(define s:dynamic-environment (make-structure #f 1)) (define top-level-dynamic-environment (let ([new-env (make-struct s:dynamic-environment)]) @@ -21,7 +21,7 @@ (struct-set! env 0 lst)) (define (parameter-callable param . rst) - (define param-hash (hash-value param)) + (define param-hash (hash-by-id param)) (let repeat-with ([bind (dynamic-environment-parameters (current-dynamic-environment))]) (if bind (let ([bind-param (parameter-binding-parameter bind)]) @@ -30,14 +30,14 @@ (set-parameter-binding-value! bind (apply (parameter-guard-function param) rst)) (parameter-binding-value bind)) - (if (fix<= param-hash (hash-value bind-param)) + (if (fix<= param-hash (hash-by-id bind-param)) (repeat-with (parameter-binding-left bind)) (repeat-with (parameter-binding-right bind))))) (if (pair? rst) (set-parameter-value! param (apply (parameter-guard-function param) rst)) (parameter-value param))))) -(define s:parameter (make-structure '() 2 parameter-callable)) +(define s:parameter (make-structure #f 2 parameter-callable)) (define (make-parameter init [guard-fn values]) (let ([param (make-struct s:parameter)]) @@ -51,7 +51,7 @@ (define (set-parameter-value! param val) (struct-set! param 0 val)) (define (parameter-guard-function param) (struct-ref param 1)) -(define s:parameter-binding (make-structure '() 4)) +(define s:parameter-binding (make-structure #f 4)) (define (make-parameter-binding param val left right) (let ([binding (make-struct s:parameter-binding)]) @@ -71,12 +71,12 @@ (define (call-with-parameters fn . param-forms) (define (add-binding param+values to-bind) (define param (if (pair? param+values) (first param+values) param+values)) - (define param-hash (hash-value param)) + (define param-hash (hash-by-id param)) (define (lookup-bind bind match-fn branch-fn) (and bind (let ([bind-param (parameter-binding-parameter bind)]) (cond [(eq? bind-param param) (branch-fn bind)] - [(match-fn (hash-value bind-param) param-hash) bind] + [(match-fn (hash-by-id bind-param) param-hash) bind] [else (lookup-bind (branch-fn bind) match-fn branch-fn)])))) (let ([left-bind (lookup-bind to-bind fix<= parameter-binding-left)] [right-bind (lookup-bind to-bind fix> parameter-binding-right)] diff --git a/src/lib/port.rls b/src/lib/port.rls index f8e48e1..97da6ab 100644 --- a/src/lib/port.rls +++ b/src/lib/port.rls @@ -16,7 +16,7 @@ ((current-port-error-handler) port) (abort)) -(define s:port (make-structure '() 11)) +(define s:port (make-structure #f 11)) (define (port? x) (kind-of? x s:port)) (define (make-port flags read unread write seek tell flush diff --git a/src/lib/primitives.rls b/src/lib/primitives.rls index e961872..4b1863c 100644 --- a/src/lib/primitives.rls +++ b/src/lib/primitives.rls @@ -32,8 +32,6 @@ (define (struct-nslots x) (#%struct-nslots x)) (define (struct-type x) (#%struct-type x)) -(define (hash-value x) (#%hash-value x)) - (define (acos x) (#%acos x)) (define (asin x) (#%asin x)) (define (atan x) (#%atan x)) @@ -172,6 +170,9 @@ (define float->string (#%builtin "float->string")) +(define hash-by-id (#%builtin "hash-by-id")) +(define hash-by-value (#%builtin "hash-by-value")) + (define posix-open (#%builtin "posix-open")) ;(define posix-openat (#%builtin "posix-openat")) (define posix-dup (#%builtin "posix-dup")) diff --git a/src/lib/util.rls b/src/lib/util.rls index 4353e71..6f29446 100644 --- a/src/lib/util.rls +++ b/src/lib/util.rls @@ -74,9 +74,9 @@ (lambda () (dirname/basename str)) (lambda (_ x) x))) -(define (make-structure supers nslots [callable #f]) +(define (make-structure super nslots [callable #f]) (let ([s (make-struct s:structure)]) - (struct-set! s 0 (copy-list supers)) + (struct-set! s 0 super) (struct-set! s 1 nslots) (struct-set! s 2 callable) (freeze! s))) @@ -224,7 +224,7 @@ (or (memq (car lst) (cdr lst)) (has-duplicates? (cdr lst))))) -(define s:marker (make-structure '() 1)) +(define s:marker (make-structure #f 1)) (define (make-marker name) (let ([marker (make-struct s:marker)])