From 892af308ce783d62ecc6e2f7848a19eeb2ed8bf8 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sun, 27 Jun 2010 16:20:51 -0500 Subject: [PATCH] Add support for immutable vectors, byte-strings, and structures. The interpreter now requires its input to be immutable. The reader marks values read after '#@' as immutable, e.g. #@#(...). --- builtin.c | 60 ++++++++++++++++++++++++++++++++++++++++-- builtin.h | 4 ++- gc.c | 15 +++++++++++ gc.h | 4 +++ interp.c | 35 ++++++++++++++---------- libcompiler/writer.scm | 12 ++++----- reader.c | 28 ++++++++++++++++++++ src/reader.rls | 3 +++ 8 files changed, 138 insertions(+), 23 deletions(-) diff --git a/builtin.c b/builtin.c index 063cf8c..827b966 100644 --- a/builtin.c +++ b/builtin.c @@ -17,6 +17,8 @@ static void register_template(void); static void register_lambda(void); static void bi_string_to_number(interp_state_t *state); +static void bi_freeze(interp_state_t *state); +static void bi_immutable_p(interp_state_t *state); void builtin_init(void) { @@ -24,8 +26,10 @@ void builtin_init(void) register_gc_root(&template_type_root, UNDEFINED); register_gc_root(&lambda_type_root, UNDEFINED); - register_builtin(BI_UNDEFINED, UNDEFINED); - register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number)); + register_builtin(BI_UNDEFINED, UNDEFINED); + register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number)); + register_builtin(BI_FREEZE, make_builtin_fn(bi_freeze)); + register_builtin(BI_IMMUTABLE_P, make_builtin_fn(bi_immutable_p)); #ifdef NAN register_builtin(BI_POS_NAN, make_float(NAN)); @@ -98,6 +102,8 @@ static void register_template(void) /* Slot 3: Callable object used as proxy when structure is APPLY'd. */ _get_struct(template_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE; + _get_struct(template_type_root.value)->immutable = true; + register_builtin(BI_TEMPLATE, template_type_root.value); } @@ -113,6 +119,8 @@ static void register_lambda(void) /* Slot 3: Callable object used as proxy when structure is APPLY'd. */ _get_struct(lambda_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE; + _get_struct(lambda_type_root.value)->immutable = true; + register_builtin(BI_LAMBDA, lambda_type_root.value); } @@ -137,4 +145,52 @@ static void bi_string_to_number(interp_state_t *state) interp_return_values(state, cons(rval, NIL)); } +static void bi_freeze(interp_state_t *state) +{ + value_t val = CAR(state->argv.value); + + if (is_vector(val)) + { + _get_vector(val)->immutable = true; + } + else if (is_byte_string(val)) + { + _get_byte_string(val)->immutable = true; + } + else if (is_struct(val)) + { + _get_struct(val)->immutable = true; + } + + interp_return_values(state, cons(val, NIL)); +} + +static void bi_immutable_p(interp_state_t *state) +{ + value_t val; + bool frozen; + + val = CAR(state->argv.value); + + if (is_vector(val)) + { + frozen = _get_vector(val)->immutable; + } + else if (is_byte_string(val)) + { + frozen = _get_byte_string(val)->immutable; + } + else if (is_struct(val)) + { + frozen = _get_struct(val)->immutable; + } + else + { + /* These values can't be changed, and thus can be considered frozen: */ + frozen = !is_object(val) || is_float(val) || is_builtin_fn(val); + } + + interp_return_values(state, cons(boolean_value(frozen), NIL)); +} + /* vim:set sw=2 expandtab: */ diff --git a/builtin.h b/builtin.h index aeac64c..d64d0d8 100644 --- a/builtin.h +++ b/builtin.h @@ -17,8 +17,10 @@ #define BI_POS_INFINITY "+infinity" #define BI_NEG_INFINITY "-infinity" -/* Name of builtin function */ +/* Names of builtin functions */ #define BI_STRING_TO_NUMBER "string->number" +#define BI_FREEZE "freeze!" +#define BI_IMMUTABLE_P "immutable?" #define TEMPLATE_SLOT_GLOBAL_VARS 0 #define TEMPLATE_SLOT_INSTANCE_VARS 1 diff --git a/gc.c b/gc.c index f74039a..e2513dc 100644 --- a/gc.c +++ b/gc.c @@ -166,6 +166,7 @@ value_t make_vector(size_t nelem, value_t initial_value) vec->tag = TYPE_TAG_VECTOR; vec->size = nelem; vec->hash = make_hash_value(); + vec->immutable = false; for (int i = 0; i < nelem; ++i) vec->elements[i] = iv_root.value; @@ -189,6 +190,7 @@ value_t make_byte_string(size_t size, int default_value) str = (byte_string_t*)gc_alloc(nbytes); str->tag = TYPE_TAG_BYTESTR; str->size = size; + str->immutable = false; memset(str->bytes, default_value, size); @@ -242,6 +244,7 @@ value_t make_struct(value_t type) register_gc_root(&type_root, type); release_assert(struct_is_a(type_root.value, get_structure_type())); + release_assert(_get_struct(type_root.value)->immutable); nslots = get_fixnum(_SLOT_VALUE(STRUCTURE, type_root.value, NSLOTS)); s = (struct_t*)gc_alloc(STRUCT_BYTES(nslots)); @@ -249,6 +252,7 @@ value_t make_struct(value_t type) s->type = type_root.value; s->nslots = nslots; s->hash = make_hash_value(); + s->immutable = false; for (int i = 0; i < nslots; ++i) s->slots[i] = UNDEFINED; @@ -281,6 +285,8 @@ static void structure_init(void) /* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */ _get_struct(structure_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE; #undef SS + + _get_struct(structure_type_root.value)->immutable = true; } bool struct_is_a(value_t value, value_t type) @@ -1540,6 +1546,9 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) } else if (is_vector(v)) { + if (_get_vector(v)->immutable) + fputs("#@", f); + fputs("#(", f); for (size_t i = 0; i < _get_vector(v)->size; ++i) @@ -1555,6 +1564,9 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) byte_string_t *str = _get_byte_string(v); size_t written = 0; + if (str->immutable) + fputs("#@", f); + fputc('"', f); for (size_t i = 0; i < str->size; ++i) @@ -1585,6 +1597,9 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) { value_t meta = _get_struct(v)->type; + if (_get_struct(v)->immutable) + fputs("#@", f); + fputs("#S(", f); if (meta == get_structure_type()) diff --git a/gc.h b/gc.h index 568c7a1..8806bf6 100644 --- a/gc.h +++ b/gc.h @@ -61,6 +61,7 @@ typedef void (builtin_fn_t)(struct interp_state *state); #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) @@ -118,6 +119,7 @@ typedef struct vector value_t tag; /* TYPE_TAG_VECTOR */ size_t size; value_t hash; + bool immutable; value_t elements[0]; } vector_t; @@ -125,6 +127,7 @@ typedef struct byte_string { value_t tag; /* TYPE_TAG_BYTESTR */ size_t size; + bool immutable; uint8_t bytes[0]; } byte_string_t; @@ -135,6 +138,7 @@ typedef struct structure value_t type; size_t nslots; value_t hash; + bool immutable; value_t slots[0]; } struct_t; diff --git a/interp.c b/interp.c index 81a9a89..e5cab8f 100644 --- a/interp.c +++ b/interp.c @@ -66,8 +66,8 @@ value_t run_interpreter(value_t lambda, value_t argv) register_state(&state, lambda, argv); - /* Keep going until something attempts to tail-call FALSE_VALUE, the original 'k', indicating completion. */ - while (state.lambda.value != FALSE_VALUE) + /* Keep going until something attempts to tail-call END_PROGRAM, the original 'k', indicating completion. */ + while (state.lambda.value != END_PROGRAM) { /* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */ translate_callable(&state); @@ -95,13 +95,14 @@ value_t run_interpreter(value_t lambda, value_t argv) } else { + release_assert(get_struct(state.lambda.value)->immutable); state.nframe = get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)); release_assert((0 <= state.nframe) && (state.nframe <= 120)); state.globals.value = _LAMBDA_SLOT(state.lambda.value, GLOBAL_VARS); state.instances.value = _LAMBDA_SLOT(state.lambda.value, INSTANCE_VARS); - release_assert(is_vector(state.globals.value)); - release_assert(is_vector(state.instances.value)); + release_assert(get_vector(state.globals.value)->immutable); + release_assert(get_vector(state.instances.value)->immutable); run_byte_code(&state); perform_tail_call(&state); @@ -169,6 +170,7 @@ static value_t struct_ref(value_t v, fixnum_t idx) 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)); vec->elements[idx] = newval; WRITE_BARRIER(v); @@ -177,6 +179,7 @@ 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) { byte_string_t *str = get_byte_string(v); + release_assert(!str->immutable); release_assert((idx >= 0) && (idx < str->size)); str->bytes[idx] = newval; } @@ -184,9 +187,8 @@ 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) { struct_t *s = get_struct(v); - + release_assert(!s->immutable); release_assert((idx >= 0) && (idx < s->nslots)); - s->slots[idx] = newval; WRITE_BARRIER(v); } @@ -232,6 +234,7 @@ static value_t make_lambda(interp_state_t *state, value_t templ) ls->slots[LAMBDA_SLOT_FRAME_VARS] = ts->slots[TEMPLATE_SLOT_FRAME_VARS]; ls->slots[LAMBDA_SLOT_BYTE_CODE] = ts->slots[TEMPLATE_SLOT_BYTE_CODE]; ls->slots[LAMBDA_SLOT_TAIL_CALL] = ts->slots[TEMPLATE_SLOT_TAIL_CALL]; + ls->immutable = true; WRITE_BARRIER(lambda_root.value); l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]); @@ -241,6 +244,7 @@ static value_t make_lambda(interp_state_t *state, value_t templ) { l_inst->elements[i] = get_input(state, t_inst->bytes[i]); } + l_inst->immutable = true; WRITE_BARRIER(object_value(l_inst)); unregister_gc_root(&templ_root); @@ -270,13 +274,15 @@ static void run_byte_code(interp_state_t *state) if (bc_root.value != FALSE_VALUE) { - release_assert((get_byte_string(bc_root.value)->size % 4) == 0); + release_assert(get_byte_string(bc_root.value)->immutable); + release_assert((_get_byte_string(bc_root.value)->size % 4) == 0); for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4) { - uint8_t bytes[4]; + uint32_t word; + uint8_t *bytes = (uint8_t*)&word; - memcpy(bytes, _get_byte_string(bc_root.value)->bytes + offset, 4); + word = *(uint32_t*)(_get_byte_string(bc_root.value)->bytes + offset); switch (bytes[0]) { @@ -312,7 +318,8 @@ static void perform_tail_call(interp_state_t *state) gc_root_t new_lambda, new_argv, new_kw_args, new_kw_vals, new_ctx, new_k; value_t tail_call = _LAMBDA_SLOT(state->lambda.value, TAIL_CALL); - release_assert(get_byte_string(tail_call)->size == 6); + release_assert(get_byte_string(tail_call)->immutable); + release_assert(_get_byte_string(tail_call)->size == 6); register_gc_root(&new_lambda, get_input(state, _get_byte_string(tail_call)->bytes[0])); register_gc_root(&new_argv, get_input(state, _get_byte_string(tail_call)->bytes[1])); @@ -593,14 +600,14 @@ static void register_state(interp_state_t *state, value_t lambda, value_t argv) register_gc_root(&state->kw_args, NIL); register_gc_root(&state->kw_vals, NIL); register_gc_root(&state->ctx, FALSE_VALUE); - register_gc_root(&state->k, FALSE_VALUE); + register_gc_root(&state->k, END_PROGRAM); register_gc_root(&state->globals, UNDEFINED); register_gc_root(&state->instances, UNDEFINED); register_gc_root(&state->frame, make_vector(120, UNDEFINED)); - register_gc_root(&state->in1, FALSE_VALUE); - register_gc_root(&state->in2, FALSE_VALUE); - register_gc_root(&state->in3, FALSE_VALUE); + register_gc_root(&state->in1, UNDEFINED); + register_gc_root(&state->in2, UNDEFINED); + register_gc_root(&state->in3, UNDEFINED); } static void unregister_state(interp_state_t *state) diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index f76381c..3ba583c 100644 --- a/libcompiler/writer.scm +++ b/libcompiler/writer.scm @@ -52,7 +52,7 @@ (write-char #\" port)) (define (write-instance-string inst-vars port) - (write-char #\" port) + (write-string "#@\"" port) (for ([var (in-list inst-vars)]) (write-hex-char (variable->code var) port)) (write-char #\" port)) @@ -60,7 +60,7 @@ (define (write-rla-bytecode+tail-call forms port) (define (write-tail-call tc-form) (req-new-line port) - (write-char #\" port) + (write-string "#@\"" port) (for ([var (in-list (cdr tc-form))]) (write-hex-char (variable->code var) port)) (write-char #\" port) @@ -72,7 +72,7 @@ (let-values ([(line col pos) (port-next-location port)]) (parameterize ([current-indent col]) - (write-char #\" port) + (write-string "#@\"" port) (if (eq? (first (first forms)) '#%tail-call) (begin (write-char #\" port) @@ -100,13 +100,13 @@ (define template? (eq? (first value) '#%template)) (let-values ([(line col pos) (port-next-location port)]) (parameterize ([current-indent col]) - (write-string "#S(" port) + (write-string "#@#S(" port) (if (eq? (first value) '#%template) (write-string "#=\"template\"" port) (write-string "#=\"lambda\"" port)) (parameterize ([current-indent (+ (current-indent-step) (current-indent))]) (req-new-line port) - (write-string "#(" port) + (write-string "#@#(" port) (unless (null? (second value)) (parameterize ([current-indent (+ (current-indent-step) (current-indent))]) (opt-new-line port) @@ -120,7 +120,7 @@ (if template? (write-instance-string (third value) port) (begin - (write-string "#(" port) + (write-string "#@#(" port) (unless (null? (third value)) (parameterize ([current-indent (+ (current-indent-step) (current-indent))]) (opt-new-line port) diff --git a/reader.c b/reader.c index d903f38..71170ac 100644 --- a/reader.c +++ b/reader.c @@ -45,6 +45,8 @@ static value_t read_placeholder(reader_state_t *state); static value_t read_indirect(value_t path); +static value_t freeze(value_t val); + static void next_char(reader_state_t *state); static void skip_whitespace(reader_state_t *state); @@ -220,6 +222,9 @@ static value_t read_special(reader_state_t *state) case 'i': next_char(state); return read_indirect(read_string(state)); + case '@': + next_char(state); + return freeze(read_one_value(state)); default: release_assert(NOTREACHED("Invalid character in special value.")); return UNDEFINED; @@ -751,6 +756,29 @@ static value_t read_indirect(value_t path) return v; } +static value_t freeze(value_t val) +{ + if (is_vector(val)) + { + _get_vector(val)->immutable = true; + } + else if (is_byte_string(val)) + { + _get_byte_string(val)->immutable = true; + } + else if (is_struct(val)) + { + _get_struct(val)->immutable = true; + } + else + { + /* Error if value cannot be made immutable */ + release_assert(!is_object(val) || is_float(val) || is_builtin_fn(val)); + } + + return val; +} + static bool is_placeholder(reader_state_t *state, value_t value) { for (value_t item = state->ref_alist.value; !is_nil(item); item = _CDDR(item)) diff --git a/src/reader.rls b/src/reader.rls index be730df..1b6cca0 100644 --- a/src/reader.rls +++ b/src/reader.rls @@ -123,6 +123,9 @@ [(memq? current-char '(#\B #\b)) (next-char) (read-fixnum 2)] + [(eq? current-char #\@) + (next-char) + (freeze! (read-one-value))] [else (unexpected-char)])) (define (read-list)