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

Change bytecode from 'frame' vars to 'transient' values. 

Each transient identifies the value of the corresponding previous bytecode.
This change (a) frees up many bytecodes formerly used by the conditional
expression (if c t f); (b) regularizes the bytecode by always placing opcodes
before operands; and (c) causes the bytecode to conform to the Single Static
Assignment (SSA) form preferred by e.g. LLVM.

Includes updates to the hand-assembled files (*.rla) and the bytecode compiler.
This commit is contained in:
Jesse D. McDonald 2011-04-10 13:50:11 -05:00
parent 6da373201c
commit be48535995
34 changed files with 820 additions and 882 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
builtin.c
View File

@ -135,14 +135,14 @@ static void bi_string_to_number(interp_state_t *state)
value_t rval; value_t rval;
str = value_to_string(CAR(state->argv.value)); str = value_to_string(CAR(state->argv.value));
num = strtol(str, &end, 0); num = (fixnum_t)strtoll(str, &end, 0);
free(str);
if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num)) if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num))
rval = fixnum_value(num); rval = fixnum_value(num);
else else
rval = FALSE_VALUE; rval = FALSE_VALUE;
free(str);
interp_return_values(state, cons(rval, NIL)); interp_return_values(state, cons(rval, NIL));
} }

14
builtin.h
View File

@ -25,19 +25,17 @@
/* Lambda: Instances of this structure are fundamental callable objects. */ /* Lambda: Instances of this structure are fundamental callable objects. */
#define LAMBDA_SLOT_GLOBAL_VARS 0 #define LAMBDA_SLOT_GLOBAL_VARS 0
#define LAMBDA_SLOT_INSTANCE_VARS 1 #define LAMBDA_SLOT_INSTANCE_VARS 1
#define LAMBDA_SLOT_FRAME_VARS 2 #define LAMBDA_SLOT_BYTE_CODE 2
#define LAMBDA_SLOT_BYTE_CODE 3 #define LAMBDA_SLOT_TAIL_CALL 3
#define LAMBDA_SLOT_TAIL_CALL 4 #define LAMBDA_SLOTS 4
#define LAMBDA_SLOTS 5
/* Template: Instances of this structure describe what a LAMBDA /* Template: Instances of this structure describe what a LAMBDA
* will look like when instanciated with the 'lambda' bytecode. */ * will look like when instanciated with the 'lambda' bytecode. */
#define TEMPLATE_SLOT_GLOBAL_VARS 0 #define TEMPLATE_SLOT_GLOBAL_VARS 0
#define TEMPLATE_SLOT_INSTANCE_VARS 1 #define TEMPLATE_SLOT_INSTANCE_VARS 1
#define TEMPLATE_SLOT_FRAME_VARS 2 #define TEMPLATE_SLOT_BYTE_CODE 2
#define TEMPLATE_SLOT_BYTE_CODE 3 #define TEMPLATE_SLOT_TAIL_CALL 3
#define TEMPLATE_SLOT_TAIL_CALL 4 #define TEMPLATE_SLOTS 4
#define TEMPLATE_SLOTS 5
value_t get_lambda_type(void); value_t get_lambda_type(void);
value_t get_template_type(void); value_t get_template_type(void);

310
doc/bytecode.txt
View File

@ -1,171 +1,164 @@
top: expression: up to 256, 3 in, no prefix
00xxxxxx out in in: expression 00 sub in in: binary-expr
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
01 (set! out in) 10 (if in1 in2 in3) ; in3 if in1 == #f, in2 otherwise
02 (set! out (unbox in))
03 (set! out (car in))
04 (set! out (cdr in))
05 (set! out (weak-unbox in))
08 (set! out (boolean? in)) ; value => bool 20 (vector-set! in1 in2 in3) ; vector n value, 0 <= n < nelem; ==> in3
09 (set! out (fixnum? in)) ; value => bool 21 (byte-string-set! in1 in2 in3) ; string n value, 0 <= n < nbytes; ==> in3
0a (set! out (box? in)) ; value => bool 22 (struct-set! in1 in2 in3) ; struct n value, 0 <= n < nslots; ==> in3
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
18 (set! out (make-box in)) ; value => box binary-expr: up to 256, 2 in, prefix = 00
19 (set! out (make-struct in)) ; metastruct => struct 00 sub in: unary-expr
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
20 (set! out (not in)) ; if in == #f then #t else #f 01 (eq? in1 in2) ; any values; superset of fix=
21 (set! out (bit-not in)) ; one's complement / bitwise negation 02 (cons in1 in2) ; car cdr
22 (set! out (fix- in)) ; two's complement / arithmetic negation 03 (make-vector in1 in2) ; nelem iv, nelem >= 0
23 (set! out (float- in)) ; floating-point negation 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)) 08 (fix+ in1 in2)
29 (set! out (byte-string-size in)) 09 (fix- in1 in2)
2a (set! out (struct-nslots in)) 0a (fix* in1 in2)
2b (set! out (struct-type in)) 0b (fix/ in1 in2)
2c (set! out (hash-value in)) 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 ; ISO C floating-point
30 (set! out (acos in)) 30 (acos in)
31 (set! out (asin in)) 31 (asin in)
32 (set! out (atan in)) 32 (atan in)
33 (set! out (cos in)) 33 (cos in)
34 (set! out (sin in)) 34 (sin in)
35 (set! out (tan in)) 35 (tan in)
36 (set! out (cosh in)) 36 (cosh in)
37 (set! out (sinh in)) 37 (sinh in)
38 (set! out (tanh in)) 38 (tanh in)
39 (set! out (exp in)) 39 (exp in)
3a (set! out (frexp in)) ; float => (float . fixnum) 3a (frexp in) ; float ==> (float . fixnum)
3b (set! out (log in)) ; base e 3b (log in) ; base e
3c (set! out (log10 in)) 3c (log10 in)
3d (set! out (modf in)) ; float => (float . float) 3d (modf in) ; float ==> (float . float)
3e (set! out (sqrt in)) 3e (sqrt in)
3f (set! out (ceil in)) 3f (ceil in)
40 (set! out (fabs in)) 40 (fabs in)
41 (set! out (floor in)) 41 (floor in)
; SVID & X/Open ; SVID & X/Open
50 (set! out (erf in)) 50 (erf in)
51 (set! out (erfc in)) 51 (erfc in)
; (set! out (gamma in)) ; obsolete ; (gamma in) ; obsolete
52 (set! out (j0 in)) 52 (j0 in)
53 (set! out (j1 in)) 53 (j1 in)
54 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r 54 (lgamma in) ; float ==> (float . fixnum), actually lgamma_r
55 (set! out (y0 in)) 55 (y0 in)
56 (set! out (y1 in)) 56 (y1 in)
; SVID & XPG 4.2/5 ; SVID & XPG 4.2/5
57 (set! out (asinh in)) 57 (asinh in)
58 (set! out (acosh in)) 58 (acosh in)
59 (set! out (atanh in)) 59 (atanh in)
5a (set! out (cbrt in)) 5a (cbrt in)
5b (set! out (logb in)) 5b (logb in)
; XPG 4.2/5 ; XPG 4.2/5
5c (set! out (expm1 in)) 5c (expm1 in)
5d (set! out (ilogb in)) 5d (ilogb in)
5e (set! out (log1p in)) 5e (log1p in)
; (set! out (rint in)) ; implies changing rounding mode; use floor or ceil ; (rint in) ; implies changing rounding mode; use floor or ceil
; C99 ; C99
70 (set! out (normal? in)) 70 (normal? in)
71 (set! out (finite? in)) 71 (finite? in)
72 (set! out (subnormal? in)) 72 (subnormal? in)
73 (set! out (infinite? in)) 73 (infinite? in)
74 (set! out (nan? in)) 74 (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
in: in:
nil (00000000) [g0, always NIL] tN (0NNNNNNN) [transient, 0 <= N < 128, one for each prior expression]
gN (00NNNNNN) [global, N < 64] gN (10NNNNNN) [global, 0 <= N < 64]
iN (01NNNNNN) [instance, N < 64] iN (110NNNNN) [instance, 0 <= N < 32]
fN (1NNNNNNN) [frame, N < 120] iN (1110NNNN) [instance, 32 <= N < 48]
-- (1111100N) [reserved, N < 2] #f (11110000) [constant]
undef (11110001) [constant]
nil (11110010) [constant]
-- (1111xxxx) [reserved, 2 <= x < 10]
self (11111010) [current lambda] self (11111010) [current lambda]
argv (11111011) [argument list] argv (11111011) [argument list]
kw-args (11111100) [keyword arguments] (sorted) kw-args (11111100) [keyword arguments] (sorted)
@ -173,21 +166,16 @@ in:
ctx (11111110) [dynamic context] ctx (11111110) [dynamic context]
k (11111111) [continuation] k (11111111) [continuation]
out:
fN (1NNNNNNN) [0 <= N < 120]
lambda:[ lambda:[
global: vector of immutable values (g1..gN); shared between instances (lambdas) global: vector of immutable values (g0..gN); shared between instances (lambdas)
instance: vector of immutable values (i0..iN); shared between frames (calls) instance: vector of immutable values (i0..iN); shared between calls
frame: number of frame variables; initially #<undefined>
code: byte-string containing sequence of 4-byte instruction words 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) tail-call: byte-string of in-refs: (target argv kw-args kw-vals ctx k)
] ]
template:[ template:[
global: linked global: linked
instance: byte-string of in-refs. to parent instance/frame slots instance: byte-string of in-refs. to parent instance/transient slots
frame: copied verbatim
code: linked code: linked
tail-call: linked tail-call: linked
] ]
@ -234,7 +222,7 @@ call-with-continuation-prompt:
((meta-continuation) result))))))])) ((meta-continuation) result))))))]))
parameterize: parameterize:
Call thunk with 'k' and updated context. Call thunk with 'k' and updated context. (No change to original context.)
New context includes (parameter => value) association. New context includes (parameter ==> value) association.
# vim:set sw=2 expandtab tw=0: # vim:set sw=2 expandtab tw=0:

