diff --git a/builtin.c b/builtin.c index ccbe4ad..0e7ab77 100644 --- a/builtin.c +++ b/builtin.c @@ -135,14 +135,14 @@ static void bi_string_to_number(interp_state_t *state) value_t rval; str = value_to_string(CAR(state->argv.value)); - num = strtol(str, &end, 0); - free(str); + num = (fixnum_t)strtoll(str, &end, 0); if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num)) rval = fixnum_value(num); else rval = FALSE_VALUE; + free(str); interp_return_values(state, cons(rval, NIL)); } diff --git a/builtin.h b/builtin.h index 8925a7d..47a7f7b 100644 --- a/builtin.h +++ b/builtin.h @@ -25,19 +25,17 @@ /* Lambda: Instances of this structure are fundamental callable objects. */ #define LAMBDA_SLOT_GLOBAL_VARS 0 #define LAMBDA_SLOT_INSTANCE_VARS 1 -#define LAMBDA_SLOT_FRAME_VARS 2 -#define LAMBDA_SLOT_BYTE_CODE 3 -#define LAMBDA_SLOT_TAIL_CALL 4 -#define LAMBDA_SLOTS 5 +#define LAMBDA_SLOT_BYTE_CODE 2 +#define LAMBDA_SLOT_TAIL_CALL 3 +#define LAMBDA_SLOTS 4 /* Template: Instances of this structure describe what a LAMBDA * will look like when instanciated with the 'lambda' bytecode. */ #define TEMPLATE_SLOT_GLOBAL_VARS 0 #define TEMPLATE_SLOT_INSTANCE_VARS 1 -#define TEMPLATE_SLOT_FRAME_VARS 2 -#define TEMPLATE_SLOT_BYTE_CODE 3 -#define TEMPLATE_SLOT_TAIL_CALL 4 -#define TEMPLATE_SLOTS 5 +#define TEMPLATE_SLOT_BYTE_CODE 2 +#define TEMPLATE_SLOT_TAIL_CALL 3 +#define TEMPLATE_SLOTS 4 value_t get_lambda_type(void); value_t get_template_type(void); diff --git a/doc/bytecode.txt b/doc/bytecode.txt index e778127..7f27c4f 100644 --- a/doc/bytecode.txt +++ b/doc/bytecode.txt @@ -1,171 +1,164 @@ -top: - 00xxxxxx out in in: expression - 01xxxxxx in in in: statement - 1xxxxxxx out in in: conditional -expression: up to 64, 1 out, 2 in - 00000000 out sub in: unary-expr - 00xxxxxx out in in: binary-expr, x > 1 -unary-expr: up to 255, 1 out, 1 in - 00 invalid / permanently reserved +expression: up to 256, 3 in, no prefix + 00 sub in in: binary-expr - 01 (set! out in) - 02 (set! out (unbox in)) - 03 (set! out (car in)) - 04 (set! out (cdr in)) - 05 (set! out (weak-unbox in)) + 10 (if in1 in2 in3) ; in3 if in1 == #f, in2 otherwise - 08 (set! out (boolean? in)) ; value => bool - 09 (set! out (fixnum? in)) ; value => bool - 0a (set! out (box? in)) ; value => bool - 0b (set! out (pair? in)) ; value => bool - 0c (set! out (vector? in)) ; value => bool - 0d (set! out (byte-string? in)) ; value => bool - 0e (set! out (struct? in)) ; value => bool - 0f (set! out (float? in)) ; value => bool - 10 (set! out (builtin? in)) ; value => bool - 11 (set! out (weak-box? in)) ; value => bool + 20 (vector-set! in1 in2 in3) ; vector n value, 0 <= n < nelem; ==> in3 + 21 (byte-string-set! in1 in2 in3) ; string n value, 0 <= n < nbytes; ==> in3 + 22 (struct-set! in1 in2 in3) ; struct n value, 0 <= n < nslots; ==> in3 - 18 (set! out (make-box in)) ; value => box - 19 (set! out (make-struct in)) ; metastruct => struct - 1a (set! out (make-float in)) ; fixnum => float - 1b (set! out (make-lambda in)) ; template-or-lambda => lambda - 1c (set! out (make-weak-box in)) ; value => weak-box +binary-expr: up to 256, 2 in, prefix = 00 + 00 sub in: unary-expr - 20 (set! out (not in)) ; if in == #f then #t else #f - 21 (set! out (bit-not in)) ; one's complement / bitwise negation - 22 (set! out (fix- in)) ; two's complement / arithmetic negation - 23 (set! out (float- in)) ; floating-point negation + 01 (eq? in1 in2) ; any values; superset of fix= + 02 (cons in1 in2) ; car cdr + 03 (make-vector in1 in2) ; nelem iv, nelem >= 0 + 04 (make-byte-string in1 in2) ; nbytes iv, nbytes >= 0 + 05 (vector-ref in1 in2) ; vector n, 0 <= n < nelem + 06 (byte-string-ref in1 in2) ; string n, 0 <= n < nbytes + 07 (struct-ref in1 in2) ; struct n, 0 <= n < nslots - 28 (set! out (vector-size in)) - 29 (set! out (byte-string-size in)) - 2a (set! out (struct-nslots in)) - 2b (set! out (struct-type in)) - 2c (set! out (hash-value in)) + 08 (fix+ in1 in2) + 09 (fix- in1 in2) + 0a (fix* in1 in2) + 0b (fix/ in1 in2) + 0c (fix% in1 in2) + 0d (fix< in1 in2) ; == (fix> in2 in1) + 0e (fix>= in1 in2) ; == (fix<= in2 in1) + + 10 (bit-and in1 in2) + 11 (bit-or in1 in2) + 12 (bit-xor in1 in2) + + 14 (fix<< in1 in2) ; logical/arithmetic left-shift (2*x) w/ overflow into sign + 15 (fix>> in1 in2) ; arithmetic right-shift (x/2) + 16 (fix>>> in1 in2) ; logical right-shift; sign becomes zero (+) + + 18 (float+ in1 in2) + 19 (float- in1 in2) + 1a (float* in1 in2) + 1b (float/ in1 in2) + 1c (float= in1 in2) + 1d (float< in1 in2) ; == (float> in2 in1) + 1e (float>= in1 in2) ; == (float<= in2 in1) + + 20 (atan2 in1 in2) ; float float + 21 (pow in1 in2) ; float float + 22 (ldexp in1 in2) ; float fixnum + 23 (fmod in1 in2) ; float float + 24 (hypot in1 in2) ; float float + 25 (jn in1 in2) ; fixnum float + 26 (yn in1 in2) ; fixnum float + 27 (nextafter in1 in2) ; float float + 28 (remainder in1 in2) ; float float + 29 (scalb in1 in2) ; float float + + 30 (kind-of? in1 in2) ; value struct-type ==> boolean + 31 (byte-string= in1 in2) + 32 (byte-string< in1 in2) ; == (byte-string> in2 in1) + 33 (byte-string>= in1 in2) ; == (byte-string<= in2 in1) + + 50 (set-box! in1 in2) ; box value ==> in2 + 51 (set-car! in1 in2) ; pair value ==> in2 + 52 (set-cdr! in1 in2) ; pair value ==> in2 + + 70 (tail-call-if in1 in2) ; flag byte-string, perform tail call (in2) if in1 != #f + +unary-expr: up to 256, 1 in, prefix = 00 00 + 00 (fatal-error in) ; signal fatal error; annotated with 'in' if non-nil + + 01 (unbox in) + 02 (weak-unbox in) + 03 (car in) + 04 (cdr in) + + 08 (boolean? in) ; value ==> bool + 09 (fixnum? in) ; value ==> bool + 0a (box? in) ; value ==> bool + 0b (pair? in) ; value ==> bool + 0c (vector? in) ; value ==> bool + 0d (byte-string? in) ; value ==> bool + 0e (struct? in) ; value ==> bool + 0f (float? in) ; value ==> bool + 10 (builtin? in) ; value ==> bool + 11 (weak-box? in) ; value ==> bool + + 18 (make-box in) ; value ==> box + 19 (make-struct in) ; metastruct ==> struct + 1a (make-float in) ; fixnum ==> float + 1b (make-lambda in) ; template-or-lambda ==> lambda + 1c (make-weak-box in) ; value ==> weak-box + + 20 (not in) ; if in == #f then #t else #f + 21 (bit-not in) ; one's complement / bitwise negation + 22 (fix- in) ; two's complement / arithmetic negation + 23 (float- in) ; floating-point negation + + 28 (vector-size in) + 29 (byte-string-size in) + 2a (struct-nslots in) + 2b (struct-type in) + 2c (hash-value in) ; ISO C floating-point - 30 (set! out (acos in)) - 31 (set! out (asin in)) - 32 (set! out (atan in)) - 33 (set! out (cos in)) - 34 (set! out (sin in)) - 35 (set! out (tan in)) - 36 (set! out (cosh in)) - 37 (set! out (sinh in)) - 38 (set! out (tanh in)) - 39 (set! out (exp in)) - 3a (set! out (frexp in)) ; float => (float . fixnum) - 3b (set! out (log in)) ; base e - 3c (set! out (log10 in)) - 3d (set! out (modf in)) ; float => (float . float) - 3e (set! out (sqrt in)) - 3f (set! out (ceil in)) - 40 (set! out (fabs in)) - 41 (set! out (floor in)) + 30 (acos in) + 31 (asin in) + 32 (atan in) + 33 (cos in) + 34 (sin in) + 35 (tan in) + 36 (cosh in) + 37 (sinh in) + 38 (tanh in) + 39 (exp in) + 3a (frexp in) ; float ==> (float . fixnum) + 3b (log in) ; base e + 3c (log10 in) + 3d (modf in) ; float ==> (float . float) + 3e (sqrt in) + 3f (ceil in) + 40 (fabs in) + 41 (floor in) ; SVID & X/Open - 50 (set! out (erf in)) - 51 (set! out (erfc in)) - ; (set! out (gamma in)) ; obsolete - 52 (set! out (j0 in)) - 53 (set! out (j1 in)) - 54 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r - 55 (set! out (y0 in)) - 56 (set! out (y1 in)) + 50 (erf in) + 51 (erfc in) + ; (gamma in) ; obsolete + 52 (j0 in) + 53 (j1 in) + 54 (lgamma in) ; float ==> (float . fixnum), actually lgamma_r + 55 (y0 in) + 56 (y1 in) ; SVID & XPG 4.2/5 - 57 (set! out (asinh in)) - 58 (set! out (acosh in)) - 59 (set! out (atanh in)) - 5a (set! out (cbrt in)) - 5b (set! out (logb in)) + 57 (asinh in) + 58 (acosh in) + 59 (atanh in) + 5a (cbrt in) + 5b (logb in) ; XPG 4.2/5 - 5c (set! out (expm1 in)) - 5d (set! out (ilogb in)) - 5e (set! out (log1p in)) - ; (set! out (rint in)) ; implies changing rounding mode; use floor or ceil + 5c (expm1 in) + 5d (ilogb in) + 5e (log1p in) + ; (rint in) ; implies changing rounding mode; use floor or ceil ; C99 - 70 (set! out (normal? in)) - 71 (set! out (finite? in)) - 72 (set! out (subnormal? in)) - 73 (set! out (infinite? in)) - 74 (set! out (nan? in)) - -binary-expr: up to 63 (01..3f), 1 out, 2 in - 00 unary-expr - - 01 (set! out (eq? in1 in2)) ; any values; superset of fix= - 02 (set! out (cons in1 in2)) ; car cdr - 03 (set! out (make-vector in1 in2)) ; nelem iv, nelem >= 0 - 04 (set! out (make-byte-string in1 in2)) ; nbytes iv, nbytes >= 0 - 05 (set! out (vector-ref in1 in2)) ; vector n, 0 <= n < nelem - 06 (set! out (byte-string-ref in1 in2)) ; string n, 0 <= n < nbytes - 07 (set! out (struct-ref in1 in2)) ; struct n, 0 <= n < nslots - - 08 (set! out (fix+ in1 in2)) - 09 (set! out (fix- in1 in2)) - 0a (set! out (fix* in1 in2)) - 0b (set! out (fix/ in1 in2)) - 0c (set! out (fix% in1 in2)) - 0d (set! out (fix< in1 in2)) ; == (fix> in2 in1) - 0e (set! out (fix>= in1 in2)) ; == (fix<= in2 in1) - - 10 (set! out (bit-and in1 in2)) - 11 (set! out (bit-or in1 in2)) - 12 (set! out (bit-xor in1 in2)) - - 14 (set! out (fix<< in1 in2)) ; arithmetic left-shift (2*x) w/ overflow into sign - 15 (set! out (fix>> in1 in2)) ; arithmetic right-shift (x/2) - 16 (set! out (fix>>> in1 in2)) ; logical right-shift; sign becomes zero (+) - - 18 (set! out (float+ in1 in2)) - 19 (set! out (float- in1 in2)) - 1a (set! out (float* in1 in2)) - 1b (set! out (float/ in1 in2)) - 1c (set! out (float= in1 in2)) - 1d (set! out (float< in1 in2)) ; == (float> in2 in1) - 1e (set! out (float>= in1 in2)) ; == (float<= in2 in1) - - 20 (set! out (atan2 in1 in2)) ; float float - 21 (set! out (pow in1 in2)) ; float float - 22 (set! out (ldexp in1 in2)) ; float fixnum - 23 (set! out (fmod in1 in2)) ; float float - 24 (set! out (hypot in1 in2)) ; float float - 25 (set! out (jn in1 in2)) ; fixnum float - 26 (set! out (yn in1 in2)) ; fixnum float - 27 (set! out (nextafter in1 in2)) ; float float - 28 (set! out (remainder in1 in2)) ; float float - 29 (set! out (scalb in1 in2)) ; float float - - 30 (set! out (kind-of? in1 in2)) ; value struct-type - 31 (set! out (byte-string= in1 in2)) - 32 (set! out (byte-string< in1 in2)) ; == (byte-string> in2 in1) - 33 (set! out (byte-string>= in1 in2)) ; == (byte-string<= in2 in1) -conditional: 1 out, 3 in - ; 0x80 <= AA <= 0xf7 (f0-f119) - AA (set! AA (if in1 in2 in3)) ; in3 if in1 == #f, in2 otherwise -statement: up to 64 (40..7f), 3 in - ; unary statements - 40 (goto-end-if in1) - 41 (goto-end-unless in1) - - ; binary statements - 50 (set-box! in1 in2) ; box value - 51 (set-car! in1 in2) ; pair value - 52 (set-cdr! in1 in2) ; pair value - - ; ternary statements - 60 (vector-set! in1 in2 in3) ; vector n value, 0 <= n < nelem - 61 (byte-string-set! in1 in2 in3) ; string n value, 0 <= n < nbytes - 62 (struct-set! in1 in2 in3) ; struct n value, 0 <= n < nslots + 70 (normal? in) + 71 (finite? in) + 72 (subnormal? in) + 73 (infinite? in) + 74 (nan? in) in: - nil (00000000) [g0, always NIL] - gN (00NNNNNN) [global, N < 64] - iN (01NNNNNN) [instance, N < 64] - fN (1NNNNNNN) [frame, N < 120] - -- (1111100N) [reserved, N < 2] + tN (0NNNNNNN) [transient, 0 <= N < 128, one for each prior expression] + gN (10NNNNNN) [global, 0 <= N < 64] + iN (110NNNNN) [instance, 0 <= N < 32] + iN (1110NNNN) [instance, 32 <= N < 48] + #f (11110000) [constant] + undef (11110001) [constant] + nil (11110010) [constant] + -- (1111xxxx) [reserved, 2 <= x < 10] self (11111010) [current lambda] argv (11111011) [argument list] kw-args (11111100) [keyword arguments] (sorted) @@ -173,21 +166,16 @@ in: ctx (11111110) [dynamic context] k (11111111) [continuation] -out: - fN (1NNNNNNN) [0 <= N < 120] - lambda:[ - global: vector of immutable values (g1..gN); shared between instances (lambdas) - instance: vector of immutable values (i0..iN); shared between frames (calls) - frame: number of frame variables; initially # + global: vector of immutable values (g0..gN); shared between instances (lambdas) + instance: vector of immutable values (i0..iN); shared between calls code: byte-string containing sequence of 4-byte instruction words tail-call: byte-string of in-refs: (target argv kw-args kw-vals ctx k) ] template:[ global: linked - instance: byte-string of in-refs. to parent instance/frame slots - frame: copied verbatim + instance: byte-string of in-refs. to parent instance/transient slots code: linked tail-call: linked ] @@ -234,7 +222,7 @@ call-with-continuation-prompt: ((meta-continuation) result))))))])) parameterize: - Call thunk with 'k' and updated context. - New context includes (parameter => value) association. + Call thunk with 'k' and updated context. (No change to original context.) + New context includes (parameter ==> value) association. # vim:set sw=2 expandtab tw=0: diff --git a/gc.c b/gc.c index 7952d1f..bce64a2 100644 --- a/gc.c +++ b/gc.c @@ -1534,6 +1534,10 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) { fputs("#", f); } + else if (v == END_PROGRAM) + { + fputs("#", f); + } else if (is_fixnum(v)) { fprintf(f, "%lld", (long long int)get_fixnum(v)); @@ -1693,8 +1697,8 @@ void fprint_gc_stats(FILE *f) ns2sec(gc_stats.gen[1].total_ns) / gc_stats.gen[1].passes, ns2sec(gc_stats.gen[1].max_ns)); - fprintf(f, "GC: The Gen-1 soft-limit peaked at %d bytes out of %d allocated.\n", - (int)gc_stats.gen1_high_water, (int)gc_gen1_max_size); + fprintf(f, "GC: The Gen-1 soft-limit peaked at %lld bytes out of %lld allocated.\n", + (long long)gc_stats.gen1_high_water, (long long)gc_gen1_max_size); } else { diff --git a/gc.h b/gc.h index 1f9797c..81fcf7a 100644 --- a/gc.h +++ b/gc.h @@ -193,8 +193,8 @@ typedef struct gc_stats nsec_t max_ns; nsec_t max_gen1_ns; llsize_t total_freed; - } gen[2]; - size_t gen1_high_water; + } gen[2]; + llsize_t gen1_high_water; } gc_stats_t; extern gc_stats_t gc_stats; diff --git a/interp.c b/interp.c index e5cab8f..56d89d8 100644 --- a/interp.c +++ b/interp.c @@ -18,9 +18,6 @@ /* Shorthand for frequently-used fields */ #define _LAMBDA_SLOT(v,s) _SLOT_VALUE(LAMBDA, v, s) -#define ST1 (state->in1.value) -#define ST2 (state->in2.value) -#define ST3 (state->in3.value) /* * Local helper routines @@ -42,13 +39,11 @@ static void translate_callable(interp_state_t *state); static void run_byte_code(interp_state_t *state); static void perform_tail_call(interp_state_t *state); -static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2); -static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_t in); +static value_t get_input(const interp_state_t *state, fixnum_t in); -static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint32_t in3); - -static value_t get_input(const interp_state_t *state, fixnum_t var); -static void set_output(const interp_state_t *state, fixnum_t var, value_t val); +static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint8_t in3); +static value_t eval_binary_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2); +static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_t in); static void register_state(interp_state_t *state, value_t lambda, value_t argv); static void unregister_state(interp_state_t *state); @@ -76,48 +71,50 @@ value_t run_interpreter(value_t lambda, value_t argv) * Now 'lambda' really is a lambda structure instance (or builtin). */ + state.ntransients = 0; + #if 0 fflush(stdout); + fputc('\n', stderr); fputs("LAMBDA: ", stderr); fprint_value(stderr, state.lambda.value); fputc('\n', stderr); fputs("ARGLIST: ", stderr); fprint_value(stderr, state.argv.value); fputc('\n', stderr); fputs("CONTEXT: ", stderr); fprint_value(stderr, state.ctx.value); fputc('\n', stderr); fputs("CONT'N: ", stderr); fprint_value(stderr, state.k.value); fputc('\n', stderr); - fputc('\n', stderr); fflush(stderr); #endif if (is_builtin_fn(state.lambda.value)) { - /* Builtin functions replace the byte-code and tail-call - * steps; they also do not require frame variables. */ - state.nframe = 0; + /* Builtin functions replace the byte-code and tail-call steps. */ _get_builtin_fn(state.lambda.value)(&state); } 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.globals.value = _LAMBDA_SLOT(state.lambda.value, GLOBAL_VARS); state.instances.value = _LAMBDA_SLOT(state.lambda.value, INSTANCE_VARS); + state.byte_code.value = _LAMBDA_SLOT(state.lambda.value, BYTE_CODE); + state.tail_call.value = _LAMBDA_SLOT(state.lambda.value, TAIL_CALL); release_assert(get_vector(state.globals.value)->immutable); release_assert(get_vector(state.instances.value)->immutable); + release_assert((state.byte_code.value == FALSE_VALUE) || + get_byte_string(state.byte_code.value)->immutable); + release_assert(get_byte_string(state.tail_call.value)->immutable); run_byte_code(&state); perform_tail_call(&state); } - /* Clear (used) frame-variable slots so they can be GC'd. */ - for (fixnum_t i = 0; i < state.nframe; ++i) - _get_vector(state.frame.value)->elements[i] = UNDEFINED; + /* Clear (used) transient slots so they can be GC'd. */ + for (int i = 0; i < state.ntransients; ++i) + _get_vector(state.transients.value)->elements[i] = UNDEFINED; /* Clear temporaries. */ - state.in1.value = UNDEFINED; - state.in2.value = UNDEFINED; - state.in3.value = UNDEFINED; - state.globals.value = UNDEFINED; + state.globals.value = UNDEFINED; state.instances.value = UNDEFINED; + state.byte_code.value = UNDEFINED; + state.tail_call.value = UNDEFINED; if (run_finalizers) { @@ -231,7 +228,6 @@ static value_t make_lambda(interp_state_t *state, value_t templ) /* 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_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; @@ -268,261 +264,298 @@ static void translate_callable(interp_state_t *state) static void run_byte_code(interp_state_t *state) { - gc_root_t bc_root; - - register_gc_root(&bc_root, _LAMBDA_SLOT(state->lambda.value, BYTE_CODE)); - - if (bc_root.value != FALSE_VALUE) + if (state->byte_code.value != FALSE_VALUE) { - release_assert(get_byte_string(bc_root.value)->immutable); - release_assert((_get_byte_string(bc_root.value)->size % 4) == 0); + uint8_t byte_code[4*128]; + int nwords; - for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4) { - uint32_t word; - uint8_t *bytes = (uint8_t*)&word; - - word = *(uint32_t*)(_get_byte_string(bc_root.value)->bytes + offset); + byte_string_t *s = get_byte_string(state->byte_code.value); + release_assert(s->immutable); + release_assert(s->size <= sizeof byte_code); + release_assert((s->size % 4) == 0); - switch (bytes[0]) - { - bool cond; - case 0x00 ... 0x3f: /* expression */ - set_output(state, bytes[1], eval_expression(state, bytes[0], bytes[2], bytes[3])); - break; - case 0x40 ... 0x41: /* goto-end-if, goto-end-unless */ - cond = _get_boolean(get_input(state, bytes[1])); - if ((bytes[0] & 1) ? !cond : cond) - { - goto break_for_loop; - } - break; - case 0x42 ... 0x7f: /* statement */ - run_statement(state, bytes[0], bytes[1], bytes[2], bytes[3]); - break; - case 0x80 ... 0xff: /* conditional */ - set_output(state, bytes[0], - get_input(state, _get_boolean(get_input(state, bytes[1])) - ? bytes[2] : bytes[3])); - break; - } + /* Copy byte code to temporary buffer for faster access. */ + nwords = s->size / 4; + memcpy(byte_code, s->bytes, s->size); } - break_for_loop:; - } - unregister_gc_root(&bc_root); + for (int word = 0; word < nwords; ++word) + { + const uint8_t *bytes = &byte_code[4 * word]; + value_t result; + + if (bytes[0] == 0x00 && bytes[1] == 0x70) /* (tail-call-if cond tail-call) */ + { + /* Must handle this here, as it may end the loop. */ + if (_get_boolean(get_input(state, bytes[2]))) + { + value_t tc = get_input(state, bytes[3]); + if (tc != FALSE_VALUE) state->tail_call.value = tc; + nwords = word + 1; + } + + result = UNDEFINED; + } + else + { + result = eval_expression(state, bytes[0], bytes[1], bytes[2], bytes[3]); + } + +#if 0 + fflush(stdout); + fprintf(stderr, "t%02d: (%02d) \\x%02x\\x%02x\\x%02x\\x%02x => ", + state->ntransients, word, bytes[0], bytes[1], bytes[2], bytes[3]); + fprint_value(stderr, result); + fputc('\n', stderr); + fflush(stderr); +#endif + + _get_vector(state->transients.value)->elements[state->ntransients++] = result; + WRITE_BARRIER(state->transients.value); + } + } +} + +static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint8_t in3) +{ + if (code == 0x00) + { + return eval_binary_expression(state, in1, in2, in3); + } + else + { + value_t v1 = get_input(state, in1); + value_t v2 = get_input(state, in2); + value_t v3 = get_input(state, in3); + + switch (code) + { + case 0x10: + return _get_boolean(v1) ? v2 : v3; + case 0x20: + vector_set(v1, get_fixnum(v2), v3); + return UNDEFINED; + case 0x21: + byte_string_set(v1, get_fixnum(v2), (char)get_fixnum(v3)); + return UNDEFINED; + case 0x22: + struct_set(v1, get_fixnum(v2), v3); + return UNDEFINED; + default: + release_assert(NOTREACHED("Invalid ternary byte-code!")); + return UNDEFINED; + } + } } 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); + uint8_t bytes[6]; + gc_root_t root; + value_t new_lambda, new_argv, new_kw_args, new_kw_vals, new_ctx, new_k; - release_assert(get_byte_string(tail_call)->immutable); - release_assert(_get_byte_string(tail_call)->size == 6); + release_assert(get_byte_string(state->tail_call.value)->immutable); + release_assert(_get_byte_string(state->tail_call.value)->size == 6); + memcpy(bytes, _get_byte_string(state->tail_call.value)->bytes, 6); - 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])); - register_gc_root(&new_kw_args, get_input(state, _get_byte_string(tail_call)->bytes[2])); - register_gc_root(&new_kw_vals, get_input(state, _get_byte_string(tail_call)->bytes[3])); - register_gc_root(&new_ctx, get_input(state, _get_byte_string(tail_call)->bytes[4])); - register_gc_root(&new_k, get_input(state, _get_byte_string(tail_call)->bytes[5])); + register_gc_root(&root, make_lambda(state, get_input(state, bytes[0]))); + new_k = make_lambda(state, get_input(state, bytes[5])); + new_lambda = root.value; + unregister_gc_root(&root); - /* If new lambda or continuation is a template, instantiate it here */ - new_lambda.value = make_lambda(state, new_lambda.value); - new_k.value = make_lambda(state, new_k.value); + new_argv = get_input(state, bytes[1]); + new_kw_args = get_input(state, bytes[2]); + new_kw_vals = get_input(state, bytes[3]); + new_ctx = get_input(state, bytes[4]); - /* Transfer control to new function */ - state->lambda.value = new_lambda.value; - state->argv.value = new_argv.value; - state->kw_args.value = new_kw_args.value; - state->kw_vals.value = new_kw_vals.value; - state->ctx.value = new_ctx.value; - state->k.value = new_k.value; - - unregister_gc_root(&new_lambda); - unregister_gc_root(&new_argv); - unregister_gc_root(&new_kw_args); - unregister_gc_root(&new_kw_vals); - unregister_gc_root(&new_ctx); - unregister_gc_root(&new_k); + /* Transfer control to new function; must be after last get_input() */ + state->lambda.value = new_lambda; + state->argv.value = new_argv; + state->kw_args.value = new_kw_args; + state->kw_vals.value = new_kw_vals; + state->ctx.value = new_ctx; + state->k.value = new_k; } -static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2) +static value_t eval_binary_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2) { - if (code != 0x00) + if (code == 0x00) { - ST1 = get_input(state, in1); - ST2 = get_input(state, in2); + return eval_unary_expression(state, in1, in2); } + else + { + value_t v1 = get_input(state, in1); + value_t v2 = get_input(state, in2); + + switch (code) + { + case 0x01: return boolean_value(v1 == v2); + case 0x02: return cons(v1, v2); + case 0x03: return make_vector(get_fixnum(v1), v2); + case 0x04: return make_byte_string(get_fixnum(v1), (char)get_fixnum(v2)); + case 0x05: return vector_ref(v1, get_fixnum(v2)); + case 0x06: return fixnum_value(byte_string_ref(v1, get_fixnum(v2))); + case 0x07: return struct_ref(v1, get_fixnum(v2)); + case 0x08: return fixnum_value(get_fixnum(v1) + get_fixnum(v2)); + case 0x09: return fixnum_value(get_fixnum(v1) - get_fixnum(v2)); + case 0x0a: return fixnum_value(get_fixnum(v1) * get_fixnum(v2)); + case 0x0b: return fixnum_value(get_fixnum(v1) / get_fixnum(v2)); + case 0x0c: return fixnum_value(get_fixnum(v1) % get_fixnum(v2)); + case 0x0d: return boolean_value(get_fixnum(v1) < get_fixnum(v2)); + case 0x0e: return boolean_value(get_fixnum(v1) >= get_fixnum(v2)); + case 0x10: return fixnum_value(get_fixnum(v1) & get_fixnum(v2)); + case 0x11: return fixnum_value(get_fixnum(v1) | get_fixnum(v2)); + case 0x12: return fixnum_value(get_fixnum(v1) ^ get_fixnum(v2)); + case 0x14: return fixnum_value(get_fixnum(v1) << get_fixnum(v2)); + case 0x15: return fixnum_value(get_fixnum(v1) >> get_fixnum(v2)); + case 0x16: return fixnum_value((unsigned long)get_fixnum(v1) >> get_fixnum(v2)); + case 0x18: return make_float(get_float(v1) + get_float(v2)); + case 0x19: return make_float(get_float(v1) - get_float(v2)); + case 0x1a: return make_float(get_float(v1) * get_float(v2)); + case 0x1b: return make_float(get_float(v1) / get_float(v2)); + case 0x1c: return boolean_value(get_float(v1) == get_float(v2)); + case 0x1d: return boolean_value(get_float(v1) < get_float(v2)); + case 0x1e: return boolean_value(get_float(v1) >= get_float(v2)); + case 0x20: return make_float(atan2(get_float(v1), get_float(v2))); + case 0x21: return make_float(pow(get_float(v1), get_float(v2))); + case 0x22: return make_float(ldexp(get_float(v1), get_fixnum(v2))); + case 0x23: return make_float(fmod(get_float(v1), get_float(v2))); + case 0x24: return make_float(hypot(get_float(v1), get_float(v2))); + case 0x25: return make_float(jn(get_fixnum(v1), get_float(v2))); + case 0x26: return make_float(yn(get_fixnum(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 0x29: return make_float(scalb(get_float(v1), get_float(v2))); + case 0x30: return boolean_value(struct_is_a(v1, v2)); + case 0x31: return boolean_value(byte_string_cmp(v1, v2) == 0); + case 0x32: return boolean_value(byte_string_cmp(v1, v2) < 0); + case 0x33: return boolean_value(byte_string_cmp(v1, v2) >= 0); + + case 0x50: + get_box(v1)->value = v2; + WRITE_BARRIER(v1); + return UNDEFINED; + case 0x51: + get_pair(v1)->car = v2; + WRITE_BARRIER(v1); + return UNDEFINED; + case 0x52: + get_pair(v1)->cdr = v2; + WRITE_BARRIER(v1); + return UNDEFINED; + + default: + release_assert(NOTREACHED("Invalid binary byte-code!")); + return UNDEFINED; + } + } +} + +static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_t in) +{ + value_t v1 = get_input(state, in); switch (code) { - case 0x00: return eval_unary_expression(state, in1, in2); - case 0x01: return boolean_value(ST1 == ST2); - case 0x02: return cons(ST1, ST2); - case 0x03: return make_vector(get_fixnum(ST1), ST2); - case 0x04: return make_byte_string(get_fixnum(ST1), (char)get_fixnum(ST2)); - case 0x05: return vector_ref(ST1, get_fixnum(ST2)); - case 0x06: return fixnum_value(byte_string_ref(ST1, get_fixnum(ST2))); - case 0x07: return struct_ref(ST1, get_fixnum(ST2)); - case 0x08: return fixnum_value(get_fixnum(ST1) + get_fixnum(ST2)); - case 0x09: return fixnum_value(get_fixnum(ST1) - get_fixnum(ST2)); - case 0x0a: return fixnum_value(get_fixnum(ST1) * get_fixnum(ST2)); - case 0x0b: return fixnum_value(get_fixnum(ST1) / get_fixnum(ST2)); - case 0x0c: return fixnum_value(get_fixnum(ST1) % get_fixnum(ST2)); - case 0x0d: return boolean_value(get_fixnum(ST1) < get_fixnum(ST2)); - case 0x0e: return boolean_value(get_fixnum(ST1) >= get_fixnum(ST2)); - case 0x10: return fixnum_value(get_fixnum(ST1) & get_fixnum(ST2)); - case 0x11: return fixnum_value(get_fixnum(ST1) | get_fixnum(ST2)); - case 0x12: return fixnum_value(get_fixnum(ST1) ^ get_fixnum(ST2)); - case 0x14: return fixnum_value(get_fixnum(ST1) << get_fixnum(ST2)); - case 0x15: return fixnum_value(get_fixnum(ST1) >> get_fixnum(ST2)); - case 0x16: return fixnum_value((unsigned long)get_fixnum(ST1) >> get_fixnum(ST2)); - case 0x18: return make_float(get_float(ST1) + get_float(ST2)); - case 0x19: return make_float(get_float(ST1) - get_float(ST2)); - case 0x1a: return make_float(get_float(ST1) * get_float(ST2)); - case 0x1b: return make_float(get_float(ST1) / get_float(ST2)); - case 0x1c: return boolean_value(get_float(ST1) == get_float(ST2)); - case 0x1d: return boolean_value(get_float(ST1) < get_float(ST2)); - case 0x1e: return boolean_value(get_float(ST1) >= get_float(ST2)); - case 0x20: return make_float(atan2(get_float(ST1), get_float(ST2))); - case 0x21: return make_float(pow(get_float(ST1), get_float(ST2))); - case 0x22: return make_float(ldexp(get_float(ST1), get_fixnum(ST2))); - case 0x23: return make_float(fmod(get_float(ST1), get_float(ST2))); - case 0x24: return make_float(hypot(get_float(ST1), get_float(ST2))); - case 0x25: return make_float(jn(get_fixnum(ST1), get_float(ST2))); - case 0x26: return make_float(yn(get_fixnum(ST1), get_float(ST2))); - case 0x27: return make_float(nextafter(get_float(ST1), get_float(ST2))); - case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2))); - case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2))); - case 0x30: return boolean_value(struct_is_a(ST1, ST2)); - case 0x31: return boolean_value(byte_string_cmp(ST1, ST2) == 0); - case 0x32: return boolean_value(byte_string_cmp(ST1, ST2) < 0); - case 0x33: return boolean_value(byte_string_cmp(ST1, ST2) >= 0); - default: release_assert(NOTREACHED("Invalid byte-code!")); - } + case 0x00: + release_assert(NOTREACHED("Fatal error detected.")); + return UNDEFINED; - return UNDEFINED; -} + case 0x01: return get_box(v1)->value; + case 0x02: return get_weak_box(v1)->value; + case 0x03: return get_pair(v1)->car; + case 0x04: return get_pair(v1)->cdr; -static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_t in) -{ - release_assert(subcode != 0); - ST1 = get_input(state, in); + case 0x08: return boolean_value(is_boolean(v1)); + case 0x09: return boolean_value(is_fixnum(v1)); + case 0x0a: return boolean_value(is_box(v1)); + case 0x0b: return boolean_value(is_pair(v1)); + case 0x0c: return boolean_value(is_vector(v1)); + case 0x0d: return boolean_value(is_byte_string(v1)); + case 0x0e: return boolean_value(is_struct(v1)); + case 0x0f: return boolean_value(is_float(v1)); + case 0x10: return boolean_value(is_builtin_fn(v1)); + case 0x11: return boolean_value(is_weak_box(v1)); - switch (subcode) - { - case 0x01: return ST1; - case 0x02: return get_box(ST1)->value; - case 0x03: return get_pair(ST1)->car; - case 0x04: return get_pair(ST1)->cdr; - case 0x05: return get_weak_box(ST1)->value; - case 0x08: return boolean_value(is_boolean(ST1)); - case 0x09: return boolean_value(is_fixnum(ST1)); - case 0x0a: return boolean_value(is_box(ST1)); - case 0x0b: return boolean_value(is_pair(ST1)); - case 0x0c: return boolean_value(is_vector(ST1)); - case 0x0d: return boolean_value(is_byte_string(ST1)); - case 0x0e: return boolean_value(is_struct(ST1)); - case 0x0f: return boolean_value(is_float(ST1)); - case 0x10: return boolean_value(is_builtin_fn(ST1)); - case 0x11: return boolean_value(is_weak_box(ST1)); - case 0x18: return make_box(ST1); - case 0x19: return make_struct(ST1); - case 0x1a: return make_float((native_float_t)get_fixnum(ST1)); - case 0x1b: return make_lambda(state, ST1); - case 0x1c: return make_weak_box(ST1); - case 0x20: return boolean_value(!_get_boolean(ST1)); - case 0x21: return fixnum_value(~get_fixnum(ST1)); - case 0x22: return fixnum_value(-get_fixnum(ST1)); - case 0x23: return make_float(-get_float(ST1)); - case 0x28: return fixnum_value(get_vector(ST1)->size); - case 0x29: return fixnum_value(get_byte_string(ST1)->size); - case 0x2a: return fixnum_value(get_struct(ST1)->nslots); - case 0x2b: return get_struct(ST1)->type; - case 0x2c: return get_hash_value(ST1); - case 0x30: return make_float(acos(get_float(ST1))); - case 0x31: return make_float(asin(get_float(ST1))); - case 0x32: return make_float(atan(get_float(ST1))); - case 0x33: return make_float(cos(get_float(ST1))); - case 0x34: return make_float(sin(get_float(ST1))); - case 0x35: return make_float(tan(get_float(ST1))); - case 0x36: return make_float(cosh(get_float(ST1))); - case 0x37: return make_float(sinh(get_float(ST1))); - case 0x38: return make_float(tanh(get_float(ST1))); - case 0x39: return make_float(exp(get_float(ST1))); + case 0x18: return make_box(v1); + case 0x19: return make_struct(v1); + case 0x1a: return make_float((native_float_t)get_fixnum(v1)); + case 0x1b: return make_lambda(state, v1); + case 0x1c: return make_weak_box(v1); + + case 0x20: return boolean_value(!_get_boolean(v1)); + case 0x21: return fixnum_value(~get_fixnum(v1)); + case 0x22: return fixnum_value(-get_fixnum(v1)); + case 0x23: return make_float(-get_float(v1)); + + case 0x28: return fixnum_value(get_vector(v1)->size); + case 0x29: return fixnum_value(get_byte_string(v1)->size); + case 0x2a: return fixnum_value(get_struct(v1)->nslots); + case 0x2b: return get_struct(v1)->type; + case 0x2c: return get_hash_value(v1); + + case 0x30: return make_float(acos(get_float(v1))); + case 0x31: return make_float(asin(get_float(v1))); + case 0x32: return make_float(atan(get_float(v1))); + case 0x33: return make_float(cos(get_float(v1))); + case 0x34: return make_float(sin(get_float(v1))); + case 0x35: return make_float(tan(get_float(v1))); + case 0x36: return make_float(cosh(get_float(v1))); + case 0x37: return make_float(sinh(get_float(v1))); + case 0x38: return make_float(tanh(get_float(v1))); + case 0x39: return make_float(exp(get_float(v1))); case 0x3a: { int exp; - ST2 = make_float(frexp(get_float(ST1), &exp)); - return cons(ST2, fixnum_value(exp)); + value_t v2 = make_float(frexp(get_float(v1), &exp)); + return cons(v2, fixnum_value(exp)); } - case 0x3b: return make_float(log(get_float(ST1))); - case 0x3c: return make_float(log10(get_float(ST1))); + case 0x3b: return make_float(log(get_float(v1))); + case 0x3c: return make_float(log10(get_float(v1))); case 0x3d: { double integral_part; - ST2 = make_float(modf(get_float(ST1), &integral_part)); - ST3 = make_float(integral_part); - return cons(ST2, ST3); + gc_root_t rv2; + value_t v3; + + register_gc_root(&rv2, make_float(modf(get_float(v1), &integral_part))); + v3 = make_float(integral_part); + unregister_gc_root(&rv2); + + return cons(rv2.value, v3); } - case 0x3e: return make_float(sqrt(get_float(ST1))); - case 0x3f: return make_float(ceil(get_float(ST1))); - case 0x40: return make_float(fabs(get_float(ST1))); - case 0x41: return make_float(floor(get_float(ST1))); - case 0x50: return make_float(erf(get_float(ST1))); - case 0x51: return make_float(erfc(get_float(ST1))); - case 0x52: return make_float(j0(get_float(ST1))); - case 0x53: return make_float(j1(get_float(ST1))); + case 0x3e: return make_float(sqrt(get_float(v1))); + case 0x3f: return make_float(ceil(get_float(v1))); + case 0x40: return make_float(fabs(get_float(v1))); + case 0x41: return make_float(floor(get_float(v1))); + case 0x50: return make_float(erf(get_float(v1))); + case 0x51: return make_float(erfc(get_float(v1))); + case 0x52: return make_float(j0(get_float(v1))); + case 0x53: return make_float(j1(get_float(v1))); case 0x54: { int signgamp; - ST2 = make_float(lgamma_r(get_float(ST1), &signgamp)); - return cons(ST2, fixnum_value(signgamp)); + value_t v2 = make_float(lgamma_r(get_float(v1), &signgamp)); + return cons(v2, fixnum_value(signgamp)); } - case 0x55: return make_float(y0(get_float(ST1))); - case 0x56: return make_float(y1(get_float(ST1))); - case 0x57: return make_float(asinh(get_float(ST1))); - case 0x58: return make_float(acosh(get_float(ST1))); - case 0x59: return make_float(atanh(get_float(ST1))); - case 0x5a: return make_float(cbrt(get_float(ST1))); - case 0x5b: return make_float(logb(get_float(ST1))); - case 0x5c: return make_float(expm1(get_float(ST1))); - case 0x5d: return make_float(ilogb(get_float(ST1))); - case 0x5e: return make_float(log1p(get_float(ST1))); - case 0x70: return boolean_value(isnormal(get_float(ST1))); - case 0x71: return boolean_value(isfinite(get_float(ST1))); - case 0x72: return boolean_value(fpclassify(get_float(ST1)) == FP_SUBNORMAL); - case 0x73: return boolean_value(isinf(get_float(ST1))); - case 0x74: return boolean_value(isnan(get_float(ST1))); - default: release_assert(NOTREACHED("Invalid unary sub-bytecode.")); - } + case 0x55: return make_float(y0(get_float(v1))); + case 0x56: return make_float(y1(get_float(v1))); + case 0x57: return make_float(asinh(get_float(v1))); + case 0x58: return make_float(acosh(get_float(v1))); + case 0x59: return make_float(atanh(get_float(v1))); + case 0x5a: return make_float(cbrt(get_float(v1))); + case 0x5b: return make_float(logb(get_float(v1))); + case 0x5c: return make_float(expm1(get_float(v1))); + case 0x5d: return make_float(ilogb(get_float(v1))); + case 0x5e: return make_float(log1p(get_float(v1))); + case 0x70: return boolean_value(isnormal(get_float(v1))); + case 0x71: return boolean_value(isfinite(get_float(v1))); + case 0x72: return boolean_value(fpclassify(get_float(v1)) == FP_SUBNORMAL); + case 0x73: return boolean_value(isinf(get_float(v1))); + case 0x74: return boolean_value(isnan(get_float(v1))); - return UNDEFINED; -} - -static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint32_t in3) -{ - ST1 = get_input(state, in1); - - if (code >= 0x50) - { - ST2 = get_input(state, in2); - } - - if (code >= 0x60) - { - ST3 = get_input(state, in3); - } - - switch (code) - { - /* 0x40 and 0x41 (goto-end-if, goto-end-unless) are handled by run_byte_code() directly. */ - case 0x50: get_box(ST1)->value = ST2; WRITE_BARRIER(ST1); break; - case 0x51: get_pair(ST1)->car = ST2; WRITE_BARRIER(ST1); break; - case 0x52: get_pair(ST1)->cdr = ST2; WRITE_BARRIER(ST1); break; - case 0x60: vector_set(ST1, get_fixnum(ST2), ST3); break; - case 0x61: byte_string_set(ST1, get_fixnum(ST2), (char)get_fixnum(ST3)); break; - case 0x62: struct_set(ST1, get_fixnum(ST2), ST3); break; - default: release_assert(NOTREACHED("Invalid statement bytecode.")); + default: + release_assert(NOTREACHED("Invalid unary bytecode.")); + return UNDEFINED; } } @@ -532,82 +565,60 @@ static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint */ static value_t get_input(const interp_state_t *state, fixnum_t var) { - release_assert((var >= 0) && (var <= 255)); - switch (var) { - case 0: - return NIL; - case 1 ... 63: + case 0x00 ... 0x7f: + { + vector_t *vec = _get_vector(state->transients.value); + release_assert(var < state->ntransients); + return vec->elements[var]; + } + case 0x80 ... 0xbf: { vector_t *vec = _get_vector(state->globals.value); - var -= 1; - + var -= 0x80; release_assert(var < vec->size); return vec->elements[var]; } - case 64 ... 127: + case 0xc0 ... 0xef: { vector_t *vec = _get_vector(state->instances.value); - var -= 64; - + var -= 0xc0; release_assert(var < vec->size); return vec->elements[var]; } - case 128 ... 247: - { - vector_t *vec = _get_vector(state->frame.value); - var -= 128; + case 0xf0: return FALSE_VALUE; + case 0xf1: return NIL; + case 0xf2: return UNDEFINED; + /* 0xf3 through 0xf9 are reserved */ + case 0xfa: return state->lambda.value; + case 0xfb: return state->argv.value; + case 0xfc: return state->kw_args.value; + case 0xfd: return state->kw_vals.value; + case 0xfe: return state->ctx.value; + case 0xff: return state->k.value; - release_assert(var < state->nframe); - return vec->elements[var]; - } - /* 248 ... 249 are reserved */ - case 250: - return state->lambda.value; - case 251: - return state->argv.value; - case 252: - return state->kw_args.value; - case 253: - return state->kw_vals.value; - case 254: - return state->ctx.value; - case 255: - return state->k.value; default: + release_assert(NOTREACHED("Invalid input code.")); return UNDEFINED; } } -static void set_output(const interp_state_t *state, fixnum_t var, value_t val) -{ - vector_t *vec = _get_vector(state->frame.value); - - /* Only frame variables can be output targets for bytecode instructions. */ - release_assert((var >= 128) && (var <= 255)); - - var -= 128; - release_assert(var < state->nframe); - vec->elements[var] = val; - WRITE_BARRIER(state->frame.value); -} - static void register_state(interp_state_t *state, value_t lambda, value_t argv) { - register_gc_root(&state->lambda, lambda); - register_gc_root(&state->argv, 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, END_PROGRAM); + register_gc_root(&state->lambda, lambda); + register_gc_root(&state->argv, 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, 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, UNDEFINED); - register_gc_root(&state->in2, UNDEFINED); - register_gc_root(&state->in3, UNDEFINED); + register_gc_root(&state->globals, UNDEFINED); + register_gc_root(&state->instances, UNDEFINED); + register_gc_root(&state->byte_code, UNDEFINED); + register_gc_root(&state->tail_call, UNDEFINED); + + register_gc_root(&state->transients, make_vector(128, UNDEFINED)); } static void unregister_state(interp_state_t *state) @@ -621,10 +632,10 @@ static void unregister_state(interp_state_t *state) unregister_gc_root(&state->globals); unregister_gc_root(&state->instances); - unregister_gc_root(&state->frame); - unregister_gc_root(&state->in1); - unregister_gc_root(&state->in2); - unregister_gc_root(&state->in3); + unregister_gc_root(&state->byte_code); + unregister_gc_root(&state->tail_call); + + unregister_gc_root(&state->transients); } /* vim:set sw=2 expandtab: */ diff --git a/interp.h b/interp.h index 5af8148..5117404 100644 --- a/interp.h +++ b/interp.h @@ -6,18 +6,19 @@ typedef struct interp_state { gc_root_t lambda; - gc_root_t globals; - gc_root_t instances; - gc_root_t frame; gc_root_t argv; gc_root_t kw_args; gc_root_t kw_vals; gc_root_t ctx; gc_root_t k; - gc_root_t in1; - gc_root_t in2; - gc_root_t in3; - fixnum_t nframe; + + gc_root_t globals; + gc_root_t instances; + gc_root_t byte_code; + gc_root_t tail_call; + + gc_root_t transients; + int ntransients; } interp_state_t; void interpreter_init(void); diff --git a/libcompiler/mapper.scm b/libcompiler/mapper.scm index 27ffe52..2ca95c1 100644 --- a/libcompiler/mapper.scm +++ b/libcompiler/mapper.scm @@ -12,19 +12,22 @@ [unused-g-vars global-variables] [i-vars '()]) (define (add-g-var value) - (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)] - [(symbol? value) `(#%builtin ,(symbol->string value))] - [else value])]) - (let/cc return - (for ([g-var (in-list global-variables)] - [val (in-list g-vars)]) - (when (eq? value val) (return g-var))) - (let ([g-var (first unused-g-vars)]) - (set! unused-g-vars (cdr unused-g-vars)) - (set! g-vars (append g-vars (list value))) - g-var)))) + (cond + [(or (eq? value #f) (equal? value '(quote #f))) '#%f] + [(equal? value '(quote ())) '#%nil] + [else (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)] + [(symbol? value) `(#%builtin ,(symbol->string value))] + [else value])]) + (let/cc return + (for ([g-var (in-list global-variables)] + [val (in-list g-vars)]) + (when (eq? value val) (return g-var))) + (let ([g-var (first unused-g-vars)]) + (set! unused-g-vars (cdr unused-g-vars)) + (set! g-vars (append g-vars (list value))) + g-var)))])) - (let* ([free-vars (filter frame/instance-variable? (free-variables bind))] + (let* ([free-vars (filter transient/instance-variable? (free-variables bind))] [var-map (for/list ([free-var (in-list free-vars)] [inst-var (in-list instance-variables)]) (set! i-vars (append i-vars (list free-var))) @@ -33,11 +36,25 @@ (set! bind `(#%bind ,(subst* var-map (second bind)) ,@(map sv* (cddr bind))))) - (for ([bound-var (in-list (second bind))] - [frame-var (in-list frame-variables)]) - (define (sv form) (subst-var bound-var frame-var form)) - (set! bind `(#%bind ,(subst bound-var frame-var (second bind)) - ,@(map sv (cddr bind))))) + (let* ([var-map (map (lambda (v) (list v '#%undef)) (second bind))] + [exprs (for/list ([expr (in-list (cddr bind))] + [tvar (in-list transient-variables)]) + (if (and (pair? expr) (eq? (first expr) '#%set!)) + (let ([var (second expr)] + [newexpr `(#%set! ,tvar ,(subst-var* var-map (third expr)))]) + (set! var-map (map (lambda (vm) + (if (eq? (first vm) var) + (list var tvar) + vm)) + var-map)) + (when (simple-value? (third newexpr)) + (set! newexpr `(#%set! ,tvar (#%if #%f #%undef ,(third newexpr))))) + newexpr) + `(#%set! ,tvar ,(subst-var* var-map expr))))]) + (set! bind `(#%bind ,(for/list ([s (in-list (cddr bind))] + [v (in-list transient-variables)]) + v) + ,@exprs))) (set! bind (map-form bind #:lambda (lambda (recurse op inner-g-vars i-vars bind) diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm index ab78d28..872468a 100644 --- a/libcompiler/primitives.scm +++ b/libcompiler/primitives.scm @@ -1,29 +1,27 @@ #lang scheme/base -(provide unary-value-primitives - binary-value-primitives - unary-statement-primitives - binary-statement-primitives - ternary-statement-primitives - value-primitives - statement-primitives +(provide unary-primitives + binary-primitives + ternary-primitives + side-effect-primitive? all-primitives + transient-variables global-variables instance-variables - frame-variables special-variables global-variable? instance-variable? - frame-variable? + transient-variable? special-variable? - frame/instance-variable? + transient/instance-variable? machine-variable?) -(define unary-value-primitives - '((#%unbox #x02 unbox) +(define unary-primitives + '((#%fatal-error #x00 fatal-error) + (#%unbox #x01 unbox) + (#%weak-unbox #x02 weak-unbox) (#%car #x03 car) (#%cdr #x04 cdr) - (#%weak-unbox #x05 weak-unbox) (#%boolean? #x08 boolean?) (#%fixnum? #x09 fixnum?) (#%box? #x0a box?) @@ -87,7 +85,7 @@ (#%infinite? #x73 infinite?) (#%nan? #x74 nan?))) -(define binary-value-primitives +(define binary-primitives '((#%eq? #x01 eq?) (#%cons #x02 cons) (#%make-vector #x03 make-vector) @@ -128,62 +126,54 @@ (#%kind-of? #x30 kind-of?) (#%byte-string= #x31 byte-string=) (#%byte-string< #x32 byte-string<) - (#%byte-string>= #x33 byte-string>=))) - -(define unary-statement-primitives - '((#%goto-end-if #x40 #f) - (#%goto-end-unless #x41 #f))) - -(define binary-statement-primitives - '((#%set-box! #x50 set-box!) + (#%byte-string>= #x33 byte-string>=) + (#%set-box! #x50 set-box!) (#%set-car! #x51 set-car!) - (#%set-cdr! #x52 set-cdr!))) + (#%set-cdr! #x52 set-cdr!) + (#%tail-call-if #x70 tail-call-if))) -(define ternary-statement-primitives - '((#%vector-set! #x60 vector-set!) - (#%byte-string-set! #x61 byte-string-set!) - (#%struct-set! #x62 struct-set!))) - -(define value-primitives - (append unary-value-primitives - binary-value-primitives - '((#%if #f #f)))) - -(define statement-primitives - (append unary-statement-primitives - binary-statement-primitives - ternary-statement-primitives)) +(define ternary-primitives + '((#%if #x10 if) + (#%vector-set! #x20 vector-set!) + (#%byte-string-set! #x21 byte-string-set!) + (#%struct-set! #x22 struct-set!))) (define all-primitives - (append value-primitives statement-primitives)) + (append unary-primitives + binary-primitives + ternary-primitives)) + +(define (side-effect-primitive? sym) + (memq sym '(#%byte-string-set! #%fatal-error #%set-box! #%set-car! + #%set-cdr! #%struct-set! #%tail-call-if #%vector-set!))) (define global-variables - (for/list ([i (in-range 1 64)]) + (for/list ([i (in-range 0 64)]) (string->uninterned-symbol (string-append "#%g" (number->string i))))) (define instance-variables (for/list ([i (in-range 0 64)]) (string->uninterned-symbol (string-append "#%i" (number->string i))))) -(define frame-variables - (for/list ([i (in-range 0 120)]) - (string->uninterned-symbol (string-append "#%f" (number->string i))))) +(define transient-variables + (for/list ([i (in-range 0 128)]) + (string->uninterned-symbol (string-append "#%t" (number->string i))))) (define special-variables - '(#%nil #%self #%argv #%kw-args #%kw-vals #%ctx #%k)) + '(#%f #%nil #%undef #%self #%argv #%kw-args #%kw-vals #%ctx #%k)) -(define (global-variable? var) (and (memq var global-variables) #t)) -(define (instance-variable? var) (and (memq var instance-variables) #t)) -(define (frame-variable? var) (and (memq var frame-variables) #t)) -(define (special-variable? var) (and (memq var special-variables) #t)) +(define (global-variable? var) (and (memq var global-variables) #t)) +(define (instance-variable? var) (and (memq var instance-variables) #t)) +(define (transient-variable? var) (and (memq var transient-variables) #t)) +(define (special-variable? var) (and (memq var special-variables) #t)) -(define (frame/instance-variable? var) - (or (frame-variable? var) +(define (transient/instance-variable? var) + (or (transient-variable? var) (instance-variable? var))) (define (machine-variable? var) (or (special-variable? var) - (frame/instance-variable? var) + (transient/instance-variable? var) (global-variable? var))) ; vim:set sw=2 expandtab: diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm index 48442b8..d692409 100644 --- a/libcompiler/simplifier.scm +++ b/libcompiler/simplifier.scm @@ -83,8 +83,7 @@ #:value-list same-form #:primitive same-form #:simple (lambda (recurse kind form) form) - #:literal (lambda (recurse kind form) - (if (equal? form '(quote ())) '#%nil form)) + #:literal (lambda (recurse kind form) form) #:other simplify-complex-form)) (define (body->forms body) @@ -491,7 +490,7 @@ (#%set! ,k-argv (#%cons ,k #%nil)) (#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))] ; keep all other forms with side-effects as-is - [(? statement-form?) (cons subform after)] + [(? side-effect-form?) (cons subform after)] ; discard any form without side-effects [_ after])) `(#%bind ,(second flat-bind) diff --git a/libcompiler/utilities.scm b/libcompiler/utilities.scm index 8b39d32..eafb708 100644 --- a/libcompiler/utilities.scm +++ b/libcompiler/utilities.scm @@ -14,9 +14,8 @@ literal-value? simple-value? value-form? - statement-form? + side-effect-form? primitive-form? - pure-form? bind-form? traverse-form map-form @@ -113,28 +112,23 @@ (literal-value? form))) ; A value-form is any simple form which can appear on the right-hand side of a (set! ...). -; If there are any side-effect they occur before the variable is updated. +; If there are any side-effects they occur before the variable is updated. (define (value-form? form) (define complex-values '(#%bind #%lambda #%apply #%call/cc #%values #%value-list)) (or (simple-value? form) (memq (first form) complex-values) - (memq (first form) (map first value-primitives)))) + (memq (first form) (map first all-primitives)))) -; A statement-form is any simple form which has, or may have, side-effects. -(define (statement-form? form) - (define complex-statements '(#%set! #%apply #%call/cc #%tail-call)) +; A side-effect-form is any simple form which has, or may have, side-effects. +(define (side-effect-form? form) + (define complex-side-effects '(#%set! #%apply #%call/cc #%tail-call)) (and (not (simple-value? form)) - (or (memq (first form) complex-statements) - (memq (first form) (map first statement-primitives))))) + (or (memq (first form) complex-side-effects) + (side-effect-primitive? (first form))))) (define (primitive-form? form) (and (pair? form) (memq (first form) (map first all-primitives)))) -; A pure form is any form known to be free of side-effects. -(define (pure-form? form) - (and (value-form? form) - (not (statement-form? form)))) - (define (bind-form? form) (and (pair? form) (eq? (first form) '#%bind))) diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index 158f575..714d370 100644 --- a/libcompiler/writer.scm +++ b/libcompiler/writer.scm @@ -123,21 +123,21 @@ (let-values ([(line col pos) (port-next-location (current-output-port))]) (parameterize ([current-indent col]) (write-string "#@\"") - (if (eq? (first (first forms)) '#%tail-call) + (if (eq? (first (third (first forms))) '#%tail-call) (begin (write-char #\") - (write-tail-call (first forms))) + (write-tail-call (third (first forms)))) (let iter ([forms forms]) (map (lambda (x) (write-hex-char x)) (statement->code (car forms))) - (if (eq? (first (second forms)) '#%tail-call) + (if (eq? (first (third (second forms))) '#%tail-call) (begin (if (verbose-rla?) (begin (write-string "\"; ") - (write (car forms))) + (write (first forms))) (write-char #\")) - (write-tail-call (second forms))) + (write-tail-call (third (second forms)))) (begin (when (verbose-rla?) (write-string "\\; ") @@ -181,8 +181,6 @@ (opt-new-line)) (write-string ")"))) (req-new-line) - (write-rla-val (length (second (fourth value)))) - (req-new-line) (write-rla-bytecode+tail-call (cddr (fourth value)))) (opt-new-line)) (write-string ")"))) @@ -252,56 +250,39 @@ [else (error "Don't know how to write Rosella syntax for:" value)])) (define (variable->code var) - (or (and (eq? var '#%nil) #x00) + (or (let ([index (find var transient-variables)]) + (and index (+ #x00 index))) (let ([index (find var global-variables)]) - (and index (+ #x01 index))) - (let ([index (find var instance-variables)]) - (and index (+ #x40 index))) - (let ([index (find var frame-variables)]) (and index (+ #x80 index))) + (let ([index (find var instance-variables)]) + (and index (+ #xc0 index))) + (let ([index (find var '(#%f #%nil #%undef))]) + (and index (+ #xf0 index))) (let ([index (find var '(#%self #%argv #%kw-args #%kw-vals #%ctx #%k))]) (and index (+ #xfa index))) (error "No bytecode for variable:" var))) (define (statement->code form) - (if (eq? (first form) '#%set!) - (let ([out (variable->code (second form))] - [value (third form)]) - (cond - [(machine-variable? value) - (list #x00 out #x01 (variable->code value))] - [(eq? (length (cdr value)) 1) - (let ([item (assoc (first value) unary-value-primitives)]) - (unless item (error "Invalid unary value primitive:" value)) - (list #x00 out (second item) (variable->code (second value))))] - [(eq? (length (cdr value)) 2) - (let ([item (assoc (first value) binary-value-primitives)]) - (unless item (error "Invalid binary value primitive:" value)) - (list* (second item) out (map variable->code (cdr value))))] - [else - (unless (and (eq? (first value) '#%if) - (eq? (length (cdr value)) 3)) - (error "Invalid ternary primitive:" form)) - (list* out (map variable->code (cdr value)))])) - (case (length (cdr form)) - [(1) (let ([item (assoc (first form) unary-statement-primitives)]) - (unless item (error "Invalid unary statement primitive:" form)) - (list (second item) - (variable->code (second form)) - #x00 - #x00))] - [(2) (let ([item (assoc (first form) binary-statement-primitives)]) - (unless item (error "Invalid binary statement primitive:" form)) - (list (second item) - (variable->code (second form)) - (variable->code (third form)) - #x00))] - [(3) (let ([item (assoc (first form) ternary-statement-primitives)]) - (unless item (error "Invalid ternary statement primitive:" form)) - (list (second item) - (variable->code (second form)) - (variable->code (third form)) - (variable->code (fourth form))))] - [else (error "Unsupported form:" form)]))) + (let ([vform (third form)]) ; (#%set! #%tNN vform) + (case (length (cdr vform)) + [(1) (let ([item (assoc (first vform) unary-primitives)]) + (or item (error "Invalid unary primitive:" vform)) + (list #x00 + #x00 + (second item) + (variable->code (second vform))))] + [(2) (let ([item (assoc (first vform) binary-primitives)]) + (or item (error "Invalid binary primitive:" vform)) + (list #x00 + (second item) + (variable->code (second vform)) + (variable->code (third vform))))] + [(3) (let ([item (assoc (first vform) ternary-primitives)]) + (or item (error "Invalid ternary primitive:" vform)) + (list (second item) + (variable->code (second vform)) + (variable->code (third vform)) + (variable->code (fourth vform))))] + [else (error "Unsupported form:" vform)]))) ; vim:set sw=2 expandtab: diff --git a/src/examples/annotated-structs.rla b/src/examples/annotated-structs.rla index 568a46b..d19f980 100644 --- a/src/examples/annotated-structs.rla +++ b/src/examples/annotated-structs.rla @@ -21,32 +21,26 @@ ) #@#2=#S(#=1 (#="lambda") - 8 + 4 #f #@"annotated-lambda" #@#( "global-vars" "instance-vars" - "frame-vars" "byte-code" "tail-call" - "arg-list" - "context" - "continuation" ) ) ) #@#S(#=2 - #@#(("OK") #f) + #@#(("OK")) #@#() - 0 - #@"" - #@"\xff\x01\x00\x00\x02\x02" + #f + #@"\xff\x80\xf1\xf1\xf0\xf0" ) ) #@#() - 0 - #@"" - #@"\x02\xfd\xfe\xff" + #f + #@"\x81\xfb\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=3 expandtab: diff --git a/src/examples/factorial.rla b/src/examples/factorial.rla index 6341239..155bb87 100755 --- a/src/examples/factorial.rla +++ b/src/examples/factorial.rla @@ -19,14 +19,12 @@ #i"../lib/math/fact.rla" ) #@"\xfe\xff" ; ctx k - 0 - #@"" - #@"\x01\xfb\x00\x00\x40\x41" + #f + #@"\x80\xfb\xf1\xf1\xc0\xc1" ) ) #@#() - 0 - #@"" - #@"\x01\xfb\x00\x00\xfe\x02" + #f + #@"\x80\xfb\xf1\xf1\xfe\x81" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-and.rla b/src/examples/test-and.rla index 22e87ae..dcbdb85 100644 --- a/src/examples/test-and.rla +++ b/src/examples/test-and.rla @@ -8,16 +8,15 @@ #@#( #i"../lib/primitive/and.rla" ( - #@#S(#="lambda" #@#(( 3) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#((#t) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#(( 4) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#((#f) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#(( 5) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") + #@#S(#="lambda" #@#(( 3)) #0=#@#() #f #1=#@"\xff\x80\xf1\xf1\xf0\xf0") + #@#S(#="lambda" #@#((#t)) #=0 #f #=1) + #@#S(#="lambda" #@#(( 4)) #=0 #f #=1) + #@#S(#="lambda" #@#((#f)) #=0 #f #=1) + #@#S(#="lambda" #@#(( 5)) #=0 #f #=1) ) ) - #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #=0 + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-append.rla b/src/examples/test-append.rla index bb5de7c..7c72f88 100644 --- a/src/examples/test-append.rla +++ b/src/examples/test-append.rla @@ -1,13 +1,12 @@ #@#S(#="lambda" ; (define (test-append) - ; (append '(1 2 3) (4 5) (6 7 8 9))) + ; (append '(1 2 3) '(4 5) '(6 7 8 9))) #@#( #i"../lib/primitive/append.rla" ((1 2 3) (4 5) (6 7 8 9)) ) #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-foldl.rla b/src/examples/test-foldl.rla index 896b910..af315b1 100644 --- a/src/examples/test-foldl.rla +++ b/src/examples/test-foldl.rla @@ -7,23 +7,21 @@ #@#S(#="lambda" ; (define (+ x y) ; (fix+ x y)) - #@#(#f) #@#() - 2 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x00\x81\x04\xfb\; (set! f1 (cdr argv)) - \x00\x81\x03\x81\; (set! f1 (car f1)) - \x08\x80\x80\x81\; (set! f0 (fix+ f0 f1)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\xff\x80\x00\x00\x01\x01" + #@#() + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (set! t0 (car t1)) + \x00\x08\x00\x02\; (set! t3 (fix+ t0 t2)) + \x00\x02\x03\xf1"; (set! t4 (cons t3 nil)) + #@"\xff\x04\xf1\xf1\xf0\xf0" ) 0 (2 3 4 5) ) ) #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-foldr.rla b/src/examples/test-foldr.rla index dc98a33..741ac07 100644 --- a/src/examples/test-foldr.rla +++ b/src/examples/test-foldr.rla @@ -7,23 +7,21 @@ #@#S(#="lambda" ; (define (+ x y) ; (fix+ x y)) - #@#(#f) #@#() - 2 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x00\x81\x04\xfb\; (set! f1 (cdr argv)) - \x00\x81\x03\x81\; (set! f1 (car f1)) - \x08\x80\x80\x81\; (set! f0 (fix+ f0 f1)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\xff\x80\x00\x00\x01\x01" + #@#() + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (set! t0 (car t1)) + \x00\x08\x00\x02\; (set! t3 (fix+ t0 t2)) + \x00\x02\x03\xf1"; (set! t4 (cons t3 nil)) + #@"\xff\x04\xf1\xf1\xf0\xf0" ) 0 (2 3 4 5) ) ) #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-list.rla b/src/examples/test-list.rla index 7dd95d2..3c980ef 100644 --- a/src/examples/test-list.rla +++ b/src/examples/test-list.rla @@ -6,8 +6,7 @@ (1 2 3 4 5) ) #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-map.rla b/src/examples/test-map.rla index cc2d6c3..4b82d2d 100644 --- a/src/examples/test-map.rla +++ b/src/examples/test-map.rla @@ -9,8 +9,7 @@ ) ) #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-or.rla b/src/examples/test-or.rla index d52dac2..e6146b8 100644 --- a/src/examples/test-or.rla +++ b/src/examples/test-or.rla @@ -8,16 +8,15 @@ #@#( #i"../lib/primitive/or.rla" ( - #@#S(#="lambda" #@#((#f) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#(( 3) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#((#f) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#((#t) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") - #@#S(#="lambda" #@#((#f) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") + #@#S(#="lambda" #@#((#f)) #0=#@#() #f #1=#@"\xff\x80\xf1\xf1\xf0\xf0") + #@#S(#="lambda" #@#(( 3)) #=0 #f #=1) + #@#S(#="lambda" #@#((#f)) #=0 #f #=1) + #@#S(#="lambda" #@#((#t)) #=0 #f #=1) + #@#S(#="lambda" #@#((#f)) #=0 #f #=1) ) ) #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/examples/test-reverse.rla b/src/examples/test-reverse.rla index c5a4710..34a7858 100644 --- a/src/examples/test-reverse.rla +++ b/src/examples/test-reverse.rla @@ -6,8 +6,7 @@ ((2 3 4 5)) ) #@#() - 0 - #@"" - #@"\x01\x02\x00\x00\xfe\xff" + #f + #@"\x80\x81\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/math/fact.rla b/src/lib/math/fact.rla index ce85649..7ad02bc 100755 --- a/src/lib/math/fact.rla +++ b/src/lib/math/fact.rla @@ -13,11 +13,10 @@ 1 #@#S(#="lambda" ; (lambda _ 1) - #@#((1) #f) + #@#((1)) #@#() - 0 - #@"" - #@"\xff\x01\x00\x00\x02\x02" + #f + #@"\xff\x80\xf1\xf1\xf0\xf0" ) #@#S(#="template" ; (let [n] @@ -33,28 +32,25 @@ ; (let/cc k ; (lambda (m) ; (k (* n m))))) - #@#(#f) - #@"\x40\xff" ; i0 k - 1 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x0a\x80\x40\x80\; (set! f0 (fix* i0 f0)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\x41\x80\x00\x00\x01\x01" + #@#() + #@"\xc0\xff" ; i0 k + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x0a\xc0\x00\; (set! t1 (fix* i0 t0)) + \x00\x02\x01\xf1"; (set! t2 (cons t1 nil)) + #@"\xc1\x02\xf1\xf1\xf0\xf0" ) #=0 ; fact ) - #@"\x80" - 1 - #@"\x09\x80\x40\x01\; (set! f0 (fix- i0 g1)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\x03\x80\x00\x00\xfe\x02" + #@"\x00" + #@"\x00\x09\xc0\x80\; (set! t0 (fix- i0 g0)) + \x00\x02\x00\xf1"; (set! t1 (cons t0 nil)) + #@"\x82\x01\xf1\xf1\xfe\x81" ) ) #@#() - 2 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x0d\x81\x80\x01\; (set! f1 (fix< f0 g1)) - \x81\x81\x02\x03"; (set! f1 (if f1 g2 g3)) - #@"\x81\x00\x00\x00\xfe\xff" + #@"\x00\x00\x03\xfb\; (set! f0 (car argv)) + \x00\x0d\x00\x80\; (set! f1 (fix< t0 g0)) + \x10\x01\x81\x82"; (set! f1 (if t1 g1 g2)) + #@"\x02\xf1\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/acons.rla b/src/lib/primitive/acons.rla index c17c9c1..495d4fd 100644 --- a/src/lib/primitive/acons.rla +++ b/src/lib/primitive/acons.rla @@ -1,17 +1,16 @@ #@#S(#="lambda" ; (define (acons a b lst) ; (cons a (cons b lst))) - #@#(#f) #@#() - 3 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x00\x82\x04\xfb\; (set! f2 (cdr argv)) - \x00\x81\x03\x82\; (set! f1 (car f2)) - \x00\x82\x04\x82\; (set! f2 (cdr f2)) - \x00\x82\x03\x82\; (set! f2 (car f2)) - \x02\x81\x81\x82\; (set! f1 (cons f1 f2)) - \x02\x80\x80\x81\; (set! f0 (cons f0 f1)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\xff\x80\x00\x00\x01\x01" + #@#() + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (car t1)) + \x00\x00\x04\x01\; (set! t3 (cdr t1)) + \x00\x00\x03\x03\; (set! t4 (car t2)) + \x00\x02\x02\x04\; (set! t5 (cons t2 t4)) + \x00\x02\x00\x05\; (set! t6 (cons t0 t5)) + \x00\x02\x06\xf1"; (set! t7 (cons t6 nil)) + #@"\xff\x07\xf1\xf1\xf0\xf0" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/and.rla b/src/lib/primitive/and.rla index de4d48c..2ce54f0 100644 --- a/src/lib/primitive/and.rla +++ b/src/lib/primitive/and.rla @@ -24,27 +24,23 @@ #@#S(#="template" ; (lambda (x) ; ((if x k2 k) x)) - #@#(#f) - #@"\x40\xff" ; i0 k - 1 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x80\x80\x41\x40"; (set! f0 (if f0 i1 i0)) - #@"\x80\xfb\x00\x00\x01\x01" + #@#() + #@"\xc0\xff" ; i0 k + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x10\x00\xc1\xc0"; (set! t1 (if t0 i1 i0)) + #@"\x01\xfb\xf1\xf1\xf0\xf0" ) ) #@"\xff" ; k - 1 - #@"\x00\x80\x03\xfb"; (set! f0 (car argv)) - #@"\x80\x00\x00\x00\xfe\x01" + #@"\x00\x00\x03\xfb"; (set! t0 (car argv)) + #@"\x00\xf1\xf1\xf1\xfe\x80" ) - #t ) #@#() - 2 - #@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) - \x02\x80\x03\x80\; (set! f0 (cons g3 f0)) - \x00\x81\x1b\x02\; (set! f1 (lambda g2)) - \x02\x80\x81\x80"; (set! f0 (cons f1 f0)) - #@"\x01\x80\x00\x00\xfe\xff" + #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil)) + \x00\x02\xf0\x00\; (set! t1 (cons g2 t0)) + \x00\x00\x1b\x81\; (set! t2 (lambda g1)) + \x00\x02\x02\x01"; (set! t3 (cons t2 t1)) + #@"\x80\x03\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/append.rla b/src/lib/primitive/append.rla index 5dbf590..5156400 100644 --- a/src/lib/primitive/append.rla +++ b/src/lib/primitive/append.rla @@ -15,21 +15,19 @@ #i"cons.rla" ) #@#() - 2 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x02\x81\x80\x00\; (set! f1 (cons f0 nil)) - \x00\x80\x04\xfb\; (set! f0 (cdr argv)) - \x00\x80\x03\x80\; (set! f0 (car f0)) - \x02\x81\x80\x81\; (set! f1 (cons f0 f1)) - \x02\x81\x02\x81"; (set! f1 (cons g2 f1)) - #@"\x01\x81\x00\x00\xfe\xff" + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x02\x00\xf1\; (set! t1 (cons t0 nil)) + \x00\x00\x04\xfb\; (set! t2 (cdr argv)) + \x00\x00\x03\x02\; (set! t3 (car t2)) + \x00\x02\x03\x01\; (set! t4 (cons t3 t1)) + \x00\x02\x81\x04"; (set! t5 (cons g1 t4)) + #@"\x80\x05\xf1\xf1\xfe\xff" ) ) #@#() - 1 - #@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) - \x02\x80\x00\x80\; (set! f0 (cons nil f0)) - \x02\x80\x02\x80"; (set! f0 (cons g2 f0)) - #@"\x01\x80\x00\x00\xfe\xff" + #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil)) + \x00\x02\xf1\x00\; (set! t1 (cons nil t0)) + \x00\x02\x81\x01"; (set! t2 (cons g1 t1)) + #@"\x80\x02\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/cons.rla b/src/lib/primitive/cons.rla index 280abf9..2849f50 100644 --- a/src/lib/primitive/cons.rla +++ b/src/lib/primitive/cons.rla @@ -1,14 +1,13 @@ #@#S(#="lambda" ; (define (cons x y) ; (builtin-cons x y)) - #@#(#f) #@#() - 2 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x00\x81\x04\xfb\; (set! f1 (cdr argv)) - \x00\x81\x03\x81\; (set! f1 (car f1)) - \x02\x80\x80\x81\; (set! f0 (cons f0 f1)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\xff\x80\x00\x00\x01\x01" + #@#() + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (car t1)) + \x00\x02\x00\x02\; (set! t3 (cons t0 t2)) + \x00\x02\x03\xf1"; (set! t4 (cons t3 nil)) + #@"\xff\x04\xf1\xf1\xf0\xf0" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/foldl.rla b/src/lib/primitive/foldl.rla index a422d50..798e356 100644 --- a/src/lib/primitive/foldl.rla +++ b/src/lib/primitive/foldl.rla @@ -25,45 +25,32 @@ ; (lambda (new-init) ; (k (foldl fn new-init (cdr lst)))) #@#(#=0) - #@"\x40\x41\x42\xfe\xff" ; i0 i1 i2 ctx k - 2 - #@"\x00\x80\x04\x42\; (set! f0 (cdr i2)) - \x02\x80\x80\x00\; (set! f0 (cons f0 nil)) - \x00\x81\x03\xfb\; (set! f1 (car argv)) - \x02\x80\x81\x80\; (set! f0 (cons f1 f0)) - \x02\x80\x40\x80"; (set! f0 (cons i0 f0)) - #@"\x01\x80\x00\x00\x43\x44" + #@"\xc0\xc1\xc2\xfe\xff" ; i0 i1 i2 ctx k + #@"\x00\x00\x04\xc2\; (set! t0 (cdr i2)) + \x00\x02\x00\xf1\; (set! t1 (cons t0 nil)) + \x00\x00\x03\xfb\; (set! t2 (car argv)) + \x00\x02\x02\x01\; (set! t3 (cons t2 t1)) + \x00\x02\xc0\x03"; (set! t4 (cons i0 t3)) + #@"\x80\x04\xf1\xf1\xc3\xc4" ) ) - #@"\x80\x81\x82" ; f0=fn f1=init f2=lst - 2 - #@"\x02\x80\x41\x00\; (set! f0 (cons i1 nil)) - \x00\x81\x03\x42\; (set! f1 (car i2)) - \x02\x80\x81\x80"; (set! f0 (cons f1 f0)) - #@"\x40\x80\x00\x00\xfe\x01" - ) - #@#S(#="template" - ; (lambda () init) - #@#(#f) - #@"\x81" ; f1 - 1 - #@"\x02\x80\x40\x00"; (set! f0 (cons i0 nil)) - #@"\xff\x80\x00\x00\x01\x01" + #@"\x00\x02\x04" ; t0=fn t2=init t4=lst + #@"\x00\x02\xc1\xf1\; (set! t0 (cons i1 nil)) + \x00\x00\x03\xc2\; (set! t1 (car i2)) + \x00\x02\x01\x00"; (set! t2 (cons t1 t0)) + #@"\xc0\x02\xf1\xf1\xfe\x80" ) + #@"\x80\xf1\xf1\xf1\xfe\xff" ) #@#() - 6 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) ; f0=fn - \x00\x82\x04\xfb\; (set! f2 (cdr argv)) - \x00\x81\x03\x82\; (set! f1 (car f2)) ; f1=init - \x00\x82\x04\x82\; (set! f2 (cdr f2)) - \x00\x82\x03\x82\; (set! f2 (car f2)) ; f2=lst - \x00\x84\x01\x01\; (set! f4 g1) - \x00\x85\x01\x00\; (set! f5 nil) - \x00\x83\x0b\x82\; (set! f3 (pair? f2)) - \x40\x83\x00\x00\; (goto-end-if f3) - \x00\x84\x01\xff\; (set! f4 k) - \x02\x85\x81\x00"; (set! f5 (cons f1 nil)) - #@"\x84\x85\x00\x00\xfe\xff" + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) ; t0=fn + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (car t1)) ; t2=init + \x00\x00\x04\x01\; (set! t3 (cdr t1)) + \x00\x00\x03\x03\; (set! t4 (car t3)) ; t4=lst + \x00\x00\x0b\x04\; (set! t5 (pair? t4)) + \x00\x70\x05\x81\; (set! t6 (tail-call-if t5 g1)) + \x00\x02\x02\xf1"; (set! t7 (cons t2 nil)) + #@"\xff\x07\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/foldr.rla b/src/lib/primitive/foldr.rla index ebac5e1..91ee720 100644 --- a/src/lib/primitive/foldr.rla +++ b/src/lib/primitive/foldr.rla @@ -26,38 +26,33 @@ #@#S(#="template" ; (lambda (v) (k (fn lstcar v))) #@#() - #@"\x40\x81\xfe\xff" ; i0 f1 ctx k - 1 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x02\x80\x80\x00\; (set! f0 (cons f0 nil)) - \x02\x80\x41\x80"; (set! f0 (cons i1 f0)) - #@"\x40\x80\x00\x00\x42\x43" + #@"\xc0\x01\xfe\xff" ; i0 f1 ctx k + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x02\x00\xf1\; (set! t1 (cons t0 nil)) + \x00\x02\xc1\x01"; (set! t2 (cons i1 t1)) + #@"\xc0\x02\xf1\xf1\xc2\xc3" ) #=0 ; foldr ) - #@"\x80\x81\x82" ; f0=fn f1=init f2=lst - 3 - #@"\x00\x80\x04\x42\; (set! f0 (cdr i2)) - \x00\x81\x03\x42\; (set! f1 (car i2)) - \x02\x82\x80\x00\; (set! f2 (cons f0 nil)) - \x02\x82\x41\x82\; (set! f2 (cons i1 f2)) - \x02\x82\x40\x82"; (set! f2 (cons i0 f2)) - #@"\x02\x82\x00\x00\xfe\x01" + #@"\x00\x02\x04" ; t0=fn t2=init t4=lst + #@"\x00\x00\x04\xc2\; (set! t0 (cdr i2)) + \x00\x00\x03\xc2\; (set! t1 (car i2)) + \x00\x02\x00\xf1\; (set! t2 (cons t0 nil)) + \x00\x02\xc1\x02\; (set! t3 (cons i1 t2)) + \x00\x02\xc0\x03"; (set! t4 (cons i0 t3)) + #@"\x81\x04\xf1\xf1\xfe\x80" ) + #@"\x80\xf1\xf1\xf1\xfe\xff" ) #@#() - 6 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) ; f0=fn - \x00\x82\x04\xfb\; (set! f2 (cdr argv)) - \x00\x81\x03\x82\; (set! f1 (car f2)) ; f1=init - \x00\x82\x04\x82\; (set! f2 (cdr f2)) - \x00\x82\x03\x82\; (set! f2 (car f2)) ; f2=lst - \x00\x84\x01\x01\; (set! f4 g1) - \x00\x85\x01\x00\; (set! f5 nil) - \x00\x83\x0b\x82\; (set! f3 (pair? f2)) - \x40\x83\x00\x00\; (goto-end-if f3) - \x00\x84\x01\xff\; (set! f4 k) - \x02\x85\x81\x00"; (set! f5 (cons f1 nil)) - #@"\x84\x85\x00\x00\xfe\xff" + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) ; t0=fn + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (car t1)) ; t2=init + \x00\x00\x04\x01\; (set! t3 (cdr t1)) + \x00\x00\x03\x03\; (set! t4 (car t3)) ; t4=lst + \x00\x00\x0b\x04\; (set! t5 (pair? t4)) + \x00\x70\x05\x81\; (set! t6 (tail-call-if t5 g1) + \x00\x02\x02\xf1"; (set! t7 (cons t2 nil)) + #@"\xff\x07\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/list.rla b/src/lib/primitive/list.rla index 5ce3cf3..27703fd 100644 --- a/src/lib/primitive/list.rla +++ b/src/lib/primitive/list.rla @@ -7,10 +7,9 @@ #i"cons.rla" ) #@#() - 1 - #@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) - \x02\x80\x00\x80\; (set! f0 (cons nil f0)) - \x02\x80\x02\x80"; (set! f0 (cons g2 f0)) - #@"\x01\x80\x00\x00\xfe\xff" + #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil)) + \x00\x02\xf1\x00\; (set! t1 (cons nil t0)) + \x00\x02\x81\x01"; (set! t2 (cons g1 t1)) + #@"\x80\x02\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/map.rla b/src/lib/primitive/map.rla index c322a3a..66fc315 100644 --- a/src/lib/primitive/map.rla +++ b/src/lib/primitive/map.rla @@ -16,44 +16,40 @@ #@#S(#="template" ; (lambda (y) ; (k (cons y rlst))) - #@#(#f) - #@"\x81\xff" ; f1 k - 1 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x02\x80\x80\x40\; (set! f0 (cons f0 i0)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\x41\x80\x00\x00\x01\x01" + #@#() + #@"\x02\xff" ; t2 k + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x02\x00\xc0\; (set! t1 (cons t0 i0)) + \x00\x02\x01\xf1"; (set! t2 (cons t1 nil)) + #@"\xc1\x02\xf1\xf1\xf0\xf0" ) ) - #@"\x80" - 2 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x00\x81\x04\xfb\; (set! f1 (cdr argv)) - \x00\x81\x03\x81\; (set! f1 (car f1)) - \x00\x81\x1b\x01\; (set! f1 (lambda g1)) - \x02\x80\x80\x00"; (set! f0 (cons f0 nil)) - #@"\x40\x80\x00\x00\xfe\x81" + #@"\x00" + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (car t1)) + \x00\x00\x1b\x80\; (set! t3 (lambda g0)) + \x00\x02\x00\xf1"; (set! t4 (cons t0 nil)) + #@"\xc0\x04\xf1\xf1\xfe\x03" ) #@#S(#="template" ; (lambda (rlst) ; (k (reverse rlst))) #@#(#i"reverse.rla") #@"\xfe\xff" ; ctx k - 0 - #@"" - #@"\x01\xfb\x00\x00\x40\x41" + #f + #@"\x80\xfb\xf1\xf1\xc0\xc1" ) ) #@#() - 4 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x00\x81\x04\xfb\; (set! f1 (cdr argv)) - \x00\x81\x03\x81\; (set! f1 (car f1)) - \x02\x82\x81\x00\; (set! f2 (cons f1 nil)) - \x02\x82\x00\x82\; (set! f2 (cons nil f2)) - \x00\x83\x1b\x02\; (set! f3 (lambda g2)) - \x02\x82\x83\x82\; (set! f2 (cons f3 f2)) - \x00\x83\x1b\x03"; (set! f3 (lambda g3)) - #@"\x01\x82\x00\x00\xfe\x83" + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x00\x04\xfb\; (set! t1 (cdr argv)) + \x00\x00\x03\x01\; (set! t2 (car t1)) + \x00\x02\x02\xf1\; (set! t3 (cons t2 nil)) + \x00\x02\xf1\x03\; (set! t4 (cons nil t3)) + \x00\x00\x1b\x81\; (set! t5 (lambda g1)) + \x00\x02\x05\x04\; (set! t6 (cons t5 t4)) + \x00\x00\x1b\x82"; (set! t7 (lambda g2)) + #@"\x80\x06\xf1\xf1\xfe\x07" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/or.rla b/src/lib/primitive/or.rla index c31ecfe..171fdde 100644 --- a/src/lib/primitive/or.rla +++ b/src/lib/primitive/or.rla @@ -24,28 +24,24 @@ #@#S(#="template" ; (lambda (x) ; ((if x k2 k) x)) - #@#(#f) - #@"\x40\xff" ; i0 k - 1 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x80\x80\x40\x41"; (set! f0 (if f0 i0 i1)) - #@"\x80\xfb\x00\x00\x01\x01" + #@#() + #@"\xc0\xff" ; i0 k + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x10\x00\xc0\xc1"; (set! t1 (if t0 i0 i1)) + #@"\x01\xfb\xf1\xf1\xf0\xf0" ) ) #@"\xff" ; k - 2 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x00\x81\x1b\x01"; (set! f1 (lambda g1)) - #@"\x80\x00\x00\x00\xfe\x81" + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x00\x1b\x80"; (set! t1 (lambda g0)) + #@"\x00\xf1\xf1\xf1\xfe\x01" ) - #f ) #@#() - 2 - #@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) - \x02\x80\x03\x80\; (set! f0 (cons g3 f0)) - \x00\x81\x1b\x02\; (set! f1 (lambda g2)) - \x02\x80\x81\x80"; (set! f0 (cons f1 f0)) - #@"\x01\x80\x00\x00\xfe\xff" + #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil)) + \x00\x02\xf0\x00\; (set! t1 (cons #f t0)) + \x00\x00\x1b\x81\; (set! t2 (lambda g1)) + \x00\x02\x02\x01"; (set! t3 (cons t2 t1)) + #@"\x80\x03\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitive/reverse.rla b/src/lib/primitive/reverse.rla index 2930dda..9bd8a94 100644 --- a/src/lib/primitive/reverse.rla +++ b/src/lib/primitive/reverse.rla @@ -7,11 +7,10 @@ #i"cons.rla" ) #@#() - 1 - #@"\x00\x80\x03\xfb\; (set! f0 (car argv)) - \x02\x80\x80\x00\; (set! f0 (cons f0 nil)) - \x02\x80\x00\x80\; (set! f0 (cons nil f0)) - \x02\x80\x02\x80"; (set! f0 (cons g2 f0)) - #@"\x01\x80\x00\x00\xfe\xff" + #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) + \x00\x02\x00\xf1\; (set! t1 (cons t0 nil)) + \x00\x02\xf1\x01\; (set! t2 (cons nil t1)) + \x00\x02\x81\x02"; (set! t3 (cons g1 t2)) + #@"\x80\x03\xf1\xf1\xfe\xff" ) ; vim:set syntax= sw=2 expandtab: diff --git a/src/lib/primitives.rls b/src/lib/primitives.rls index 430003a..ad9b409 100644 --- a/src/lib/primitives.rls +++ b/src/lib/primitives.rls @@ -1,10 +1,10 @@ ; Function forms of built-in primitives -; Unary value primitives; no side effects (define (unbox x) (unbox x)) +(define (weak-unbox x) (weak-unbox x)) (define (car x) (car x)) (define (cdr x) (cdr x)) -(define (weak-unbox x) (weak-unbox x)) + (define (boolean? x) (boolean? x)) (define (fixnum? x) (fixnum? x)) (define (box? x) (box? x)) @@ -15,19 +15,24 @@ (define (float? x) (float? x)) (define (builtin? x) (builtin? x)) (define (weak-box? x) (weak-box? x)) + (define (make-box x) (make-box x)) (define (make-struct x) (make-struct x)) (define (make-float x) (make-float x)) (define (make-weak-box x) (make-weak-box x)) + (define (not x) (not x)) (define (bit-not x) (bit-not x)) (define (fix- x) (fix- x)) (define (float- x) (float- x)) + (define (vector-size x) (vector-size x)) (define (byte-string-size x) (byte-string-size x)) (define (struct-nslots x) (struct-nslots x)) (define (struct-type x) (struct-type x)) + (define (hash-value x) (hash-value x)) + (define (acos x) (acos x)) (define (asin x) (asin x)) (define (atan x) (atan x)) @@ -61,20 +66,23 @@ (define (expm1 x) (expm1 x)) (define (ilogb x) (ilogb x)) (define (log1p x) (log1p x)) + (define (normal? x) (normal? x)) (define (finite? x) (finite? x)) (define (subnormal? x) (subnormal? x)) (define (infinite? x) (infinite? x)) (define (nan? x) (nan? x)) -; Binary value primitives; no side effects (define (eq? x y) (eq? x y)) + (define (cons x y) (cons x y)) (define (make-vector x y) (make-vector x y)) (define (make-byte-string x y) (make-byte-string x y)) + (define (vector-ref x y) (vector-ref x y)) (define (byte-string-ref x y) (byte-string-ref x y)) (define (struct-ref x y) (struct-ref x y)) + (define (fix+ x y) (fix+ x y)) (define (fix- x y) (fix- x y)) (define (fix* x y) (fix* x y)) @@ -85,12 +93,14 @@ (define (fix> x y) (fix> x y)) (define (fix>= x y) (fix>= x y)) (define (fix<= x y) (fix<= x y)) + (define (bit-and x y) (bit-and x y)) (define (bit-or x y) (bit-or x y)) (define (bit-xor x y) (bit-xor x y)) (define (fix<< x y) (fix<< x y)) (define (fix>> x y) (fix>> x y)) (define (fix>>> x y) (fix>>> x y)) + (define (float+ x y) (float+ x y)) (define (float- x y) (float- x y)) (define (float* x y) (float* x y)) @@ -100,6 +110,7 @@ (define (float> x y) (float> x y)) (define (float>= x y) (float>= x y)) (define (float<= x y) (float<= x y)) + (define (atan2 x y) (atan2 x y)) (define (pow x y) (pow x y)) (define (ldexp x y) (ldexp x y)) @@ -110,19 +121,21 @@ (define (nextafter x y) (nextafter x y)) (define (remainder x y) (remainder x y)) (define (scalb x y) (scalb x y)) + (define (kind-of? x y) (kind-of? x y)) + (define (byte-string= x y) (byte-string= x y)) (define (byte-string< x y) (byte-string< x y)) (define (byte-string> x y) (byte-string> x y)) (define (byte-string>= x y) (byte-string>= x y)) (define (byte-string<= x y) (byte-string<= x y)) -; Binary statement primitives (define (set-box! x y) (set-box! x y)) (define (set-car! x y) (set-car! x y)) (define (set-cdr! x y) (set-cdr! x y)) -; Ternary statement primitives +(define (if x y z) (if x y z)) + (define (vector-set! x y z) (vector-set! x y z)) (define (byte-string-set! x y z) (byte-string-set! x y z)) (define (struct-set! x y z) (struct-set! x y z))