nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

First version of simplified garbage collector. 

For now, this GC is non-generational, and much slower than the old
version. It tracks objects by a fixed object ID rather than changeable
memory address. Small object (eight bytes or less) are stored directly
in the array, indexed by object ID, while larger object are allocated
with malloc() (for now) and stored in the array as a pointer. Object
IDs are stored as 32-bit integers, even on 64-bit platforms.

Advantages:
- Simpler design
- Requires less memory on 64-bit platforms
- Object IDs don't change when running the GC
- No need to store a random "hash" value in vectors/strings/structs
- Can hash pairs by identity, not just value
- Can move objects individually, without fixing up all references
- Can determine object type from value, without another memory access

Disadvantages:
- Lower initial performance (non-generational, relies on malloc())
- 32-bit values place a (high) limit on total number of objects
- Must explicitly free unreachable object IDs after GC
This commit is contained in:
Jesse D. McDonald 2012-07-14 12:59:27 -05:00
parent 8f9ce6122e
commit 9e789dce14
20 changed files with 1415 additions and 1744 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

195
builtin.c
View File

@ -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: */

2
builtin.h
View File

@ -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

2
doc/bytecode.txt
View File

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

1869
gc.c
View File

File diff suppressed because it is too large Load Diff

579
gc.h
View File

@ -7,166 +7,185 @@
#include <stdio.h>
#include <time.h>
/* 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__))
/*
** Macro Definitions
*/
/* Evaluates to false, but with an expression that conveys what went wrong. */
#define NOTREACHED(msg) 0
/*
** 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
*/
typedef uintptr_t value_t;
typedef intptr_t fixnum_t;
typedef double native_float_t;
#define FIXNUM_MIN (INT32_MIN/2)
#define FIXNUM_MAX (INT32_MAX/2)
#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 OBJECT_BLOCK_MAX 0x3ff
#define OBJECT_INDEX_MAX 0x1ffff
#define OBJECT_TAG_MAX 0xf
#define FIXNUM_MIN (INTPTR_MIN/2)
#define FIXNUM_MAX (INTPTR_MAX/2)
#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 */
/* 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);
#define OBJECT(blk, idx, tag) \
((((value_t)(blk) & 0x3ff) << 22) | \
(((value_t)(idx) & 0x1ffff) << 5) | \
(((value_t)(tag) & 0xf) << 1))
/* NIL: 00000000 00000000 00000000 00000000 */
/* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa00 (where aa... >= 1024) */
/* Pair: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa10 */
/* Fixnum: snnnnnnn nnnnnnnn nnnnnnnn nnnnnnn1 */
#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 NIL ((value_t)0)
#define SPECIAL_VALUE(n) ((value_t)(n) << 5)
#define SPECIAL_MAX ((value_t)(-1) << 5)
/* 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 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))
#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)
/* 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_SUPER 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. */
/* 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 Gen-0 GC can lead to incorrect behavior. */
#define WRITE_BARRIER(value) ((void)_gc_write_barrier((value)))
/* Failing to invoke the macro before the next GC pass can lead to incorrect behavior. */
#define WRITE_BARRIER(value) ((void)0)
typedef struct object
/* 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__))
/* Evaluates to false, but with an expression that conveys what went wrong. */
#define NOTREACHED(msg) 0
/*
** Type Definitions
*/
/* 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 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;
size_t nelements;
value_t elements[0];
} vector_t;
typedef struct byte_string
{
value_t tag; /* TYPE_TAG_BYTESTR */
size_t size;
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;
size_t nslots;
value_t hash;
bool immutable;
size_t nslots;
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;
nsec_t peak_ns;
llsize_t total_freed;
} gen[2];
llsize_t gen1_high_water;
llsize_t peak_allocated;
} gc_stats_t;
/*
** Object Declarations
*/
extern const char *const object_tag_names[16];
extern object_block_t object_blocks[OBJECT_BLOCK_MAX + 1];
extern gc_stats_t gc_stats;
/* Must be #t or #f; for generalized booleans use _get_boolean(). */
bool get_boolean(value_t v);
/*
** Function Declarations
*/
fixnum_t get_fixnum(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);
object_t *get_object(value_t v);
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 */
pair_t *get_pair(value_t pair);
value_t cons(value_t car, value_t cdr);
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: */

172
interp.c
View File

@ -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;

2
libcompiler/primitives.scm
View File

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

2
libcompiler/writer.scm
View File

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

46
mods/mod_io.c
View File

@ -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);

90
reader.c
View File

@ -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);
}
}

36
rosella.c
View File

@ -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;
}
}

7
src/compiler.rls
View File

@ -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"))

8
src/examples/annotated-structs.rla
View File

@ -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"

4
src/lib/hash-table.rls
View File

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

2
src/lib/keywords.rls
View File

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

2
src/lib/names.rls
View File

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

14
src/lib/parameters.rls
View File

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

2
src/lib/port.rls
View File

@ -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

5
src/lib/primitives.rls
View File

@ -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"))

6
src/lib/util.rls
View File

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