8
gc.c
View File

@ -1534,6 +1534,10 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
{ {
fputs("#<undefined>", f); fputs("#<undefined>", f);
} }
else if (v == END_PROGRAM)
{
fputs("#<endp>", f);
}
else if (is_fixnum(v)) else if (is_fixnum(v))
{ {
fprintf(f, "%lld", (long long int)get_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].total_ns) / gc_stats.gen[1].passes,
ns2sec(gc_stats.gen[1].max_ns)); ns2sec(gc_stats.gen[1].max_ns));
fprintf(f, "GC: The Gen-1 soft-limit peaked at %d bytes out of %d allocated.\n", fprintf(f, "GC: The Gen-1 soft-limit peaked at %lld bytes out of %lld allocated.\n",
(int)gc_stats.gen1_high_water, (int)gc_gen1_max_size); (long long)gc_stats.gen1_high_water, (long long)gc_gen1_max_size);
} }
else else
{ {

4
gc.h
View File

@ -193,8 +193,8 @@ typedef struct gc_stats
nsec_t max_ns; nsec_t max_ns;
nsec_t max_gen1_ns; nsec_t max_gen1_ns;
llsize_t total_freed; llsize_t total_freed;
} gen[2]; } gen[2];
size_t gen1_high_water; llsize_t gen1_high_water;
} gc_stats_t; } gc_stats_t;
extern gc_stats_t gc_stats; extern gc_stats_t gc_stats;

617
interp.c
View File

