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)])