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 "builtin.h"
#include "interp.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 builtin_list;
static gc_root_t lambda_type_root; static gc_root_t lambda_type_root;
static gc_root_t template_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_exit(interp_state_t *state);
static void bi_float_to_string(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) void builtin_init(void)
{ {
register_gc_root(&builtin_list, NIL); register_gc_root(&builtin_list, NIL);
register_gc_root(&lambda_type_root, make_struct_type(NIL, LAMBDA_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(NIL, TEMPLATE_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_UNDEFINED, UNDEFINED);
register_builtin(BI_STRUCTURE, get_structure_type()); 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_EXIT, make_builtin_fn(bi_exit));
register_builtin(BI_FLOAT_TO_STRING, make_builtin_fn(bi_float_to_string)); 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) 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; gc_root_t name_root;
register_gc_root(&name_root, string_to_value(name)); register_gc_root(&name_root, string_to_value(name));
builtin_list.value = cons(value, builtin_list.value); builtin_list.value = make_pair(value, builtin_list.value);
builtin_list.value = cons(name_root.value, builtin_list.value); builtin_list.value = make_pair(name_root.value, builtin_list.value);
unregister_gc_root(&name_root); unregister_gc_root(&name_root);
} }
@ -82,11 +94,11 @@ value_t lookup_builtin(const char *name)
value_t name_val = string_to_value(name); value_t name_val = string_to_value(name);
for (value_t list = builtin_list.value; !is_nil(list); 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) value_t reverse_lookup_builtin(value_t value)
{ {
for (value_t list = builtin_list.value; !is_nil(list); 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); rval = lookup_builtin(str);
free(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) static void bi_builtin_to_string(interp_state_t *state)
{ {
value_t rval = reverse_lookup_builtin(CAR(state->argv.value)); 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) static void bi_values(interp_state_t *state)
@ -146,18 +158,18 @@ static void bi_freeze(interp_state_t *state)
if (is_vector(val)) if (is_vector(val))
{ {
_get_vector(val)->immutable = true; get_vector(val)->immutable = true;
} }
else if (is_byte_string(val)) else if (is_byte_string(val))
{ {
_get_byte_string(val)->immutable = true; get_byte_string(val)->immutable = true;
} }
else if (is_struct(val)) 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) 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)) if (is_vector(val))
{ {
frozen = _get_vector(val)->immutable; frozen = get_vector(val)->immutable;
} }
else if (is_byte_string(val)) else if (is_byte_string(val))
{ {
frozen = _get_byte_string(val)->immutable; frozen = get_byte_string(val)->immutable;
} }
else if (is_struct(val)) else if (is_struct(val))
{ {
frozen = _get_struct(val)->immutable; frozen = get_struct(val)->immutable;
} }
else 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); 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) 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)); str = value_to_string(CAR(state->argv.value));
num = (fixnum_t)strtoll(str, &end, 0); num = (fixnum_t)strtoll(str, &end, 0);
if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num)) if ((*end == '\0') && (get_fixnum(make_fixnum(num)) == num))
rval = fixnum_value(num); rval = make_fixnum(num);
else else
rval = FALSE_VALUE; rval = FALSE_VALUE;
free(str); 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) 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) 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); interp_return_values(state, NIL);
} }
static void bi_current_context(interp_state_t *state) 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) static void bi_call_with_context(interp_state_t *state)
{ {
state->ctx.value = CAR(state->argv.value); 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->argv.value = NIL;
state->kw_args.value = NIL; state->kw_args.value = NIL;
state->kw_vals.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) static void bi_float_to_string(interp_state_t *state)
{ {
char buffer[32]; 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); 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: */ /* vim:set sw=2 expandtab: */

2
builtin.h
View File

@ -30,6 +30,8 @@
#define BI_CALL_WITH_CONTEXT "call-with-context" #define BI_CALL_WITH_CONTEXT "call-with-context"
#define BI_EXIT "exit" #define BI_EXIT "exit"
#define BI_FLOAT_TO_STRING "float->string" #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. */ /* Lambda: Instances of this structure are fundamental callable objects. */
#define LAMBDA_SLOT_GLOBAL_VARS 0 #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) 29 (byte-string-size in)
2a (struct-nslots in) 2a (struct-nslots in)
2b (struct-type in) 2b (struct-type in)
2c (hash-value in) 2c (object-id in)
; ISO C floating-point ; ISO C floating-point
30 (acos in) 30 (acos in)

1875
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 <stdio.h>
#include <time.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. */ ** Macro Definitions
#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 ** 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; #define FIXNUM_MIN (INT32_MIN/2)
typedef intptr_t fixnum_t; #define FIXNUM_MAX (INT32_MAX/2)
typedef double native_float_t;
#if INTPTR_MAX - 0 == 0 #define OBJECT_BLOCK_MAX 0x3ff
/* The INTPTR_ macros are defined, but not given values. */ #define OBJECT_INDEX_MAX 0x1ffff
# undef INTPTR_MIN #define OBJECT_TAG_MAX 0xf
# 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 OBJECT_TAG_FIXNUM -1
#define FIXNUM_MAX (INTPTR_MAX/2) #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. #define OBJECT(blk, idx, tag) \
* The argv, k, and ctx inputs can be found in the state fields, and should be ((((value_t)(blk) & 0x3ff) << 22) | \
* updated as necessary (particularly argv) before the builtin returns. The (((value_t)(idx) & 0x1ffff) << 5) | \
* 'lambda' field will refer to the builtin itself, and in1-in3 are all free. */ (((value_t)(tag) & 0xf) << 1))
struct interp_state;
typedef void (builtin_fn_t)(struct interp_state *state);
/* NIL: 00000000 00000000 00000000 00000000 */ #define OBJECT_BLOCK(value) ((int)(((value) >> 22) & 0x3ff))
/* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa00 (where aa... >= 1024) */ #define OBJECT_INDEX(value) ((int)(((value) >> 5) & 0x1ffff))
/* Pair: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa10 */ #define OBJECT_TAG(value) ((int)(((value) >> 1) & 0xf))
/* Fixnum: snnnnnnn nnnnnnnn nnnnnnnn nnnnnnn1 */
#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) */ #define UNDEFINED SPECIAL_VALUE(0)
/* These correspond to objects within the first page of memory */ #define NIL SPECIAL_VALUE(1)
#define SPECIAL_VALUE(n) ((value_t)(4*(n)+4)) #define FALSE_VALUE SPECIAL_VALUE(2)
#define TYPE_TAG(n) SPECIAL_VALUE(768+(n)) #define TRUE_VALUE SPECIAL_VALUE(3)
#define MAX_SPECIAL SPECIAL_VALUE(1023) #define END_PROGRAM SPECIAL_VALUE(4)
#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 CAR(x) (get_pair(x)->car)
#define CDR(x) (get_pair(x)->cdr) #define CDR(x) (get_pair(x)->cdr)
#define CADR(x) CAR(CDR(x)) #define CADR(x) CAR(CDR(x))
#define CDDR(x) CDR(CDR(x)) #define CDDR(x) CDR(CDR(x))
#define _CAR(x) (_get_pair(x)->car) /* Ex: SLOT_VALUE(STRUCTURE, v, NAME) */
#define _CDR(x) (_get_pair(x)->cdr) #define SLOT_VALUE(t,v,s) (get_struct(v)->slots[t ## _SLOT_ ## s])
#define _CADR(x) _CAR(_CDR(x)) #define _SLOT_VALUE(t,v,s) SLOT_VALUE(t,v,s)
#define _CDDR(x) _CDR(_CDR(x))
/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */ #define STRUCTURE_SLOT_SUPER 0
#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_NSLOTS 1
#define STRUCTURE_SLOT_CALLABLE 2 #define STRUCTURE_SLOT_CALLABLE 2
#define STRUCTURE_SLOTS 3 #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. */ /* 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. */ /* Failing to invoke the macro before the next GC pass can lead to incorrect behavior. */
#define WRITE_BARRIER(value) ((void)_gc_write_barrier((value))) #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 value;
value_t forward; /* only if tag == BROKEN_HEART */ } box_t;
} object_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 typedef struct pair
{ {
value_t car; value_t car;
value_t cdr; value_t cdr;
} pair_t; } pair_t;
typedef struct box
{
value_t tag; /* TYPE_TAG_BOX */
value_t value;
} box_t;
typedef struct vector 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]; value_t elements[0];
} vector_t; } vector_t;
typedef struct byte_string typedef struct byte_string
{ {
value_t tag; /* TYPE_TAG_BYTESTR */
size_t size;
bool immutable; bool immutable;
size_t nbytes;
uint8_t bytes[0]; uint8_t bytes[0];
} byte_string_t; } byte_string_t;
/* Equivalent to vector_t */
typedef struct structure typedef struct structure
{ {
value_t tag; /* TYPE_TAG_STRUCT */
value_t type;
size_t nslots;
value_t hash;
bool immutable; bool immutable;
size_t nslots;
value_t type;
value_t slots[0]; value_t slots[0];
} struct_t; } struct_t;
typedef struct weak_box
{
value_t tag;
value_t value;
value_t next;
} weak_box_t;
typedef struct will typedef struct will
{ {
value_t tag;
value_t value; value_t value;
value_t finalizer; value_t finalizer;
value_t next; value_t next;
} will_t; } will_t;
typedef struct float_object typedef union object
{ {
value_t tag; /* free list */
native_float_t value; value_t next;
} float_object_t;
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; object_t *objects;
builtin_fn_t *fn; uint8_t *flag_bits;
} builtin_fn_object_t; } object_block_t;
typedef struct gc_root typedef struct gc_root
{ {
@ -181,62 +200,69 @@ typedef unsigned long long llsize_t;
typedef struct gc_stats typedef struct gc_stats
{ {
struct {
int passes; int passes;
nsec_t total_ns; nsec_t total_ns;
nsec_t max_ns; nsec_t peak_ns;
nsec_t max_gen1_ns;
llsize_t total_freed; llsize_t total_freed;
} gen[2]; llsize_t peak_allocated;
llsize_t gen1_high_water;
} gc_stats_t; } 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; 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); static inline value_t make_boolean(bool value);
value_t cons(value_t car, value_t cdr); 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); value_t make_box(value_t initial_value);
box_t *get_box(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 elements, value_t default_value); value_t make_vector(size_t nelements, value_t init);
vector_t *get_vector(value_t v); value_t make_byte_string(size_t nbytes, int init);
value_t make_struct(value_t type);
value_t make_byte_string(size_t size, int default_value); /* wills are deliberately omitted from the public interface */
byte_string_t *get_byte_string(value_t v);
/* Returns a byte string w/ bytes from 's' (excl. terminating NUL). */ /* Returns a byte string w/ bytes from 's' (excl. terminating NUL). */
value_t string_to_value(const char *s); 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); char *value_to_string(value_t v);
/* Like strcmp(), but for byte strings. */ /* Like strcmp(), but for byte strings. */
int byte_strcmp(value_t s1, value_t s2); int byte_strcmp(value_t s1, value_t s2);
value_t get_hash_value(value_t val); /* Return the structure instance at the root of the structure type hierarchy. */
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);
value_t get_structure_type(void); value_t get_structure_type(void);
/* Instantiates a structure type. Result is immutable. */ /* 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'. */ /* True if 'value' is (1) a structure, and (2) an instance of 'type'. */
bool struct_is_a(value_t value, value_t 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. */ /* Finalizers are register-and-forget; there should be no external references to wills. */
void register_finalizer(value_t value, value_t finalizer); void register_finalizer(value_t value, value_t finalizer);
bool are_finalizers_pending(void); bool are_finalizers_pending(void);
@ -244,13 +270,31 @@ bool are_finalizers_pending(void);
/* If *value == #f on return there are no more finalizers. */ /* If *value == #f on return there are no more finalizers. */
void get_next_finalizer(value_t *value, value_t *finalizer); void get_next_finalizer(value_t *value, value_t *finalizer);
value_t make_float(native_float_t value); void register_gc_root(gc_root_t *root, value_t v);
native_float_t get_float(value_t v); void unregister_gc_root(gc_root_t *root);
value_t make_builtin_fn(builtin_fn_t *fn); void gc_init(void);
builtin_fn_t *get_builtin_fn(value_t v); 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) static inline bool is_nil(value_t v)
{ {
@ -262,169 +306,174 @@ static inline bool is_undefined(value_t v)
return v == UNDEFINED; 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) static inline bool is_boolean(value_t v)
{ {
return (v == FALSE_VALUE) || (v == TRUE_VALUE); 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; 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); return &_get_typed_object(value, OBJECT_TAG_WEAK_BOX)->weak_box;
assert(((uintptr_t)obj & 3) == 0);
return (value_t)obj;
} }
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 &_get_typed_object(value, OBJECT_TAG_PAIR)->pair;
return ((v & 0x1) == 0) && (v > MAX_SPECIAL);
} }
/* Pairs are a type of object, but the value representation is different */ static inline fpnum_t get_float(value_t value)
static inline object_t *_get_object(value_t v)
{ {
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); return _get_typed_object(value, OBJECT_TAG_BUILTIN_FN)->builtin_fn;
assert(((uintptr_t)p & 3) == 0);
return (value_t)p + 2;
} }
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) static inline void print_value(value_t v)
{ {
fprint_value(stdout, v); fprint_value(stdout, v);
@ -435,33 +484,5 @@ static inline void print_gc_stats(void)
fprint_gc_stats(stderr); 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 #endif
/* vim:set sw=2 expandtab: */ /* 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 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 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 value_t make_lambda(interp_state_t *state, value_t templ);
static void translate_callable(interp_state_t *state); 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)) if (is_builtin_fn(state.lambda.value))
{ {
/* Builtin functions replace the byte-code and tail-call steps. */ /* 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 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. */ /* Clear (used) transient slots so they can be GC'd. */
for (int i = 0; i < state.ntransients; ++i) 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. */ /* Clear temporaries. */
state.globals.value = UNDEFINED; 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. */ /* Note that recursion is limited to a single level by the static variable. */
run_finalizers = false; run_finalizers = false;
run_interpreter(f_root.value, cons(v, NIL)); run_interpreter(f_root.value, make_pair(v, NIL));
run_finalizers = true; run_finalizers = true;
unregister_gc_root(&f_root); 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) static value_t vector_ref(value_t v, fixnum_t idx)
{ {
vector_t *vec = get_vector(v); vector_t *vec = get_vector(v);
if (!((idx >= 0) && (idx < vec->size))) if (!((idx >= 0) && (idx < vec->nelements)))
fprintf(stderr, "idx=%d, vec->size=%d\n", (int)idx, (int)vec->size); fprintf(stderr, "idx=%d, vec->nelements=%d\n", (int)idx, (int)vec->nelements);
release_assert((idx >= 0) && (idx < vec->size)); release_assert((idx >= 0) && (idx < vec->nelements));
return vec->elements[idx]; return vec->elements[idx];
} }
static uint8_t byte_string_ref(value_t v, fixnum_t idx) static uint8_t byte_string_ref(value_t v, fixnum_t idx)
{ {
byte_string_t *str = get_byte_string(v); 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]; 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); vector_t *vec = get_vector(v);
release_assert(!vec->immutable); release_assert(!vec->immutable);
release_assert((idx >= 0) && (idx < vec->size)); release_assert((idx >= 0) && (idx < vec->nelements));
vec->elements[idx] = newval; vec->elements[idx] = newval;
WRITE_BARRIER(v); 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); byte_string_t *str = get_byte_string(v);
release_assert(!str->immutable); release_assert(!str->immutable);
release_assert((idx >= 0) && (idx < str->size)); release_assert((idx >= 0) && (idx < str->nbytes));
str->bytes[idx] = newval; str->bytes[idx] = newval;
} }
@ -199,16 +197,6 @@ static void struct_set(value_t v, fixnum_t idx, value_t newval)
WRITE_BARRIER(v); 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) static value_t make_lambda(interp_state_t *state, value_t templ)
{ {
gc_root_t templ_root, lambda_root; 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. */ /* Need to do this first, since it can call the garbage collector. */
temp = make_vector(get_byte_string(get_struct(templ_root.value) temp = make_vector(get_byte_string(get_struct(templ_root.value)
->slots[TEMPLATE_SLOT_INSTANCE_VARS])->size, ->slots[TEMPLATE_SLOT_INSTANCE_VARS])->nbytes,
UNDEFINED); UNDEFINED);
_LAMBDA_SLOT(lambda_root.value, INSTANCE_VARS) = temp; _LAMBDA_SLOT(lambda_root.value, INSTANCE_VARS) = temp;
WRITE_BARRIER(lambda_root.value); WRITE_BARRIER(lambda_root.value);
ls = _get_struct(lambda_root.value); ls = get_struct(lambda_root.value);
ts = _get_struct(templ_root.value); ts = get_struct(templ_root.value);
/* All but the instance variables are just shallow-copied. */ /* All but the instance variables are just shallow-copied. */
ls->slots[LAMBDA_SLOT_GLOBAL_VARS] = ts->slots[TEMPLATE_SLOT_GLOBAL_VARS]; 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; ls->immutable = true;
WRITE_BARRIER(lambda_root.value); 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]); 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]); 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())) !struct_is_a(state->lambda.value, get_lambda_type()))
{ {
/* Prepend structure instance to argument list, per proxy protocol. */ /* 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! */ /* Follow link to next callable. Must be a structure! */
state->lambda.value = _SLOT_VALUE(STRUCTURE, get_struct(state->lambda.value)->type, CALLABLE); 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); byte_string_t *s = get_byte_string(state->byte_code.value);
release_assert(s->immutable); release_assert(s->immutable);
release_assert(s->size <= sizeof byte_code); release_assert(s->nbytes <= sizeof byte_code);
release_assert((s->size % 4) == 0); release_assert((s->nbytes % 4) == 0);
/* Copy byte code to temporary buffer for faster access. */ /* Copy byte code to temporary buffer for faster access. */
nwords = s->size / 4; nwords = s->nbytes / 4;
memcpy(byte_code, s->bytes, s->size); memcpy(byte_code, s->bytes, s->nbytes);
} }
for (int word = 0; word < nwords; ++word) 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) */ if (bytes[0] == 0x00 && bytes[1] == 0x70) /* (tail-call-if cond tail-call) */
{ {
/* Must handle this here, as it may end the loop. */ /* 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]); value_t tc = get_input(state, bytes[3]);
if (tc != FALSE_VALUE) state->tail_call.value = tc; if (tc != FALSE_VALUE) state->tail_call.value = tc;
@ -320,7 +308,7 @@ static void run_byte_code(interp_state_t *state)
fflush(stderr); fflush(stderr);
#endif #endif
_get_vector(state->transients.value)->elements[state->ntransients++] = result; get_vector(state->transients.value)->elements[state->ntransients++] = result;
WRITE_BARRIER(state->transients.value); 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) switch (code)
{ {
case 0x10: case 0x10:
return _get_boolean(v1) ? v2 : v3; return get_boolean(v1) ? v2 : v3;
case 0x20: case 0x20:
vector_set(v1, get_fixnum(v2), v3); vector_set(v1, get_fixnum(v2), v3);
return UNDEFINED; 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; 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)->immutable);
release_assert(_get_byte_string(state->tail_call.value)->size == 6); release_assert(get_byte_string(state->tail_call.value)->nbytes == 6);
memcpy(bytes, _get_byte_string(state->tail_call.value)->bytes, 6); memcpy(bytes, get_byte_string(state->tail_call.value)->bytes, 6);
register_gc_root(&root, make_lambda(state, get_input(state, bytes[0]))); register_gc_root(&root, make_lambda(state, get_input(state, bytes[0])));
new_k = make_lambda(state, get_input(state, bytes[5])); 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) switch (code)
{ {
case 0x01: return boolean_value(v1 == v2); case 0x01: return make_boolean(v1 == v2);
case 0x02: return cons(v1, v2); case 0x02: return make_pair(v1, v2);
case 0x03: return make_vector(get_fixnum(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 0x04: return make_byte_string(get_fixnum(v1), (char)get_fixnum(v2));
case 0x05: return vector_ref(v1, 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 0x07: return struct_ref(v1, get_fixnum(v2));
case 0x08: return fixnum_value(get_fixnum(v1) + get_fixnum(v2)); case 0x08: return make_fixnum(get_fixnum(v1) + get_fixnum(v2));
case 0x09: return fixnum_value(get_fixnum(v1) - get_fixnum(v2)); case 0x09: return make_fixnum(get_fixnum(v1) - get_fixnum(v2));
case 0x0a: return fixnum_value(get_fixnum(v1) * get_fixnum(v2)); case 0x0a: return make_fixnum(get_fixnum(v1) * get_fixnum(v2));
case 0x0b: return fixnum_value(get_fixnum(v1) / get_fixnum(v2)); case 0x0b: return make_fixnum(get_fixnum(v1) / get_fixnum(v2));
case 0x0c: return fixnum_value(get_fixnum(v1) % get_fixnum(v2)); case 0x0c: return make_fixnum(get_fixnum(v1) % get_fixnum(v2));
case 0x0d: return boolean_value(get_fixnum(v1) < get_fixnum(v2)); case 0x0d: return make_boolean(get_fixnum(v1) < get_fixnum(v2));
case 0x0e: return boolean_value(get_fixnum(v1) >= get_fixnum(v2)); case 0x0e: return make_boolean(get_fixnum(v1) >= get_fixnum(v2));
case 0x10: return fixnum_value(get_fixnum(v1) & get_fixnum(v2)); case 0x10: return make_fixnum(get_fixnum(v1) & get_fixnum(v2));
case 0x11: return fixnum_value(get_fixnum(v1) | get_fixnum(v2)); case 0x11: return make_fixnum(get_fixnum(v1) | get_fixnum(v2));
case 0x12: return fixnum_value(get_fixnum(v1) ^ get_fixnum(v2)); case 0x12: return make_fixnum(get_fixnum(v1) ^ get_fixnum(v2));
case 0x14: return fixnum_value(get_fixnum(v1) << get_fixnum(v2)); case 0x14: return make_fixnum(get_fixnum(v1) << get_fixnum(v2));
case 0x15: return fixnum_value(get_fixnum(v1) >> get_fixnum(v2)); case 0x15: return make_fixnum(get_fixnum(v1) >> get_fixnum(v2));
case 0x16: return fixnum_value((unsigned long)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 0x18: return make_float(get_float(v1) + get_float(v2));
case 0x19: 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 0x1a: return make_float(get_float(v1) * get_float(v2));
case 0x1b: 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 0x1c: return make_boolean(get_float(v1) == get_float(v2));
case 0x1d: return boolean_value(get_float(v1) < get_float(v2)); case 0x1d: return make_boolean(get_float(v1) < get_float(v2));
case 0x1e: return boolean_value(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 0x20: return make_float(atan2(get_float(v1), get_float(v2)));
case 0x21: return make_float(pow(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))); 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 0x27: return make_float(nextafter(get_float(v1), get_float(v2)));
case 0x28: return make_float(remainder(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 0x29: return make_float(scalb(get_float(v1), get_float(v2)));
case 0x30: return boolean_value(struct_is_a(v1, v2)); case 0x30: return make_boolean(struct_is_a(v1, v2));
case 0x31: return boolean_value(byte_string_cmp(v1, v2) == 0); case 0x31: return make_boolean(byte_strcmp(v1, v2) == 0);
case 0x32: return boolean_value(byte_string_cmp(v1, v2) < 0); case 0x32: return make_boolean(byte_strcmp(v1, v2) < 0);
case 0x33: return boolean_value(byte_string_cmp(v1, v2) >= 0); case 0x33: return make_boolean(byte_strcmp(v1, v2) >= 0);
case 0x50: case 0x50:
get_box(v1)->value = v2; 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; return UNDEFINED;
case 0xff: case 0xff:
if (_get_boolean(v1)) if (get_boolean(v1))
{ {
if (_get_boolean(v2)) if (get_boolean(v2))
{ {
fprint_value(stderr, v2); fprint_value(stderr, v2);
fputc('\n', stderr); 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 0x03: return get_pair(v1)->car;
case 0x04: return get_pair(v1)->cdr; case 0x04: return get_pair(v1)->cdr;
case 0x08: return boolean_value(is_boolean(v1)); case 0x08: return make_boolean(is_boolean(v1));
case 0x09: return boolean_value(is_fixnum(v1)); case 0x09: return make_boolean(is_fixnum(v1));
case 0x0a: return boolean_value(is_box(v1)); case 0x0a: return make_boolean(is_box(v1));
case 0x0b: return boolean_value(is_pair(v1)); case 0x0b: return make_boolean(is_pair(v1));
case 0x0c: return boolean_value(is_vector(v1)); case 0x0c: return make_boolean(is_vector(v1));
case 0x0d: return boolean_value(is_byte_string(v1)); case 0x0d: return make_boolean(is_byte_string(v1));
case 0x0e: return boolean_value(is_struct(v1)); case 0x0e: return make_boolean(is_struct(v1));
case 0x0f: return boolean_value(is_float(v1)); case 0x0f: return make_boolean(is_float(v1));
case 0x10: return boolean_value(is_builtin_fn(v1)); case 0x10: return make_boolean(is_builtin_fn(v1));
case 0x11: return boolean_value(is_weak_box(v1)); case 0x11: return make_boolean(is_weak_box(v1));
case 0x18: return make_box(v1); case 0x18: return make_box(v1);
case 0x19: return make_struct(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 0x1b: return make_lambda(state, v1);
case 0x1c: return make_weak_box(v1); case 0x1c: return make_weak_box(v1);
case 0x20: return boolean_value(!_get_boolean(v1)); case 0x20: return make_boolean(!get_boolean(v1));
case 0x21: return fixnum_value(~get_fixnum(v1)); case 0x21: return make_fixnum(~get_fixnum(v1));
case 0x22: return fixnum_value(-get_fixnum(v1)); case 0x22: return make_fixnum(-get_fixnum(v1));
case 0x23: return make_float(-get_float(v1)); case 0x23: return make_float(-get_float(v1));
case 0x28: return fixnum_value(get_vector(v1)->size); case 0x28: return make_fixnum(get_vector(v1)->nelements);
case 0x29: return fixnum_value(get_byte_string(v1)->size); case 0x29: return make_fixnum(get_byte_string(v1)->nbytes);
case 0x2a: return fixnum_value(get_struct(v1)->nslots); case 0x2a: return make_fixnum(get_struct(v1)->nslots);
case 0x2b: return get_struct(v1)->type; 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 0x30: return make_float(acos(get_float(v1)));
case 0x31: return make_float(asin(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: { case 0x3a: {
int exp; int exp;
value_t v2 = make_float(frexp(get_float(v1), &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 0x3b: return make_float(log(get_float(v1)));
case 0x3c: return make_float(log10(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); v3 = make_float(integral_part);
unregister_gc_root(&rv2); 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 0x3e: return make_float(sqrt(get_float(v1)));
case 0x3f: return make_float(ceil(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: { case 0x54: {
int signgamp; int signgamp;
value_t v2 = make_float(lgamma_r(get_float(v1), &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 0x55: return make_float(y0(get_float(v1)));
case 0x56: return make_float(y1(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 0x5c: return make_float(expm1(get_float(v1)));
case 0x5d: return make_float(ilogb(get_float(v1))); case 0x5d: return make_float(ilogb(get_float(v1)));
case 0x5e: return make_float(log1p(get_float(v1))); case 0x5e: return make_float(log1p(get_float(v1)));
case 0x70: return boolean_value(isnormal(get_float(v1))); case 0x70: return make_boolean(isnormal(get_float(v1)));
case 0x71: return boolean_value(isfinite(get_float(v1))); case 0x71: return make_boolean(isfinite(get_float(v1)));
case 0x72: return boolean_value(fpclassify(get_float(v1)) == FP_SUBNORMAL); case 0x72: return make_boolean(fpclassify(get_float(v1)) == FP_SUBNORMAL);
case 0x73: return boolean_value(isinf(get_float(v1))); case 0x73: return make_boolean(isinf(get_float(v1)));
case 0x74: return boolean_value(isnan(get_float(v1))); case 0x74: return make_boolean(isnan(get_float(v1)));
default: default:
release_assert(NOTREACHED("Invalid unary bytecode.")); 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: case 0x00 ... 0x7f:
{ {
vector_t *vec = _get_vector(state->transients.value); vector_t *vec = get_vector(state->transients.value);
release_assert(var < state->ntransients); release_assert(var < state->ntransients);
return vec->elements[var]; return vec->elements[var];
} }
case 0x80 ... 0xbf: case 0x80 ... 0xbf:
{ {
vector_t *vec = _get_vector(state->globals.value); vector_t *vec = get_vector(state->globals.value);
var -= 0x80; var -= 0x80;
release_assert(var < vec->size); release_assert(var < vec->nelements);
return vec->elements[var]; return vec->elements[var];
} }
case 0xc0 ... 0xef: case 0xc0 ... 0xef:
{ {
vector_t *vec = _get_vector(state->instances.value); vector_t *vec = get_vector(state->instances.value);
var -= 0xc0; var -= 0xc0;
release_assert(var < vec->size); release_assert(var < vec->nelements);
return vec->elements[var]; return vec->elements[var];
} }
case 0xf0: return FALSE_VALUE; case 0xf0: return FALSE_VALUE;

2
libcompiler/primitives.scm
View File

@ -43,7 +43,7 @@
(#%byte-string-size #x29 byte-string-size) (#%byte-string-size #x29 byte-string-size)
(#%struct-nslots #x2a struct-nslots) (#%struct-nslots #x2a struct-nslots)
(#%struct-type #x2b struct-type) (#%struct-type #x2b struct-type)
(#%hash-value #x2c hash-value) (#%object-id #x2c object-id)
(#%acos #x30 acos) (#%acos #x30 acos)
(#%asin #x31 asin) (#%asin #x31 asin)
(#%atan #x32 atan) (#%atan #x32 atan)

2
libcompiler/writer.scm
View File

@ -17,7 +17,7 @@
(define next-object-number (make-parameter #f)) (define next-object-number (make-parameter #f))
(define symbol-structs (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))) (define (write-rla-value value (port (current-output-port)))
(void (parameterize ([current-output-port 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 fd;
int saved_errno; 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)); 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 else
{ {
@ -91,7 +91,7 @@ static void bi_posix_dup(interp_state_t *state)
int newfd; int newfd;
int saved_errno; int saved_errno;
release_assert(is_nil(_CDR(state->argv.value))); release_assert(is_nil(CDR(state->argv.value)));
errno = 0; errno = 0;
newfd = dup(oldfd); 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) static void bi_posix_dup2(interp_state_t *state)
{ {
int oldfd = get_fixnum(CAR(state->argv.value)); 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; int saved_errno;
release_assert(is_nil(_CDDR(state->argv.value))); release_assert(is_nil(CDDR(state->argv.value)));
errno = 0; errno = 0;
newfd = dup2(oldfd, newfd); 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) static void bi_posix_read(interp_state_t *state)
{ {
int fd = get_fixnum(CAR(state->argv.value)); 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 = get_fixnum(CAR(_CDDR(state->argv.value))); fixnum_t count = get_fixnum(CAR(CDDR(state->argv.value)));
ssize_t result; ssize_t result;
int saved_errno; int saved_errno;
release_assert(is_byte_string(str)); release_assert(is_byte_string(str));
release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); release_assert(is_nil(CDR(CDDR(state->argv.value))));
release_assert((0 <= count) && (count <= _get_byte_string(str)->size)); release_assert((0 <= count) && (count <= get_byte_string(str)->nbytes));
errno = 0; errno = 0;
result = read(fd, _get_byte_string(str)->bytes, count); result = read(fd, get_byte_string(str)->bytes, count);
saved_errno = errno; saved_errno = errno;
release_assert(is_valid_fixnum(result)); 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) static void bi_posix_write(interp_state_t *state)
{ {
int fd = get_fixnum(CAR(state->argv.value)); 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; fixnum_t count;
ssize_t result; ssize_t result;
int saved_errno; int saved_errno;
release_assert(is_byte_string(str)); 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))); count = get_fixnum(CAR(CDDR(state->argv.value)));
release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); release_assert(is_nil(CDR(CDDR(state->argv.value))));
} }
else 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; errno = 0;
result = write(fd, _get_byte_string(str)->bytes, count); result = write(fd, get_byte_string(str)->bytes, count);
saved_errno = errno; saved_errno = errno;
release_assert(is_valid_fixnum(result)); 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) static void bi_posix_lseek(interp_state_t *state)
{ {
int fd = get_fixnum(CAR(state->argv.value)); int fd = get_fixnum(CAR(state->argv.value));
fixnum_t off = get_fixnum(CAR(_CDR(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 whence = get_fixnum(CAR(CDDR(state->argv.value)));
off_t result; off_t result;
int saved_errno; int saved_errno;
release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); release_assert(is_nil(CDR(CDDR(state->argv.value))));
errno = 0; errno = 0;
result = lseek(fd, off, whence); result = lseek(fd, off, whence);
@ -224,7 +224,7 @@ static void bi_posix_close(interp_state_t *state)
ssize_t result; ssize_t result;
int saved_errno; int saved_errno;
release_assert(is_nil(_CDR(state->argv.value))); release_assert(is_nil(CDR(state->argv.value)));
errno = 0; errno = 0;
result = close(fd); 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) void reader_init(void)
{ {
register_gc_root(&reference_root, make_struct_type(NIL, REFERENCE_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(NIL, STRUCT_PH_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(NIL, IMMUTABLE_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) 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)) while (is_pair(lst))
{ {
value_t temp = _get_pair(lst)->cdr; value_t temp = get_pair(lst)->cdr;
_get_pair(lst)->cdr = newcdr; get_pair(lst)->cdr = newcdr;
WRITE_BARRIER(lst); WRITE_BARRIER(lst);
newcdr = lst; newcdr = lst;
lst = temp; lst = temp;
@ -318,7 +318,7 @@ static value_t read_list(reader_state_t *state)
default: default:
{ {
value_t temp = read_one_value(state); 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; break;
} }
@ -415,14 +415,14 @@ static value_t read_fixnum(reader_state_t *state, int radix)
num = -num; num = -num;
release_assert((FIXNUM_MIN <= num) && (num <= FIXNUM_MAX)); 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) static value_t read_number(reader_state_t *state)
{ {
bool negative = false; bool negative = false;
fixnum_t num = 0; fixnum_t num = 0;
native_float_t flt; fpnum_t flt;
int radix; int radix;
if (state->ch == '-') if (state->ch == '-')
@ -493,7 +493,7 @@ static value_t read_number(reader_state_t *state)
num = -num; num = -num;
release_assert(!issymbol(state->ch)); release_assert(!issymbol(state->ch));
release_assert((FIXNUM_MIN <= num) && (num <= FIXNUM_MAX)); 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); 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; flt += (state->ch - '0') * pv;
next_char(state); next_char(state);
@ -517,7 +517,7 @@ static value_t read_number(reader_state_t *state)
{ {
next_char(state); next_char(state);
num = read_fixnum(state, 10); num = read_fixnum(state, 10);
flt *= pow(10, _get_fixnum(num)); flt *= pow(10, get_fixnum(num));
} }
if (negative) if (negative)
@ -664,7 +664,7 @@ static value_t read_string(reader_state_t *state)
next_char(state); next_char(state);
value = make_byte_string(length, '\0'); value = make_byte_string(length, '\0');
memcpy(_get_byte_string(value)->bytes, buffer, length); memcpy(get_byte_string(value)->bytes, buffer, length);
free(buffer); free(buffer);
return value; return value;
@ -709,9 +709,9 @@ static value_t read_vector(reader_state_t *state)
item = list_root.value; item = list_root.value;
for (size_t i = 0; i < length; ++i) 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. */ /* No write barrier needed here. */
item = _CDR(item); item = CDR(item);
} }
unregister_gc_root(&list_root); 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); register_gc_root(&value_root, NIL);
value_root.value = read_one_value(state); 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); unregister_gc_root(&value_root);
return make_weak_box(value_root.value); return make_weak_box(value_root.value);
@ -806,15 +806,15 @@ static value_t freeze(value_t val)
{ {
if (is_vector(val)) if (is_vector(val))
{ {
_get_vector(val)->immutable = true; get_vector(val)->immutable = true;
} }
else if (is_byte_string(val)) else if (is_byte_string(val))
{ {
_get_byte_string(val)->immutable = true; get_byte_string(val)->immutable = true;
} }
else if (is_struct(val)) else if (is_struct(val))
{ {
_get_struct(val)->immutable = true; get_struct(val)->immutable = true;
} }
else 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) 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) if (REF_IDENT(CAR(item)) == refidval)
return _CAR(item); return CAR(item);
} }
/* No existing reference with that number; create a new one. */ /* 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_IDENT(ref) = refidval;
REF_VALUE(ref) = UNDEFINED; REF_VALUE(ref) = UNDEFINED;
REF_PATCHED(ref) = FALSE_VALUE; 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) 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; changed = false;
/* Resolve one level of placeholder-to-placeholder links. */ /* 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) if (REF_VALUE(ref) == ref)
{ {
/* Self-links indicate cycles. */ /* 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 (struct_is_a(in, reference_root.value))
{ {
if (!_get_boolean(REF_PATCHED(in))) if (!get_boolean(REF_PATCHED(in)))
{ {
value_t val; 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)) 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); 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); values = STRUCT_PH_VALUES(in_root.value);
in_root.value = sval; 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; if (is_nil(values)) break;
_get_struct(in_root.value)->slots[i] = CAR(values); get_struct(in_root.value)->slots[i] = CAR(values);
values = _CDR(values); values = CDR(values);
} }
WRITE_BARRIER(in_root.value); 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); value_t val = _patch_placeholders(state, get_struct(in_root.value)->slots[i], &this_seen);
_get_struct(in_root.value)->slots[i] = val; get_struct(in_root.value)->slots[i] = val;
WRITE_BARRIER(in_root.value); WRITE_BARRIER(in_root.value);
} }
} }
} }
else if (is_box(in_root.value)) else if (is_box(in_root.value))
{ {
value_t val = _patch_placeholders(state, _get_box(in_root.value)->value, &this_seen); value_t val = _patch_placeholders(state, get_box(in_root.value)->value, &this_seen);
_get_box(in_root.value)->value = val; get_box(in_root.value)->value = val;
WRITE_BARRIER(in_root.value); WRITE_BARRIER(in_root.value);
} }
else if (is_weak_box(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); value_t val = _patch_placeholders(state, get_weak_box(in_root.value)->value, &this_seen);
_get_weak_box(in_root.value)->value = val; get_weak_box(in_root.value)->value = val;
WRITE_BARRIER(in_root.value); WRITE_BARRIER(in_root.value);
} }
else if (is_pair(in_root.value)) else if (is_pair(in_root.value))
{ {
value_t val; value_t val;
val = _patch_placeholders(state, _CAR(in_root.value), &this_seen); val = _patch_placeholders(state, CAR(in_root.value), &this_seen);
_CAR(in_root.value) = val; CAR(in_root.value) = val;
WRITE_BARRIER(in_root.value); WRITE_BARRIER(in_root.value);
val = _patch_placeholders(state, _CDR(in_root.value), &this_seen); val = _patch_placeholders(state, CDR(in_root.value), &this_seen);
_CDR(in_root.value) = val; CDR(in_root.value) = val;
WRITE_BARRIER(in_root.value); WRITE_BARRIER(in_root.value);
} }
else if (is_vector(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) for (size_t i = 0; i < nelem; ++i)
{ {
value_t val = _patch_placeholders(state, _get_vector(in_root.value)->elements[i], &this_seen); value_t val = _patch_placeholders(state, get_vector(in_root.value)->elements[i], &this_seen);
_get_vector(in_root.value)->elements[i] = val; get_vector(in_root.value)->elements[i] = val;
WRITE_BARRIER(in_root.value); WRITE_BARRIER(in_root.value);
} }
} }

36
rosella.c
View File

@ -47,7 +47,7 @@ int main(int argc, char **argv)
} }
#endif #endif
gc_init(8*1024*1024, 4*1024*1024, 64*1024*1024); gc_init();
builtin_init(); builtin_init();
interpreter_init(); interpreter_init();
#ifdef HAVE_MOD_IO #ifdef HAVE_MOD_IO
@ -82,7 +82,7 @@ int main(int argc, char **argv)
for (int i = argc - 1; i >= 2; --i) for (int i = argc - 1; i >= 2; --i)
{ {
value_t temp = string_to_value(argv[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) if (argc >= 2)
@ -95,14 +95,14 @@ int main(int argc, char **argv)
fflush(stdin); fflush(stdin);
} }
collect_garbage(4*1024*1024); collect_garbage();
unregister_gc_root(&argv_root); unregister_gc_root(&argv_root);
unregister_gc_root(&program_root); unregister_gc_root(&program_root);
results = run_interpreter(program_root.value, argv_root.value); 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)); print_value(CAR(result));
nl(); nl();
@ -145,22 +145,22 @@ static void test_weak_boxes_and_wills(void)
register_gc_root(&box_root, UNDEFINED); register_gc_root(&box_root, UNDEFINED);
register_gc_root(&tmp_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); 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); print_weak_box_results(box_root.value);
collect_garbage(0); collect_garbage();
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
tmp_root.value = UNDEFINED; tmp_root.value = UNDEFINED;
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
collect_garbage(0); collect_garbage();
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
collect_garbage(0); collect_garbage();
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
nl(); nl();
@ -180,7 +180,7 @@ static void test_garbage_collection(bool keep_going)
/* Construct a large, static tree w/ many links. */ /* Construct a large, static tree w/ many links. */
for (int i = 0; i < 1000000; ++i) for (int i = 0; i < 1000000; ++i)
{ {
root2.value = cons(root2.value, root2.value); root2.value = make_pair(root2.value, root2.value);
} }
while (1) while (1)
@ -189,35 +189,35 @@ static void test_garbage_collection(bool keep_going)
if (r == 0) if (r == 0)
{ {
root.value = fixnum_value(rand()); root.value = make_fixnum(rand());
} }
else else
{ {
switch (r & 15) switch (r & 15)
{ {
case 0: case 0:
root.value = cons(fixnum_value(rand()), root.value); root.value = make_pair(make_fixnum(rand()), root.value);
break; break;
case 1: case 1:
root.value = cons(root.value, make_byte_string(256, '\0')); root.value = make_pair(root.value, make_byte_string(256, '\0'));
break; break;
case 2: case 2:
root.value = make_box(root.value); root.value = make_box(root.value);
break; break;
case 3: case 3:
root.value = cons(root.value, cons(fixnum_value(-1), NIL)); root.value = make_pair(root.value, make_pair(make_fixnum(-1), NIL));
_CDDR(root.value) = root.value; CDDR(root.value) = root.value;
WRITE_BARRIER(_CDR(root.value)); WRITE_BARRIER(CDR(root.value));
break; break;
case 4: case 4:
{ {
value_t s = make_vector(4, FALSE_VALUE); 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; root.value = s;
} }
break; break;
default: 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; break;
} }
} }