@ -18,9 +18,6 @@
/* Shorthand for frequently-used fields */ /* Shorthand for frequently-used fields */
#define _LAMBDA_SLOT(v,s) _SLOT_VALUE(LAMBDA, v, s) #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 * 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 run_byte_code(interp_state_t *state);
static void perform_tail_call(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 get_input(const interp_state_t *state, fixnum_t in);
static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_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 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 get_input(const interp_state_t *state, fixnum_t var); static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_t in);
static void set_output(const interp_state_t *state, fixnum_t var, value_t val);
static void register_state(interp_state_t *state, value_t lambda, value_t argv); static void register_state(interp_state_t *state, value_t lambda, value_t argv);
static void unregister_state(interp_state_t *state); 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). * Now 'lambda' really is a lambda structure instance (or builtin).
*/ */
state.ntransients = 0;
#if 0 #if 0
fflush(stdout); fflush(stdout);
fputc('\n', stderr);
fputs("LAMBDA: ", stderr); fprint_value(stderr, state.lambda.value); 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("ARGLIST: ", stderr); fprint_value(stderr, state.argv.value); fputc('\n', stderr);
fputs("CONTEXT: ", stderr); fprint_value(stderr, state.ctx.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); fputs("CONT'N: ", stderr); fprint_value(stderr, state.k.value); fputc('\n', stderr);
fputc('\n', stderr);
fflush(stderr); fflush(stderr);
#endif #endif
if (is_builtin_fn(state.lambda.value)) if (is_builtin_fn(state.lambda.value))
{ {
/* Builtin functions replace the byte-code and tail-call /* Builtin functions replace the byte-code and tail-call steps. */
* steps; they also do not require frame variables. */
state.nframe = 0;
_get_builtin_fn(state.lambda.value)(&state); _get_builtin_fn(state.lambda.value)(&state);
} }
else else
{ {
release_assert(get_struct(state.lambda.value)->immutable); 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.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.globals.value)->immutable);
release_assert(get_vector(state.instances.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); run_byte_code(&state);
perform_tail_call(&state); perform_tail_call(&state);
} }
/* Clear (used) frame-variable slots so they can be GC'd. */ /* Clear (used) transient slots so they can be GC'd. */
for (fixnum_t i = 0; i < state.nframe; ++i) for (int i = 0; i < state.ntransients; ++i)
_get_vector(state.frame.value)->elements[i] = UNDEFINED; _get_vector(state.transients.value)->elements[i] = UNDEFINED;
/* Clear temporaries. */ /* Clear temporaries. */
state.in1.value = UNDEFINED; state.globals.value = UNDEFINED;
state.in2.value = UNDEFINED;
state.in3.value = UNDEFINED;
state.globals.value = UNDEFINED;
state.instances.value = UNDEFINED; state.instances.value = UNDEFINED;
state.byte_code.value = UNDEFINED;
state.tail_call.value = UNDEFINED;
if (run_finalizers) 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. */ /* All but the instance variables are just shallow-copied. */
ls->slots[LAMBDA_SLOT_GLOBAL_VARS] = ts->slots[TEMPLATE_SLOT_GLOBAL_VARS]; ls->slots[LAMBDA_SLOT_GLOBAL_VARS] = ts->slots[TEMPLATE_SLOT_GLOBAL_VARS];
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_BYTE_CODE] = ts->slots[TEMPLATE_SLOT_BYTE_CODE];
ls->slots[LAMBDA_SLOT_TAIL_CALL] = ts->slots[TEMPLATE_SLOT_TAIL_CALL]; ls->slots[LAMBDA_SLOT_TAIL_CALL] = ts->slots[TEMPLATE_SLOT_TAIL_CALL];
ls->immutable = true; ls->immutable = true;
@ -268,261 +264,298 @@ static void translate_callable(interp_state_t *state)
static void run_byte_code(interp_state_t *state) static void run_byte_code(interp_state_t *state)
{ {
gc_root_t bc_root; if (state->byte_code.value != FALSE_VALUE)
register_gc_root(&bc_root, _LAMBDA_SLOT(state->lambda.value, BYTE_CODE));
if (bc_root.value != FALSE_VALUE)
{ {
release_assert(get_byte_string(bc_root.value)->immutable); uint8_t byte_code[4*128];
release_assert((_get_byte_string(bc_root.value)->size % 4) == 0); int nwords;
for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4)
{ {
uint32_t word; byte_string_t *s = get_byte_string(state->byte_code.value);
uint8_t *bytes = (uint8_t*)&word; release_assert(s->immutable);
release_assert(s->size <= sizeof byte_code);
word = *(uint32_t*)(_get_byte_string(bc_root.value)->bytes + offset); release_assert((s->size % 4) == 0);
switch (bytes[0]) /* Copy byte code to temporary buffer for faster access. */
{ nwords = s->size / 4;
bool cond; memcpy(byte_code, s->bytes, s->size);
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;
}
} }
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) 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; uint8_t bytes[6];
value_t tail_call = _LAMBDA_SLOT(state->lambda.value, TAIL_CALL); 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(state->tail_call.value)->immutable);
release_assert(_get_byte_string(tail_call)->size == 6); 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(&root, make_lambda(state, get_input(state, bytes[0])));
register_gc_root(&new_argv, get_input(state, _get_byte_string(tail_call)->bytes[1])); new_k = make_lambda(state, get_input(state, bytes[5]));
register_gc_root(&new_kw_args, get_input(state, _get_byte_string(tail_call)->bytes[2])); new_lambda = root.value;
register_gc_root(&new_kw_vals, get_input(state, _get_byte_string(tail_call)->bytes[3])); unregister_gc_root(&root);
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]));
/* If new lambda or continuation is a template, instantiate it here */ new_argv = get_input(state, bytes[1]);
new_lambda.value = make_lambda(state, new_lambda.value); new_kw_args = get_input(state, bytes[2]);
new_k.value = make_lambda(state, new_k.value); new_kw_vals = get_input(state, bytes[3]);
new_ctx = get_input(state, bytes[4]);
/* Transfer control to new function */ /* Transfer control to new function; must be after last get_input() */
state->lambda.value = new_lambda.value; state->lambda.value = new_lambda;
state->argv.value = new_argv.value; state->argv.value = new_argv;
state->kw_args.value = new_kw_args.value; state->kw_args.value = new_kw_args;
state->kw_vals.value = new_kw_vals.value; state->kw_vals.value = new_kw_vals;
state->ctx.value = new_ctx.value; state->ctx.value = new_ctx;
state->k.value = new_k.value; state->k.value = new_k;
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);
} }
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); return eval_unary_expression(state, in1, in2);
ST2 = get_input(state, 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) switch (code)
{ {
case 0x00: return eval_unary_expression(state, in1, in2); case 0x00:
case 0x01: return boolean_value(ST1 == ST2); release_assert(NOTREACHED("Fatal error detected."));
case 0x02: return cons(ST1, ST2); return UNDEFINED;
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!"));
}
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) case 0x08: return boolean_value(is_boolean(v1));
{ case 0x09: return boolean_value(is_fixnum(v1));
release_assert(subcode != 0); case 0x0a: return boolean_value(is_box(v1));
ST1 = get_input(state, in); 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 0x18: return make_box(v1);
{ case 0x19: return make_struct(v1);
case 0x01: return ST1; case 0x1a: return make_float((native_float_t)get_fixnum(v1));
case 0x02: return get_box(ST1)->value; case 0x1b: return make_lambda(state, v1);
case 0x03: return get_pair(ST1)->car; case 0x1c: return make_weak_box(v1);
case 0x04: return get_pair(ST1)->cdr;
case 0x05: return get_weak_box(ST1)->value; case 0x20: return boolean_value(!_get_boolean(v1));
case 0x08: return boolean_value(is_boolean(ST1)); case 0x21: return fixnum_value(~get_fixnum(v1));
case 0x09: return boolean_value(is_fixnum(ST1)); case 0x22: return fixnum_value(-get_fixnum(v1));
case 0x0a: return boolean_value(is_box(ST1)); case 0x23: return make_float(-get_float(v1));
case 0x0b: return boolean_value(is_pair(ST1));
case 0x0c: return boolean_value(is_vector(ST1)); case 0x28: return fixnum_value(get_vector(v1)->size);
case 0x0d: return boolean_value(is_byte_string(ST1)); case 0x29: return fixnum_value(get_byte_string(v1)->size);
case 0x0e: return boolean_value(is_struct(ST1)); case 0x2a: return fixnum_value(get_struct(v1)->nslots);
case 0x0f: return boolean_value(is_float(ST1)); case 0x2b: return get_struct(v1)->type;
case 0x10: return boolean_value(is_builtin_fn(ST1)); case 0x2c: return get_hash_value(v1);
case 0x11: return boolean_value(is_weak_box(ST1));
case 0x18: return make_box(ST1); case 0x30: return make_float(acos(get_float(v1)));
case 0x19: return make_struct(ST1); case 0x31: return make_float(asin(get_float(v1)));
case 0x1a: return make_float((native_float_t)get_fixnum(ST1)); case 0x32: return make_float(atan(get_float(v1)));
case 0x1b: return make_lambda(state, ST1); case 0x33: return make_float(cos(get_float(v1)));
case 0x1c: return make_weak_box(ST1); case 0x34: return make_float(sin(get_float(v1)));
case 0x20: return boolean_value(!_get_boolean(ST1)); case 0x35: return make_float(tan(get_float(v1)));
case 0x21: return fixnum_value(~get_fixnum(ST1)); case 0x36: return make_float(cosh(get_float(v1)));
case 0x22: return fixnum_value(-get_fixnum(ST1)); case 0x37: return make_float(sinh(get_float(v1)));
case 0x23: return make_float(-get_float(ST1)); case 0x38: return make_float(tanh(get_float(v1)));
case 0x28: return fixnum_value(get_vector(ST1)->size); case 0x39: return make_float(exp(get_float(v1)));
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 0x3a: { case 0x3a: {
int exp; int exp;
ST2 = make_float(frexp(get_float(ST1), &exp)); value_t v2 = make_float(frexp(get_float(v1), &exp));
return cons(ST2, fixnum_value(exp)); return cons(v2, fixnum_value(exp));
} }
case 0x3b: return make_float(log(get_float(ST1))); case 0x3b: return make_float(log(get_float(v1)));
case 0x3c: return make_float(log10(get_float(ST1))); case 0x3c: return make_float(log10(get_float(v1)));
case 0x3d: { case 0x3d: {
double integral_part; double integral_part;
ST2 = make_float(modf(get_float(ST1), &integral_part)); gc_root_t rv2;
ST3 = make_float(integral_part); value_t v3;
return cons(ST2, ST3);
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 0x3e: return make_float(sqrt(get_float(v1)));
case 0x3f: return make_float(ceil(get_float(ST1))); case 0x3f: return make_float(ceil(get_float(v1)));
case 0x40: return make_float(fabs(get_float(ST1))); case 0x40: return make_float(fabs(get_float(v1)));
case 0x41: return make_float(floor(get_float(ST1))); case 0x41: return make_float(floor(get_float(v1)));
case 0x50: return make_float(erf(get_float(ST1))); case 0x50: return make_float(erf(get_float(v1)));
case 0x51: return make_float(erfc(get_float(ST1))); case 0x51: return make_float(erfc(get_float(v1)));
case 0x52: return make_float(j0(get_float(ST1))); case 0x52: return make_float(j0(get_float(v1)));
case 0x53: return make_float(j1(get_float(ST1))); case 0x53: return make_float(j1(get_float(v1)));
case 0x54: { case 0x54: {
int signgamp; int signgamp;
ST2 = make_float(lgamma_r(get_float(ST1), &signgamp)); value_t v2 = make_float(lgamma_r(get_float(v1), &signgamp));
return cons(ST2, fixnum_value(signgamp)); return cons(v2, fixnum_value(signgamp));
} }
case 0x55: return make_float(y0(get_float(ST1))); case 0x55: return make_float(y0(get_float(v1)));
case 0x56: return make_float(y1(get_float(ST1))); case 0x56: return make_float(y1(get_float(v1)));
case 0x57: return make_float(asinh(get_float(ST1))); case 0x57: return make_float(asinh(get_float(v1)));
case 0x58: return make_float(acosh(get_float(ST1))); case 0x58: return make_float(acosh(get_float(v1)));
case 0x59: return make_float(atanh(get_float(ST1))); case 0x59: return make_float(atanh(get_float(v1)));
case 0x5a: return make_float(cbrt(get_float(ST1))); case 0x5a: return make_float(cbrt(get_float(v1)));
case 0x5b: return make_float(logb(get_float(ST1))); case 0x5b: return make_float(logb(get_float(v1)));
case 0x5c: return make_float(expm1(get_float(ST1))); case 0x5c: return make_float(expm1(get_float(v1)));
case 0x5d: return make_float(ilogb(get_float(ST1))); case 0x5d: return make_float(ilogb(get_float(v1)));
case 0x5e: return make_float(log1p(get_float(ST1))); case 0x5e: return make_float(log1p(get_float(v1)));
case 0x70: return boolean_value(isnormal(get_float(ST1))); case 0x70: return boolean_value(isnormal(get_float(v1)));
case 0x71: return boolean_value(isfinite(get_float(ST1))); case 0x71: return boolean_value(isfinite(get_float(v1)));
case 0x72: return boolean_value(fpclassify(get_float(ST1)) == FP_SUBNORMAL); case 0x72: return boolean_value(fpclassify(get_float(v1)) == FP_SUBNORMAL);
case 0x73: return boolean_value(isinf(get_float(ST1))); case 0x73: return boolean_value(isinf(get_float(v1)));
case 0x74: return boolean_value(isnan(get_float(ST1))); case 0x74: return boolean_value(isnan(get_float(v1)));
default: release_assert(NOTREACHED("Invalid unary sub-bytecode."));
}
return UNDEFINED; default:
} release_assert(NOTREACHED("Invalid unary bytecode."));
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."));
} }
} }
@ -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) static value_t get_input(const interp_state_t *state, fixnum_t var)
{ {
release_assert((var >= 0) && (var <= 255));
switch (var) switch (var)
{ {
case 0: case 0x00 ... 0x7f:
return NIL; {
case 1 ... 63: vector_t *vec = _get_vector(state->transients.value);
release_assert(var < state->ntransients);
return vec->elements[var];
}
case 0x80 ... 0xbf:
{ {
vector_t *vec = _get_vector(state->globals.value); vector_t *vec = _get_vector(state->globals.value);
var -= 1; var -= 0x80;
release_assert(var < vec->size); release_assert(var < vec->size);
return vec->elements[var]; return vec->elements[var];
} }
case 64 ... 127: case 0xc0 ... 0xef:
{ {
vector_t *vec = _get_vector(state->instances.value); vector_t *vec = _get_vector(state->instances.value);
var -= 64; var -= 0xc0;
release_assert(var < vec->size); release_assert(var < vec->size);
return vec->elements[var]; return vec->elements[var];
} }
case 128 ... 247: case 0xf0: return FALSE_VALUE;
{ case 0xf1: return NIL;
vector_t *vec = _get_vector(state->frame.value); case 0xf2: return UNDEFINED;
var -= 128; /* 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: default:
release_assert(NOTREACHED("Invalid input code."));
return UNDEFINED; 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) static void register_state(interp_state_t *state, value_t lambda, value_t argv)
{ {
register_gc_root(&state->lambda, lambda); register_gc_root(&state->lambda, lambda);
register_gc_root(&state->argv, argv); register_gc_root(&state->argv, argv);
register_gc_root(&state->kw_args, NIL); register_gc_root(&state->kw_args, NIL);
register_gc_root(&state->kw_vals, NIL); register_gc_root(&state->kw_vals, NIL);
register_gc_root(&state->ctx, FALSE_VALUE); register_gc_root(&state->ctx, FALSE_VALUE);
register_gc_root(&state->k, END_PROGRAM); register_gc_root(&state->k, END_PROGRAM);
register_gc_root(&state->globals, UNDEFINED); register_gc_root(&state->globals, UNDEFINED);
register_gc_root(&state->instances, UNDEFINED); register_gc_root(&state->instances, UNDEFINED);
register_gc_root(&state->frame, make_vector(120, UNDEFINED)); register_gc_root(&state->byte_code, UNDEFINED);
register_gc_root(&state->in1, UNDEFINED); register_gc_root(&state->tail_call, UNDEFINED);
register_gc_root(&state->in2, UNDEFINED);
register_gc_root(&state->in3, UNDEFINED); register_gc_root(&state->transients, make_vector(128, UNDEFINED));
} }
static void unregister_state(interp_state_t *state) 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->globals);
unregister_gc_root(&state->instances); unregister_gc_root(&state->instances);
unregister_gc_root(&state->frame); unregister_gc_root(&state->byte_code);
unregister_gc_root(&state->in1); unregister_gc_root(&state->tail_call);
unregister_gc_root(&state->in2);
unregister_gc_root(&state->in3); unregister_gc_root(&state->transients);
} }
/* vim:set sw=2 expandtab: */ /* vim:set sw=2 expandtab: */

15
interp.h
View File

@ -6,18 +6,19 @@
typedef struct interp_state typedef struct interp_state
{ {
gc_root_t lambda; gc_root_t lambda;
gc_root_t globals;
gc_root_t instances;
gc_root_t frame;
gc_root_t argv; gc_root_t argv;
gc_root_t kw_args; gc_root_t kw_args;
gc_root_t kw_vals; gc_root_t kw_vals;
gc_root_t ctx; gc_root_t ctx;
gc_root_t k; gc_root_t k;
gc_root_t in1;
gc_root_t in2; gc_root_t globals;
gc_root_t in3; gc_root_t instances;
fixnum_t nframe; gc_root_t byte_code;
gc_root_t tail_call;
gc_root_t transients;
int ntransients;
} interp_state_t; } interp_state_t;
void interpreter_init(void); void interpreter_init(void);

51
libcompiler/mapper.scm
View File

@ -12,19 +12,22 @@
[unused-g-vars global-variables] [unused-g-vars global-variables]
[i-vars '()]) [i-vars '()])
(define (add-g-var value) (define (add-g-var value)
(let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)] (cond
[(symbol? value) `(#%builtin ,(symbol->string value))] [(or (eq? value #f) (equal? value '(quote #f))) '#%f]
[else value])]) [(equal? value '(quote ())) '#%nil]
(let/cc return [else (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)]
(for ([g-var (in-list global-variables)] [(symbol? value) `(#%builtin ,(symbol->string value))]
[val (in-list g-vars)]) [else value])])
(when (eq? value val) (return g-var))) (let/cc return
(let ([g-var (first unused-g-vars)]) (for ([g-var (in-list global-variables)]
(set! unused-g-vars (cdr unused-g-vars)) [val (in-list g-vars)])
(set! g-vars (append g-vars (list value))) (when (eq? value val) (return g-var)))
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)] [var-map (for/list ([free-var (in-list free-vars)]
[inst-var (in-list instance-variables)]) [inst-var (in-list instance-variables)])
(set! i-vars (append i-vars (list free-var))) (set! i-vars (append i-vars (list free-var)))
@ -33,11 +36,25 @@
(set! bind `(#%bind ,(subst* var-map (second bind)) (set! bind `(#%bind ,(subst* var-map (second bind))
,@(map sv* (cddr bind))))) ,@(map sv* (cddr bind)))))
(for ([bound-var (in-list (second bind))] (let* ([var-map (map (lambda (v) (list v '#%undef)) (second bind))]
[frame-var (in-list frame-variables)]) [exprs (for/list ([expr (in-list (cddr bind))]
(define (sv form) (subst-var bound-var frame-var form)) [tvar (in-list transient-variables)])
(set! bind `(#%bind ,(subst bound-var frame-var (second bind)) (if (and (pair? expr) (eq? (first expr) '#%set!))
,@(map sv (cddr bind))))) (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 (set! bind (map-form bind
#:lambda (lambda (recurse op inner-g-vars i-vars bind) #:lambda (lambda (recurse op inner-g-vars i-vars bind)

90
libcompiler/primitives.scm
View File

@ -1,29 +1,27 @@
#lang scheme/base #lang scheme/base
(provide unary-value-primitives (provide unary-primitives
binary-value-primitives binary-primitives
unary-statement-primitives ternary-primitives
binary-statement-primitives side-effect-primitive?
ternary-statement-primitives
value-primitives
statement-primitives
all-primitives all-primitives
transient-variables
global-variables global-variables
instance-variables instance-variables
frame-variables
special-variables special-variables
global-variable? global-variable?
instance-variable? instance-variable?
frame-variable? transient-variable?
special-variable? special-variable?
frame/instance-variable? transient/instance-variable?
machine-variable?) machine-variable?)
(define unary-value-primitives (define unary-primitives
'((#%unbox #x02 unbox) '((#%fatal-error #x00 fatal-error)
(#%unbox #x01 unbox)
(#%weak-unbox #x02 weak-unbox)
(#%car #x03 car) (#%car #x03 car)
(#%cdr #x04 cdr) (#%cdr #x04 cdr)
(#%weak-unbox #x05 weak-unbox)
(#%boolean? #x08 boolean?) (#%boolean? #x08 boolean?)
(#%fixnum? #x09 fixnum?) (#%fixnum? #x09 fixnum?)
(#%box? #x0a box?) (#%box? #x0a box?)
@ -87,7 +85,7 @@
(#%infinite? #x73 infinite?) (#%infinite? #x73 infinite?)
(#%nan? #x74 nan?))) (#%nan? #x74 nan?)))
(define binary-value-primitives (define binary-primitives
'((#%eq? #x01 eq?) '((#%eq? #x01 eq?)
(#%cons #x02 cons) (#%cons #x02 cons)
(#%make-vector #x03 make-vector) (#%make-vector #x03 make-vector)
@ -128,62 +126,54 @@
(#%kind-of? #x30 kind-of?) (#%kind-of? #x30 kind-of?)
(#%byte-string= #x31 byte-string=) (#%byte-string= #x31 byte-string=)
(#%byte-string< #x32 byte-string<) (#%byte-string< #x32 byte-string<)
(#%byte-string>= #x33 byte-string>=))) (#%byte-string>= #x33 byte-string>=)
(#%set-box! #x50 set-box!)
(define unary-statement-primitives
'((#%goto-end-if #x40 #f)
(#%goto-end-unless #x41 #f)))
(define binary-statement-primitives
'((#%set-box! #x50 set-box!)
(#%set-car! #x51 set-car!) (#%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 (define ternary-primitives
'((#%vector-set! #x60 vector-set!) '((#%if #x10 if)
(#%byte-string-set! #x61 byte-string-set!) (#%vector-set! #x20 vector-set!)
(#%struct-set! #x62 struct-set!))) (#%byte-string-set! #x21 byte-string-set!)
(#%struct-set! #x22 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 all-primitives (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 (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))))) (string->uninterned-symbol (string-append "#%g" (number->string i)))))
(define instance-variables (define instance-variables
(for/list ([i (in-range 0 64)]) (for/list ([i (in-range 0 64)])
(string->uninterned-symbol (string-append "#%i" (number->string i))))) (string->uninterned-symbol (string-append "#%i" (number->string i)))))
(define frame-variables (define transient-variables
(for/list ([i (in-range 0 120)]) (for/list ([i (in-range 0 128)])
(string->uninterned-symbol (string-append "#%f" (number->string i))))) (string->uninterned-symbol (string-append "#%t" (number->string i)))))
(define special-variables (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 (global-variable? var) (and (memq var global-variables) #t))
(define (instance-variable? var) (and (memq var instance-variables) #t)) (define (instance-variable? var) (and (memq var instance-variables) #t))
(define (frame-variable? var) (and (memq var frame-variables) #t)) (define (transient-variable? var) (and (memq var transient-variables) #t))
(define (special-variable? var) (and (memq var special-variables) #t)) (define (special-variable? var) (and (memq var special-variables) #t))
(define (frame/instance-variable? var) (define (transient/instance-variable? var)
(or (frame-variable? var) (or (transient-variable? var)
(instance-variable? var))) (instance-variable? var)))
(define (machine-variable? var) (define (machine-variable? var)
(or (special-variable? var) (or (special-variable? var)
(frame/instance-variable? var) (transient/instance-variable? var)
(global-variable? var))) (global-variable? var)))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

5
libcompiler/simplifier.scm
View File

@ -83,8 +83,7 @@
#:value-list same-form #:value-list same-form
#:primitive same-form #:primitive same-form
#:simple (lambda (recurse kind form) form) #:simple (lambda (recurse kind form) form)
#:literal (lambda (recurse kind form) #:literal (lambda (recurse kind form) form)
(if (equal? form '(quote ())) '#%nil form))
#:other simplify-complex-form)) #:other simplify-complex-form))
(define (body->forms body) (define (body->forms body)
@ -491,7 +490,7 @@
(#%set! ,k-argv (#%cons ,k #%nil)) (#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))] (#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))]
; keep all other forms with side-effects as-is ; 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 ; discard any form without side-effects
[_ after])) [_ after]))
`(#%bind ,(second flat-bind) `(#%bind ,(second flat-bind)

22
libcompiler/utilities.scm
View File

@ -14,9 +14,8 @@
literal-value? literal-value?
simple-value? simple-value?
value-form? value-form?
statement-form? side-effect-form?
primitive-form? primitive-form?
pure-form?
bind-form? bind-form?
traverse-form traverse-form
map-form map-form
@ -113,28 +112,23 @@
(literal-value? form))) (literal-value? form)))
; A value-form is any simple form which can appear on the right-hand side of a (set! ...). ; 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 (value-form? form)
(define complex-values '(#%bind #%lambda #%apply #%call/cc #%values #%value-list)) (define complex-values '(#%bind #%lambda #%apply #%call/cc #%values #%value-list))
(or (simple-value? form) (or (simple-value? form)
(memq (first form) complex-values) (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. ; A side-effect-form is any simple form which has, or may have, side-effects.
(define (statement-form? form) (define (side-effect-form? form)
(define complex-statements '(#%set! #%apply #%call/cc #%tail-call)) (define complex-side-effects '(#%set! #%apply #%call/cc #%tail-call))
(and (not (simple-value? form)) (and (not (simple-value? form))
(or (memq (first form) complex-statements) (or (memq (first form) complex-side-effects)
(memq (first form) (map first statement-primitives))))) (side-effect-primitive? (first form)))))
(define (primitive-form? form) (define (primitive-form? form)
(and (pair? form) (memq (first form) (map first all-primitives)))) (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) (define (bind-form? form)
(and (pair? form) (eq? (first form) '#%bind))) (and (pair? form) (eq? (first form) '#%bind)))

83
libcompiler/writer.scm
View File

@ -123,21 +123,21 @@
(let-values ([(line col pos) (port-next-location (current-output-port))]) (let-values ([(line col pos) (port-next-location (current-output-port))])
(parameterize ([current-indent col]) (parameterize ([current-indent col])
(write-string "#@\"") (write-string "#@\"")
(if (eq? (first (first forms)) '#%tail-call) (if (eq? (first (third (first forms))) '#%tail-call)
(begin (begin
(write-char #\") (write-char #\")
(write-tail-call (first forms))) (write-tail-call (third (first forms))))
(let iter ([forms forms]) (let iter ([forms forms])
(map (lambda (x) (write-hex-char x)) (map (lambda (x) (write-hex-char x))
(statement->code (car forms))) (statement->code (car forms)))
(if (eq? (first (second forms)) '#%tail-call) (if (eq? (first (third (second forms))) '#%tail-call)
(begin (begin
(if (verbose-rla?) (if (verbose-rla?)
(begin (begin
(write-string "\"; ") (write-string "\"; ")
(write (car forms))) (write (first forms)))
(write-char #\")) (write-char #\"))
(write-tail-call (second forms))) (write-tail-call (third (second forms))))
(begin (begin
(when (verbose-rla?) (when (verbose-rla?)
(write-string "\\; ") (write-string "\\; ")
@ -181,8 +181,6 @@
(opt-new-line)) (opt-new-line))
(write-string ")"))) (write-string ")")))
(req-new-line) (req-new-line)
(write-rla-val (length (second (fourth value))))
(req-new-line)
(write-rla-bytecode+tail-call (cddr (fourth value)))) (write-rla-bytecode+tail-call (cddr (fourth value))))
(opt-new-line)) (opt-new-line))
(write-string ")"))) (write-string ")")))
@ -252,56 +250,39 @@
[else (error "Don't know how to write Rosella syntax for:" value)])) [else (error "Don't know how to write Rosella syntax for:" value)]))
(define (variable->code var) (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)]) (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))) (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))]) (let ([index (find var '(#%self #%argv #%kw-args #%kw-vals #%ctx #%k))])
(and index (+ #xfa index))) (and index (+ #xfa index)))
(error "No bytecode for variable:" var))) (error "No bytecode for variable:" var)))
(define (statement->code form) (define (statement->code form)
(if (eq? (first form) '#%set!) (let ([vform (third form)]) ; (#%set! #%tNN vform)
(let ([out (variable->code (second form))] (case (length (cdr vform))
[value (third form)]) [(1) (let ([item (assoc (first vform) unary-primitives)])
(cond (or item (error "Invalid unary primitive:" vform))
[(machine-variable? value) (list #x00
(list #x00 out #x01 (variable->code value))] #x00
[(eq? (length (cdr value)) 1) (second item)
(let ([item (assoc (first value) unary-value-primitives)]) (variable->code (second vform))))]
(unless item (error "Invalid unary value primitive:" value)) [(2) (let ([item (assoc (first vform) binary-primitives)])
(list #x00 out (second item) (variable->code (second value))))] (or item (error "Invalid binary primitive:" vform))
[(eq? (length (cdr value)) 2) (list #x00
(let ([item (assoc (first value) binary-value-primitives)]) (second item)
(unless item (error "Invalid binary value primitive:" value)) (variable->code (second vform))
(list* (second item) out (map variable->code (cdr value))))] (variable->code (third vform))))]
[else [(3) (let ([item (assoc (first vform) ternary-primitives)])
(unless (and (eq? (first value) '#%if) (or item (error "Invalid ternary primitive:" vform))
(eq? (length (cdr value)) 3)) (list (second item)
(error "Invalid ternary primitive:" form)) (variable->code (second vform))
(list* out (map variable->code (cdr value)))])) (variable->code (third vform))
(case (length (cdr form)) (variable->code (fourth vform))))]
[(1) (let ([item (assoc (first form) unary-statement-primitives)]) [else (error "Unsupported form:" vform)])))
(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)])))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

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

@ -21,32 +21,26 @@
) )
#@#2=#S(#=1 #@#2=#S(#=1
(#="lambda") (#="lambda")
8 4
#f #f
#@"annotated-lambda" #@"annotated-lambda"
#@#( #@#(
"global-vars" "global-vars"
"instance-vars" "instance-vars"
"frame-vars"
"byte-code" "byte-code"
"tail-call" "tail-call"
"arg-list"
"context"
"continuation"
) )
) )
) )
#@#S(#=2 #@#S(#=2
#@#(("OK") #f) #@#(("OK"))
#@#() #@#()
0 #f
#@"" #@"\xff\x80\xf1\xf1\xf0\xf0"
#@"\xff\x01\x00\x00\x02\x02"
) )
) )
#@#() #@#()
0 #f
#@"" #@"\x81\xfb\xf1\xf1\xfe\xff"
#@"\x02\xfd\xfe\xff"
) )
; vim:set syntax= sw=3 expandtab: ; vim:set syntax= sw=3 expandtab:

10
src/examples/factorial.rla
View File

@ -19,14 +19,12 @@
#i"../lib/math/fact.rla" #i"../lib/math/fact.rla"
) )
#@"\xfe\xff" ; ctx k #@"\xfe\xff" ; ctx k
0 #f
#@"" #@"\x80\xfb\xf1\xf1\xc0\xc1"
#@"\x01\xfb\x00\x00\x40\x41"
) )
) )
#@#() #@#()
0 #f
#@"" #@"\x80\xfb\xf1\xf1\xfe\x81"
#@"\x01\xfb\x00\x00\xfe\x02"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

17
src/examples/test-and.rla
View File

@ -8,16 +8,15 @@
#@#( #@#(
#i"../lib/primitive/and.rla" #i"../lib/primitive/and.rla"
( (
#@#S(#="lambda" #@#(( 3) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#(( 3)) #0=#@#() #f #1=#@"\xff\x80\xf1\xf1\xf0\xf0")
#@#S(#="lambda" #@#((#t) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#((#t)) #=0 #f #=1)
#@#S(#="lambda" #@#(( 4) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#(( 4)) #=0 #f #=1)
#@#S(#="lambda" #@#((#f) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#((#f)) #=0 #f #=1)
#@#S(#="lambda" #@#(( 5) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#(( 5)) #=0 #f #=1)
) )
) )
#@#() #=0
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

7
src/examples/test-append.rla
View File

@ -1,13 +1,12 @@
#@#S(#="lambda" #@#S(#="lambda"
; (define (test-append) ; (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" #i"../lib/primitive/append.rla"
((1 2 3) (4 5) (6 7 8 9)) ((1 2 3) (4 5) (6 7 8 9))
) )
#@#() #@#()
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

20
src/examples/test-foldl.rla
View File

@ -7,23 +7,21 @@
#@#S(#="lambda" #@#S(#="lambda"
; (define (+ x y) ; (define (+ x y)
; (fix+ x y)) ; (fix+ x y))
#@#(#f)
#@#() #@#()
2 #@#()
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv)) \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1)) \x00\x00\x03\x01\; (set! t2 (set! t0 (car t1))
\x08\x80\x80\x81\; (set! f0 (fix+ f0 f1)) \x00\x08\x00\x02\; (set! t3 (fix+ t0 t2))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) \x00\x02\x03\xf1"; (set! t4 (cons t3 nil))
#@"\xff\x80\x00\x00\x01\x01" #@"\xff\x04\xf1\xf1\xf0\xf0"
) )
0 0
(2 3 4 5) (2 3 4 5)
) )
) )
#@#() #@#()
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

20
src/examples/test-foldr.rla
View File