7
src/compiler.rls
View File

@ -17,7 +17,7 @@
(load "lib/reader.rls") (load "lib/reader.rls")
(load "lib/writer.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) (define (make-evaluation-environment parent-env n-vars)
(let ([env (make-struct s:evaluation-environment)]) (let ([env (make-struct s:evaluation-environment)])
@ -38,7 +38,7 @@
(define (evaluation-environment-local-variable-values env) (define (evaluation-environment-local-variable-values env)
(struct-ref (type-check s:evaluation-environment env) 1)) (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 (define (make-compilation-environment
parent-env parent-env
@ -686,7 +686,6 @@
(register-top-level-binding 'byte-string-size (lambda (x) (#%byte-string-size x))) (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-nslots (lambda (x) (#%struct-nslots x)))
(register-top-level-binding 'struct-type (lambda (x) (#%struct-type 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 'acos (lambda (x) (#%acos x)))
(register-top-level-binding 'asin (lambda (x) (#%asin x))) (register-top-level-binding 'asin (lambda (x) (#%asin x)))
(register-top-level-binding 'atan (lambda (x) (#%atan 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 'call-with-context (#%builtin "call-with-context"))
(register-top-level-binding 'exit (#%builtin "exit")) (register-top-level-binding 'exit (#%builtin "exit"))
(register-top-level-binding 'float->string (#%builtin "float->string")) (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-open (#%builtin "posix-open"))
(register-top-level-binding 'posix-dup (#%builtin "posix-dup")) (register-top-level-binding 'posix-dup (#%builtin "posix-dup"))
(register-top-level-binding 'posix-dup2 (#%builtin "posix-dup2")) (register-top-level-binding 'posix-dup2 (#%builtin "posix-dup2"))

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

@ -2,17 +2,17 @@
#@#( #@#(
( (
#@#0=#S(#="structure" #@#0=#S(#="structure"
(#="structure") #="structure"
5 5
#f #f
) )
#@#1=#S(#=0 #@#1=#S(#=0
(#="structure") #="structure"
5 5
#f #f
#@"annotated-structure" #@"annotated-structure"
#@#( #@#(
#@"supers" #@"super"
#@"nslots" #@"nslots"
#@"callable" #@"callable"
#@"name" #@"name"
@ -20,7 +20,7 @@
) )
) )
#@#2=#S(#=1 #@#2=#S(#=1
(#="lambda") #="lambda"
4 4
#f #f
#@"annotated-lambda" #@"annotated-lambda"

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

@ -5,9 +5,9 @@
(define @minimum-buckets@ 17) (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))] (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)]) (let ([ht (make-struct s:hash-table)])
(struct-set! ht 0 eq-fn) (struct-set! ht 0 eq-fn)
(struct-set! ht 1 hash-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 *keywords* (make-hash-table))
(define (make-keyword name) (define (make-keyword name)

2
src/lib/names.rls
View File

@ -15,7 +15,7 @@
(and v1 (eq? v1 (weak-unbox wb2))))) (and v1 (eq? v1 (weak-unbox wb2)))))
(define (weak-hash-value wb) (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)) (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 (define top-level-dynamic-environment
(let ([new-env (make-struct s:dynamic-environment)]) (let ([new-env (make-struct s:dynamic-environment)])
@ -21,7 +21,7 @@
(struct-set! env 0 lst)) (struct-set! env 0 lst))
(define (parameter-callable param . rst) (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))]) (let repeat-with ([bind (dynamic-environment-parameters (current-dynamic-environment))])
(if bind (if bind
(let ([bind-param (parameter-binding-parameter bind)]) (let ([bind-param (parameter-binding-parameter bind)])
@ -30,14 +30,14 @@
(set-parameter-binding-value! bind (set-parameter-binding-value! bind
(apply (parameter-guard-function param) rst)) (apply (parameter-guard-function param) rst))
(parameter-binding-value bind)) (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-left bind))
(repeat-with (parameter-binding-right bind))))) (repeat-with (parameter-binding-right bind)))))
(if (pair? rst) (if (pair? rst)
(set-parameter-value! param (apply (parameter-guard-function param) rst)) (set-parameter-value! param (apply (parameter-guard-function param) rst))
(parameter-value param))))) (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]) (define (make-parameter init [guard-fn values])
(let ([param (make-struct s:parameter)]) (let ([param (make-struct s:parameter)])
@ -51,7 +51,7 @@
(define (set-parameter-value! param val) (struct-set! param 0 val)) (define (set-parameter-value! param val) (struct-set! param 0 val))
(define (parameter-guard-function param) (struct-ref param 1)) (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) (define (make-parameter-binding param val left right)
(let ([binding (make-struct s:parameter-binding)]) (let ([binding (make-struct s:parameter-binding)])
@ -71,12 +71,12 @@
(define (call-with-parameters fn . param-forms) (define (call-with-parameters fn . param-forms)
(define (add-binding param+values to-bind) (define (add-binding param+values to-bind)
(define param (if (pair? param+values) (first param+values) param+values)) (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) (define (lookup-bind bind match-fn branch-fn)
(and bind (let ([bind-param (parameter-binding-parameter bind)]) (and bind (let ([bind-param (parameter-binding-parameter bind)])
(cond (cond
[(eq? bind-param param) (branch-fn bind)] [(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)])))) [else (lookup-bind (branch-fn bind) match-fn branch-fn)]))))
(let ([left-bind (lookup-bind to-bind fix<= parameter-binding-left)] (let ([left-bind (lookup-bind to-bind fix<= parameter-binding-left)]
[right-bind (lookup-bind to-bind fix> parameter-binding-right)] [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) ((current-port-error-handler) port)
(abort)) (abort))
(define s:port (make-structure '() 11)) (define s:port (make-structure #f 11))
(define (port? x) (kind-of? x s:port)) (define (port? x) (kind-of? x s:port))
(define (make-port flags read unread write seek tell flush (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-nslots x) (#%struct-nslots x))
(define (struct-type x) (#%struct-type x)) (define (struct-type x) (#%struct-type x))
(define (hash-value x) (#%hash-value x))
(define (acos x) (#%acos x)) (define (acos x) (#%acos x))
(define (asin x) (#%asin x)) (define (asin x) (#%asin x))
(define (atan x) (#%atan x)) (define (atan x) (#%atan x))
@ -172,6 +170,9 @@
(define float->string (#%builtin "float->string")) (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-open (#%builtin "posix-open"))
;(define posix-openat (#%builtin "posix-openat")) ;(define posix-openat (#%builtin "posix-openat"))
(define posix-dup (#%builtin "posix-dup")) (define posix-dup (#%builtin "posix-dup"))

6
src/lib/util.rls
View File

@ -74,9 +74,9 @@
(lambda () (dirname/basename str)) (lambda () (dirname/basename str))
(lambda (_ x) x))) (lambda (_ x) x)))
(define (make-structure supers nslots [callable #f]) (define (make-structure super nslots [callable #f])
(let ([s (make-struct s:structure)]) (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 1 nslots)
(struct-set! s 2 callable) (struct-set! s 2 callable)
(freeze! s))) (freeze! s)))
@ -224,7 +224,7 @@
(or (memq (car lst) (cdr lst)) (or (memq (car lst) (cdr lst))
(has-duplicates? (cdr lst))))) (has-duplicates? (cdr lst)))))
(define s:marker (make-structure '() 1)) (define s:marker (make-structure #f 1))
(define (make-marker name) (define (make-marker name)
(let ([marker (make-struct s:marker)]) (let ([marker (make-struct s:marker)])