@ -7,23 +7,21 @@
#@#S(#="lambda" #@#S(#="lambda"
; (define (+ x y) ; (define (+ x y)
; (fix+ x y)) ; (fix+ x y))
#@#(#f)
#@#() #@#()
2 #@#()
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv)) \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1)) \x00\x00\x03\x01\; (set! t2 (set! t0 (car t1))
\x08\x80\x80\x81\; (set! f0 (fix+ f0 f1)) \x00\x08\x00\x02\; (set! t3 (fix+ t0 t2))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) \x00\x02\x03\xf1"; (set! t4 (cons t3 nil))
#@"\xff\x80\x00\x00\x01\x01" #@"\xff\x04\xf1\xf1\xf0\xf0"
) )
0 0
(2 3 4 5) (2 3 4 5)
) )
) )
#@#() #@#()
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

5
src/examples/test-list.rla
View File

@ -6,8 +6,7 @@
(1 2 3 4 5) (1 2 3 4 5)
) )
#@#() #@#()
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

5
src/examples/test-map.rla
View File

@ -9,8 +9,7 @@
) )
) )
#@#() #@#()
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

15
src/examples/test-or.rla
View File

@ -8,16 +8,15 @@
#@#( #@#(
#i"../lib/primitive/or.rla" #i"../lib/primitive/or.rla"
( (
#@#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) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#(( 3)) #=0 #f #=1)
#@#S(#="lambda" #@#((#f) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#((#f)) #=0 #f #=1)
#@#S(#="lambda" #@#((#t) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#((#t)) #=0 #f #=1)
#@#S(#="lambda" #@#((#f) #f) #@#() 0 #@"" #@"\xff\x01\x00\x00\x02\x02") #@#S(#="lambda" #@#((#f)) #=0 #f #=1)
) )
) )
#@#() #@#()
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

5
src/examples/test-reverse.rla
View File

@ -6,8 +6,7 @@
((2 3 4 5)) ((2 3 4 5))
) )
#@#() #@#()
0 #f
#@"" #@"\x80\x81\xf1\xf1\xfe\xff"
#@"\x01\x02\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

38
src/lib/math/fact.rla
View File

@ -13,11 +13,10 @@
1 1
#@#S(#="lambda" #@#S(#="lambda"
; (lambda _ 1) ; (lambda _ 1)
#@#((1) #f) #@#((1))
#@#() #@#()
0 #f
#@"" #@"\xff\x80\xf1\xf1\xf0\xf0"
#@"\xff\x01\x00\x00\x02\x02"
) )
#@#S(#="template" #@#S(#="template"
; (let [n] ; (let [n]
@ -33,28 +32,25 @@
; (let/cc k ; (let/cc k
; (lambda (m) ; (lambda (m)
; (k (* n m))))) ; (k (* n m)))))
#@#(#f) #@#()
#@"\x40\xff" ; i0 k #@"\xc0\xff" ; i0 k
1 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x0a\xc0\x00\; (set! t1 (fix* i0 t0))
\x0a\x80\x40\x80\; (set! f0 (fix* i0 f0)) \x00\x02\x01\xf1"; (set! t2 (cons t1 nil))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) #@"\xc1\x02\xf1\xf1\xf0\xf0"
#@"\x41\x80\x00\x00\x01\x01"
) )
#=0 ; fact #=0 ; fact
) )
#@"\x80" #@"\x00"
1 #@"\x00\x09\xc0\x80\; (set! t0 (fix- i0 g0))
#@"\x09\x80\x40\x01\; (set! f0 (fix- i0 g1)) \x00\x02\x00\xf1"; (set! t1 (cons t0 nil))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) #@"\x82\x01\xf1\xf1\xfe\x81"
#@"\x03\x80\x00\x00\xfe\x02"
) )
) )
#@#() #@#()
2 #@"\x00\x00\x03\xfb\; (set! f0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x0d\x00\x80\; (set! f1 (fix< t0 g0))
\x0d\x81\x80\x01\; (set! f1 (fix< f0 g1)) \x10\x01\x81\x82"; (set! f1 (if t1 g1 g2))
\x81\x81\x02\x03"; (set! f1 (if f1 g2 g3)) #@"\x02\xf1\xf1\xf1\xfe\xff"
#@"\x81\x00\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

21
src/lib/primitive/acons.rla
View File

@ -1,17 +1,16 @@
#@#S(#="lambda" #@#S(#="lambda"
; (define (acons a b lst) ; (define (acons a b lst)
; (cons a (cons b lst))) ; (cons a (cons b lst)))
#@#(#f)
#@#() #@#()
3 #@#()
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
\x00\x82\x04\xfb\; (set! f2 (cdr argv)) \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x81\x03\x82\; (set! f1 (car f2)) \x00\x00\x03\x01\; (set! t2 (car t1))
\x00\x82\x04\x82\; (set! f2 (cdr f2)) \x00\x00\x04\x01\; (set! t3 (cdr t1))
\x00\x82\x03\x82\; (set! f2 (car f2)) \x00\x00\x03\x03\; (set! t4 (car t2))
\x02\x81\x81\x82\; (set! f1 (cons f1 f2)) \x00\x02\x02\x04\; (set! t5 (cons t2 t4))
\x02\x80\x80\x81\; (set! f0 (cons f0 f1)) \x00\x02\x00\x05\; (set! t6 (cons t0 t5))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) \x00\x02\x06\xf1"; (set! t7 (cons t6 nil))
#@"\xff\x80\x00\x00\x01\x01" #@"\xff\x07\xf1\xf1\xf0\xf0"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

28
src/lib/primitive/and.rla
View File

@ -24,27 +24,23 @@
#@#S(#="template" #@#S(#="template"
; (lambda (x) ; (lambda (x)
; ((if x k2 k) x)) ; ((if x k2 k) x))
#@#(#f) #@#()
#@"\x40\xff" ; i0 k #@"\xc0\xff" ; i0 k
1 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x10\x00\xc1\xc0"; (set! t1 (if t0 i1 i0))
\x80\x80\x41\x40"; (set! f0 (if f0 i1 i0)) #@"\x01\xfb\xf1\xf1\xf0\xf0"
#@"\x80\xfb\x00\x00\x01\x01"
) )
) )
#@"\xff" ; k #@"\xff" ; k
1 #@"\x00\x00\x03\xfb"; (set! t0 (car argv))
#@"\x00\x80\x03\xfb"; (set! f0 (car argv)) #@"\x00\xf1\xf1\xf1\xfe\x80"
#@"\x80\x00\x00\x00\xfe\x01"
) )
#t
) )
#@#() #@#()
2 #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil))
#@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) \x00\x02\xf0\x00\; (set! t1 (cons g2 t0))
\x02\x80\x03\x80\; (set! f0 (cons g3 f0)) \x00\x00\x1b\x81\; (set! t2 (lambda g1))
\x00\x81\x1b\x02\; (set! f1 (lambda g2)) \x00\x02\x02\x01"; (set! t3 (cons t2 t1))
\x02\x80\x81\x80"; (set! f0 (cons f1 f0)) #@"\x80\x03\xf1\xf1\xfe\xff"
#@"\x01\x80\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

24
src/lib/primitive/append.rla
View File

@ -15,21 +15,19 @@
#i"cons.rla" #i"cons.rla"
) )
#@#() #@#()
2 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x02\x00\xf1\; (set! t1 (cons t0 nil))
\x02\x81\x80\x00\; (set! f1 (cons f0 nil)) \x00\x00\x04\xfb\; (set! t2 (cdr argv))
\x00\x80\x04\xfb\; (set! f0 (cdr argv)) \x00\x00\x03\x02\; (set! t3 (car t2))
\x00\x80\x03\x80\; (set! f0 (car f0)) \x00\x02\x03\x01\; (set! t4 (cons t3 t1))
\x02\x81\x80\x81\; (set! f1 (cons f0 f1)) \x00\x02\x81\x04"; (set! t5 (cons g1 t4))
\x02\x81\x02\x81"; (set! f1 (cons g2 f1)) #@"\x80\x05\xf1\xf1\xfe\xff"
#@"\x01\x81\x00\x00\xfe\xff"
) )
) )
#@#() #@#()
1 #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil))
#@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) \x00\x02\xf1\x00\; (set! t1 (cons nil t0))
\x02\x80\x00\x80\; (set! f0 (cons nil f0)) \x00\x02\x81\x01"; (set! t2 (cons g1 t1))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0)) #@"\x80\x02\xf1\xf1\xfe\xff"
#@"\x01\x80\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

15
src/lib/primitive/cons.rla
View File

@ -1,14 +1,13 @@
#@#S(#="lambda" #@#S(#="lambda"
; (define (cons x y) ; (define (cons x y)
; (builtin-cons x y)) ; (builtin-cons x y))
#@#(#f)
#@#() #@#()
2 #@#()
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv)) \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1)) \x00\x00\x03\x01\; (set! t2 (car t1))
\x02\x80\x80\x81\; (set! f0 (cons f0 f1)) \x00\x02\x00\x02\; (set! t3 (cons t0 t2))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) \x00\x02\x03\xf1"; (set! t4 (cons t3 nil))
#@"\xff\x80\x00\x00\x01\x01" #@"\xff\x04\xf1\xf1\xf0\xf0"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

57
src/lib/primitive/foldl.rla
View File

@ -25,45 +25,32 @@
; (lambda (new-init) ; (lambda (new-init)
; (k (foldl fn new-init (cdr lst)))) ; (k (foldl fn new-init (cdr lst))))
#@#(#=0) #@#(#=0)
#@"\x40\x41\x42\xfe\xff" ; i0 i1 i2 ctx k #@"\xc0\xc1\xc2\xfe\xff" ; i0 i1 i2 ctx k
2 #@"\x00\x00\x04\xc2\; (set! t0 (cdr i2))
#@"\x00\x80\x04\x42\; (set! f0 (cdr i2)) \x00\x02\x00\xf1\; (set! t1 (cons t0 nil))
\x02\x80\x80\x00\; (set! f0 (cons f0 nil)) \x00\x00\x03\xfb\; (set! t2 (car argv))
\x00\x81\x03\xfb\; (set! f1 (car argv)) \x00\x02\x02\x01\; (set! t3 (cons t2 t1))
\x02\x80\x81\x80\; (set! f0 (cons f1 f0)) \x00\x02\xc0\x03"; (set! t4 (cons i0 t3))
\x02\x80\x40\x80"; (set! f0 (cons i0 f0)) #@"\x80\x04\xf1\xf1\xc3\xc4"
#@"\x01\x80\x00\x00\x43\x44"
) )
) )
#@"\x80\x81\x82" ; f0=fn f1=init f2=lst #@"\x00\x02\x04" ; t0=fn t2=init t4=lst
2 #@"\x00\x02\xc1\xf1\; (set! t0 (cons i1 nil))
#@"\x02\x80\x41\x00\; (set! f0 (cons i1 nil)) \x00\x00\x03\xc2\; (set! t1 (car i2))
\x00\x81\x03\x42\; (set! f1 (car i2)) \x00\x02\x01\x00"; (set! t2 (cons t1 t0))
\x02\x80\x81\x80"; (set! f0 (cons f1 f0)) #@"\xc0\x02\xf1\xf1\xfe\x80"
#@"\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"
) )
#@"\x80\xf1\xf1\xf1\xfe\xff"
) )
#@#() #@#()
6 #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) ; t0=fn
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) ; f0=fn \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x82\x04\xfb\; (set! f2 (cdr argv)) \x00\x00\x03\x01\; (set! t2 (car t1)) ; t2=init
\x00\x81\x03\x82\; (set! f1 (car f2)) ; f1=init \x00\x00\x04\x01\; (set! t3 (cdr t1))
\x00\x82\x04\x82\; (set! f2 (cdr f2)) \x00\x00\x03\x03\; (set! t4 (car t3)) ; t4=lst
\x00\x82\x03\x82\; (set! f2 (car f2)) ; f2=lst \x00\x00\x0b\x04\; (set! t5 (pair? t4))
\x00\x84\x01\x01\; (set! f4 g1) \x00\x70\x05\x81\; (set! t6 (tail-call-if t5 g1))
\x00\x85\x01\x00\; (set! f5 nil) \x00\x02\x02\xf1"; (set! t7 (cons t2 nil))
\x00\x83\x0b\x82\; (set! f3 (pair? f2)) #@"\xff\x07\xf1\xf1\xfe\xff"
\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"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

49
src/lib/primitive/foldr.rla
View File

@ -26,38 +26,33 @@
#@#S(#="template" #@#S(#="template"
; (lambda (v) (k (fn lstcar v))) ; (lambda (v) (k (fn lstcar v)))
#@#() #@#()
#@"\x40\x81\xfe\xff" ; i0 f1 ctx k #@"\xc0\x01\xfe\xff" ; i0 f1 ctx k
1 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x02\x00\xf1\; (set! t1 (cons t0 nil))
\x02\x80\x80\x00\; (set! f0 (cons f0 nil)) \x00\x02\xc1\x01"; (set! t2 (cons i1 t1))
\x02\x80\x41\x80"; (set! f0 (cons i1 f0)) #@"\xc0\x02\xf1\xf1\xc2\xc3"
#@"\x40\x80\x00\x00\x42\x43"
) )
#=0 ; foldr #=0 ; foldr
) )
#@"\x80\x81\x82" ; f0=fn f1=init f2=lst #@"\x00\x02\x04" ; t0=fn t2=init t4=lst
3 #@"\x00\x00\x04\xc2\; (set! t0 (cdr i2))
#@"\x00\x80\x04\x42\; (set! f0 (cdr i2)) \x00\x00\x03\xc2\; (set! t1 (car i2))
\x00\x81\x03\x42\; (set! f1 (car i2)) \x00\x02\x00\xf1\; (set! t2 (cons t0 nil))
\x02\x82\x80\x00\; (set! f2 (cons f0 nil)) \x00\x02\xc1\x02\; (set! t3 (cons i1 t2))
\x02\x82\x41\x82\; (set! f2 (cons i1 f2)) \x00\x02\xc0\x03"; (set! t4 (cons i0 t3))
\x02\x82\x40\x82"; (set! f2 (cons i0 f2)) #@"\x81\x04\xf1\xf1\xfe\x80"
#@"\x02\x82\x00\x00\xfe\x01"
) )
#@"\x80\xf1\xf1\xf1\xfe\xff"
) )
#@#() #@#()
6 #@"\x00\x00\x03\xfb\; (set! t0 (car argv)) ; t0=fn
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) ; f0=fn \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x82\x04\xfb\; (set! f2 (cdr argv)) \x00\x00\x03\x01\; (set! t2 (car t1)) ; t2=init
\x00\x81\x03\x82\; (set! f1 (car f2)) ; f1=init \x00\x00\x04\x01\; (set! t3 (cdr t1))
\x00\x82\x04\x82\; (set! f2 (cdr f2)) \x00\x00\x03\x03\; (set! t4 (car t3)) ; t4=lst
\x00\x82\x03\x82\; (set! f2 (car f2)) ; f2=lst \x00\x00\x0b\x04\; (set! t5 (pair? t4))
\x00\x84\x01\x01\; (set! f4 g1) \x00\x70\x05\x81\; (set! t6 (tail-call-if t5 g1)
\x00\x85\x01\x00\; (set! f5 nil) \x00\x02\x02\xf1"; (set! t7 (cons t2 nil))
\x00\x83\x0b\x82\; (set! f3 (pair? f2)) #@"\xff\x07\xf1\xf1\xfe\xff"
\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"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

9
src/lib/primitive/list.rla
View File

@ -7,10 +7,9 @@
#i"cons.rla" #i"cons.rla"
) )
#@#() #@#()
1 #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil))
#@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) \x00\x02\xf1\x00\; (set! t1 (cons nil t0))
\x02\x80\x00\x80\; (set! f0 (cons nil f0)) \x00\x02\x81\x01"; (set! t2 (cons g1 t1))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0)) #@"\x80\x02\xf1\xf1\xfe\xff"
#@"\x01\x80\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

52
src/lib/primitive/map.rla
View File

@ -16,44 +16,40 @@
#@#S(#="template" #@#S(#="template"
; (lambda (y) ; (lambda (y)
; (k (cons y rlst))) ; (k (cons y rlst)))
#@#(#f) #@#()
#@"\x81\xff" ; f1 k #@"\x02\xff" ; t2 k
1 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x02\x00\xc0\; (set! t1 (cons t0 i0))
\x02\x80\x80\x40\; (set! f0 (cons f0 i0)) \x00\x02\x01\xf1"; (set! t2 (cons t1 nil))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) #@"\xc1\x02\xf1\xf1\xf0\xf0"
#@"\x41\x80\x00\x00\x01\x01"
) )
) )
#@"\x80" #@"\x00"
2 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv)) \x00\x00\x03\x01\; (set! t2 (car t1))
\x00\x81\x03\x81\; (set! f1 (car f1)) \x00\x00\x1b\x80\; (set! t3 (lambda g0))
\x00\x81\x1b\x01\; (set! f1 (lambda g1)) \x00\x02\x00\xf1"; (set! t4 (cons t0 nil))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil)) #@"\xc0\x04\xf1\xf1\xfe\x03"
#@"\x40\x80\x00\x00\xfe\x81"
) )
#@#S(#="template" #@#S(#="template"
; (lambda (rlst) ; (lambda (rlst)
; (k (reverse rlst))) ; (k (reverse rlst)))
#@#(#i"reverse.rla") #@#(#i"reverse.rla")
#@"\xfe\xff" ; ctx k #@"\xfe\xff" ; ctx k
0 #f
#@"" #@"\x80\xfb\xf1\xf1\xc0\xc1"
#@"\x01\xfb\x00\x00\x40\x41"
) )
) )
#@#() #@#()
4 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x00\x04\xfb\; (set! t1 (cdr argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv)) \x00\x00\x03\x01\; (set! t2 (car t1))
\x00\x81\x03\x81\; (set! f1 (car f1)) \x00\x02\x02\xf1\; (set! t3 (cons t2 nil))
\x02\x82\x81\x00\; (set! f2 (cons f1 nil)) \x00\x02\xf1\x03\; (set! t4 (cons nil t3))
\x02\x82\x00\x82\; (set! f2 (cons nil f2)) \x00\x00\x1b\x81\; (set! t5 (lambda g1))
\x00\x83\x1b\x02\; (set! f3 (lambda g2)) \x00\x02\x05\x04\; (set! t6 (cons t5 t4))
\x02\x82\x83\x82\; (set! f2 (cons f3 f2)) \x00\x00\x1b\x82"; (set! t7 (lambda g2))
\x00\x83\x1b\x03"; (set! f3 (lambda g3)) #@"\x80\x06\xf1\xf1\xfe\x07"
#@"\x01\x82\x00\x00\xfe\x83"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

30
src/lib/primitive/or.rla
View File

@ -24,28 +24,24 @@
#@#S(#="template" #@#S(#="template"
; (lambda (x) ; (lambda (x)
; ((if x k2 k) x)) ; ((if x k2 k) x))
#@#(#f) #@#()
#@"\x40\xff" ; i0 k #@"\xc0\xff" ; i0 k
1 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x10\x00\xc0\xc1"; (set! t1 (if t0 i0 i1))
\x80\x80\x40\x41"; (set! f0 (if f0 i0 i1)) #@"\x01\xfb\xf1\xf1\xf0\xf0"
#@"\x80\xfb\x00\x00\x01\x01"
) )
) )
#@"\xff" ; k #@"\xff" ; k
2 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x00\x1b\x80"; (set! t1 (lambda g0))
\x00\x81\x1b\x01"; (set! f1 (lambda g1)) #@"\x00\xf1\xf1\xf1\xfe\x01"
#@"\x80\x00\x00\x00\xfe\x81"
) )
#f
) )
#@#() #@#()
2 #@"\x00\x02\xfb\xf1\; (set! t0 (cons argv nil))
#@"\x02\x80\xfb\x00\; (set! f0 (cons argv nil)) \x00\x02\xf0\x00\; (set! t1 (cons #f t0))
\x02\x80\x03\x80\; (set! f0 (cons g3 f0)) \x00\x00\x1b\x81\; (set! t2 (lambda g1))
\x00\x81\x1b\x02\; (set! f1 (lambda g2)) \x00\x02\x02\x01"; (set! t3 (cons t2 t1))
\x02\x80\x81\x80"; (set! f0 (cons f1 f0)) #@"\x80\x03\xf1\xf1\xfe\xff"
#@"\x01\x80\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

11
src/lib/primitive/reverse.rla
View File

@ -7,11 +7,10 @@
#i"cons.rla" #i"cons.rla"
) )
#@#() #@#()
1 #@"\x00\x00\x03\xfb\; (set! t0 (car argv))
#@"\x00\x80\x03\xfb\; (set! f0 (car argv)) \x00\x02\x00\xf1\; (set! t1 (cons t0 nil))
\x02\x80\x80\x00\; (set! f0 (cons f0 nil)) \x00\x02\xf1\x01\; (set! t2 (cons nil t1))
\x02\x80\x00\x80\; (set! f0 (cons nil f0)) \x00\x02\x81\x02"; (set! t3 (cons g1 t2))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0)) #@"\x80\x03\xf1\xf1\xfe\xff"
#@"\x01\x80\x00\x00\xfe\xff"
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

23
src/lib/primitives.rls
View File

@ -1,10 +1,10 @@
; Function forms of built-in primitives ; Function forms of built-in primitives
; Unary value primitives; no side effects
(define (unbox x) (unbox x)) (define (unbox x) (unbox x))
(define (weak-unbox x) (weak-unbox x))
(define (car x) (car x)) (define (car x) (car x))
(define (cdr x) (cdr x)) (define (cdr x) (cdr x))
(define (weak-unbox x) (weak-unbox x))
(define (boolean? x) (boolean? x)) (define (boolean? x) (boolean? x))
(define (fixnum? x) (fixnum? x)) (define (fixnum? x) (fixnum? x))
(define (box? x) (box? x)) (define (box? x) (box? x))
@ -15,19 +15,24 @@
(define (float? x) (float? x)) (define (float? x) (float? x))
(define (builtin? x) (builtin? x)) (define (builtin? x) (builtin? x))
(define (weak-box? x) (weak-box? x)) (define (weak-box? x) (weak-box? x))
(define (make-box x) (make-box x)) (define (make-box x) (make-box x))
(define (make-struct x) (make-struct x)) (define (make-struct x) (make-struct x))
(define (make-float x) (make-float x)) (define (make-float x) (make-float x))
(define (make-weak-box x) (make-weak-box x)) (define (make-weak-box x) (make-weak-box x))
(define (not x) (not x)) (define (not x) (not x))
(define (bit-not x) (bit-not x)) (define (bit-not x) (bit-not x))
(define (fix- x) (fix- x)) (define (fix- x) (fix- x))
(define (float- x) (float- x)) (define (float- x) (float- x))
(define (vector-size x) (vector-size x)) (define (vector-size x) (vector-size x))
(define (byte-string-size x) (byte-string-size x)) (define (byte-string-size x) (byte-string-size x))
(define (struct-nslots x) (struct-nslots x)) (define (struct-nslots x) (struct-nslots x))
(define (struct-type x) (struct-type x)) (define (struct-type x) (struct-type x))
(define (hash-value x) (hash-value x)) (define (hash-value x) (hash-value x))
(define (acos x) (acos x)) (define (acos x) (acos x))
(define (asin x) (asin x)) (define (asin x) (asin x))
(define (atan x) (atan x)) (define (atan x) (atan x))
@ -61,20 +66,23 @@
(define (expm1 x) (expm1 x)) (define (expm1 x) (expm1 x))
(define (ilogb x) (ilogb x)) (define (ilogb x) (ilogb x))
(define (log1p x) (log1p x)) (define (log1p x) (log1p x))
(define (normal? x) (normal? x)) (define (normal? x) (normal? x))
(define (finite? x) (finite? x)) (define (finite? x) (finite? x))
(define (subnormal? x) (subnormal? x)) (define (subnormal? x) (subnormal? x))
(define (infinite? x) (infinite? x)) (define (infinite? x) (infinite? x))
(define (nan? x) (nan? x)) (define (nan? x) (nan? x))
; Binary value primitives; no side effects
(define (eq? x y) (eq? x y)) (define (eq? x y) (eq? x y))
(define (cons x y) (cons x y)) (define (cons x y) (cons x y))
(define (make-vector x y) (make-vector x y)) (define (make-vector x y) (make-vector x y))
(define (make-byte-string x y) (make-byte-string x y)) (define (make-byte-string x y) (make-byte-string x y))
(define (vector-ref x y) (vector-ref x y)) (define (vector-ref x y) (vector-ref x y))
(define (byte-string-ref x y) (byte-string-ref x y)) (define (byte-string-ref x y) (byte-string-ref x y))
(define (struct-ref x y) (struct-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)) (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 (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-and x y) (bit-and x y))
(define (bit-or x y) (bit-or x y)) (define (bit-or x y) (bit-or x y))
(define (bit-xor x y) (bit-xor 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 (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)) (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 (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 (atan2 x y) (atan2 x y))
(define (pow x y) (pow x y)) (define (pow x y) (pow x y))
(define (ldexp x y) (ldexp x y)) (define (ldexp x y) (ldexp x y))
@ -110,19 +121,21 @@
(define (nextafter x y) (nextafter x y)) (define (nextafter x y) (nextafter x y))
(define (remainder x y) (remainder x y)) (define (remainder x y) (remainder x y))
(define (scalb x y) (scalb x y)) (define (scalb x y) (scalb x y))
(define (kind-of? x y) (kind-of? 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)) (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-box! x y) (set-box! x y))
(define (set-car! x y) (set-car! x y)) (define (set-car! x y) (set-car! x y))
(define (set-cdr! x y) (set-cdr! 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 (vector-set! x y z) (vector-set! x y z))
(define (byte-string-set! x y z) (byte-string-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)) (define (struct-set! x y z) (struct-set! x y z))