├── .gitignore ├── Makefile ├── README.txt ├── check.c ├── check.h ├── compile.c ├── compile.h ├── continue.c ├── continue.h ├── eval.c ├── eval.h ├── fail.c ├── fail.h ├── gc.c ├── gc.h ├── hash.c ├── hash.h ├── jit.c ├── jit.h ├── lookup.c ├── lookup.h ├── main.c ├── print.c ├── print.h ├── struct.c ├── struct.h ├── test.c └── test.h /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | mr 3 | *~ 4 | #*# 5 | make_jit 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | OBJS = main.o lookup.o hash.o struct.o eval.o compile.o jit.o print.o fail.o continue.o gc.o check.o test.o 3 | HEADERS = lookup.h hash.h fail.h struct.h continue.h jit.h gc.h compile.h check.h test.h 4 | CFLAGS = -O2 -g -Wall 5 | 6 | mr : $(OBJS) 7 | $(CC) -o mr $(OBJS) $(LDFLAGS) $(LIBS) 8 | 9 | main.o : $(HEADERS) 10 | eval.o : $(HEADERS) 11 | compile.o : $(HEADERS) 12 | jit.o : $(HEADERS) 13 | print.o : $(HEADERS) 14 | lookup.o : $(HEADERS) 15 | struct.o : struct.h gc.h 16 | fail.o : fail.h 17 | hash.o : hash.h 18 | check.o : $(HEADERS) 19 | test.o : $(HEADERS) 20 | gc.o : $(HEADERS) 21 | 22 | clean: 23 | rm -f *.o mr 24 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | This is an interpreter in C for a mini Scheme/Racket language that 2 | support functions, numbers, `if0`, and a top-level table of 3 | definitions --- and a just-in-time (JIT) compiler to machine code that 4 | specializes frequently called closures. 5 | 6 | There's no reader. Programs are constructed direct in AST form using a 7 | C API, as demonstrated in "test.c". 8 | 9 | Continuations are explicit. A standard eval--continue interpreter is 10 | implemented in "eval.c". 11 | 12 | Memory is managed with a two-space copying collector. The test suite 13 | allocates an AST before the GC is enabled so that all the test 14 | variables don't have to be registered as GC roots. 15 | 16 | Numbers are encoded either as record or using a fixnum encoding where 17 | the low bit is set to indicate a number instead of a pointer. 18 | Configure with `FIXNUM_ENCODING` in "struct.h". The fixnum encoding is 19 | required for native-code JIT mode. 20 | 21 | The evaluator supports an optional compilation pass that converts a 22 | local-variable reference to a De Bruijn index and substitutes a 23 | top-level reference with its value (which creates a cyclic structure 24 | for a recursive function). This compiler is already a kind of 25 | just-in-time compiler, because it relies on having values for 26 | top-level definitions. 27 | 28 | A JIT compiler to machine code is supported when `USE_JIT` is defined 29 | to 1 and when linked with GNU lightning. To build in that mode, build 30 | with something like 31 | 32 | make CPPFLAGS="-DUSE_JIT=1" LIBS="-llightning" 33 | 34 | The JIT specializes closures by recompiling the closure body (taking 35 | into accunt actual values in the closure) after a closure is called 36 | `SPECIALIZE_AFTER_COUNT` times. This specialization pass inlines 37 | simple functions. Setting `SPECIALIZE_AFTER_COUNT` to -1 effectively 38 | disables specialization. 39 | 40 | Naturally, the "test.c" examples include variants of `fib`. Change 41 | "main.c" to run test_Y_fib() or test_alt_fib() to try variants. 42 | Specialization does little for Y-combinator recursion, but it 43 | eliminates the abstraction overhead for the "alt" variant. 44 | -------------------------------------------------------------------------------- /check.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "struct.h" 5 | #include "print.h" 6 | #include "fail.h" 7 | 8 | void check_ptr(void* a, void* b) 9 | { 10 | if (a != b) { 11 | fail("failed ptr"); 12 | } 13 | } 14 | 15 | void check_num_val(tagged* r, int n) 16 | { 17 | if (TAGGED_TYPE(r) != num_type) { 18 | printf("not a number: "); 19 | } else { 20 | if (n != NUM_VAL(r)) 21 | printf("not expected number %d: ", n); 22 | else 23 | return; 24 | } 25 | print_val(r); 26 | fail("failed num_val"); 27 | } 28 | 29 | void check_func_val(tagged* r) 30 | { 31 | if (TAGGED_TYPE(r) != func_type) { 32 | printf("not a function: "); 33 | print_val(r); 34 | fail("failed func_val"); 35 | } 36 | } 37 | 38 | -------------------------------------------------------------------------------- /check.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __CHECK_H__ 3 | #define __CHECK_H__ 4 | 5 | #include "struct.h" 6 | 7 | void check_ptr(void* a, void* b); 8 | void check_num_val(tagged* r, int n); 9 | void check_func_val(tagged* r); 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /compile.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "compile.h" 3 | #include "lookup.h" 4 | #include "fail.h" 5 | 6 | tagged* compile(tagged* expr, env* e, hash_table* d) 7 | { 8 | switch (TAGGED_TYPE(expr)) { 9 | case num_type: 10 | case func_type: 11 | return expr; 12 | case sym_type: 13 | { 14 | int pos; 15 | 16 | pos = env_lookup_pos((symbol *)expr, e); 17 | if (pos == -1) 18 | return lookup(d, (symbol *)expr); 19 | else 20 | return make_debruijn(pos); 21 | } 22 | case plus_type: 23 | case minus_type: 24 | case times_type: 25 | case app_type: 26 | { 27 | bin_op_expr* bn = (bin_op_expr*)expr; 28 | 29 | return make_bin_op(bn->t.type, 30 | compile(bn->left, e, d), 31 | compile(bn->right, e, d)); 32 | } 33 | case lambda_type: 34 | { 35 | lambda_expr *lam = (lambda_expr *)expr; 36 | 37 | return make_lambda(lam->arg_name, 38 | compile(lam->body, 39 | make_env(lam->arg_name, 40 | make_num(0), 41 | e), 42 | d)); 43 | } 44 | case if0_type: 45 | { 46 | if0_expr* if0 = (if0_expr*)expr; 47 | 48 | return make_if0(compile(if0->tst, e, d), 49 | compile(if0->thn, e, d), 50 | compile(if0->els, e, d)); 51 | } 52 | default: 53 | fail("unrecognized expression in compile"); 54 | } 55 | 56 | return expr; 57 | } 58 | 59 | void compile_function(symbol* name, hash_table *d) { 60 | /* Compiles a (potentially recursive) function that's in d */ 61 | tagged* fn = lookup(d, name); 62 | tagged* new_lam; 63 | 64 | if (TAGGED_TYPE(fn) != func_type) 65 | fail("not defined as a function"); 66 | 67 | new_lam = make_lambda(((func_val*)fn)->lam->arg_name, 68 | compile(((func_val*)fn)->lam->body, 69 | make_env(((func_val*)fn)->lam->arg_name, 70 | make_num(0), 71 | ((func_val *)fn)->e), 72 | d)); 73 | 74 | ((func_val*)fn)->lam = (lambda_expr*)new_lam; 75 | } 76 | -------------------------------------------------------------------------------- /compile.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __COMPILE_H__ 3 | #define __COMPILE_H__ 4 | 5 | #include "struct.h" 6 | #include "hash.h" 7 | 8 | tagged* compile(tagged* expr, env* e, hash_table* d); 9 | void compile_function(symbol* fib, hash_table *d); 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /continue.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "continue.h" 4 | #include "gc.h" 5 | 6 | static void init_cont(cont *c, int tag) { 7 | c->type = tag; 8 | } 9 | 10 | cont *make_done() { 11 | cont *c = (cont*)gc_malloc0(sizeof(cont)); 12 | init_cont(c, done_type); 13 | return c; 14 | } 15 | 16 | cont *make_right_of_bin(int op, tagged *right, env *env, cont *rest) { 17 | right_of_bin *c =gc_malloc3(sizeof(right_of_bin), 18 | &right, 19 | &env, 20 | &rest); 21 | init_cont(&c->c, right_of_bin_type); 22 | c->op = op; 23 | c->right = right; 24 | c->env = env; 25 | c->rest = rest; 26 | return (cont*)c; 27 | } 28 | 29 | cont *make_finish_bin(int op, tagged *left_val, cont *rest) { 30 | finish_bin *c = gc_malloc2(sizeof(finish_bin), 31 | &left_val, 32 | &rest); 33 | init_cont(&c->c, finish_bin_type); 34 | c->op = op; 35 | c->left_val = left_val; 36 | c->rest = rest; 37 | return (cont*)c; 38 | } 39 | 40 | cont *make_right_of_app(tagged *right, env *env, cont *rest) { 41 | right_of_app *c = gc_malloc3(sizeof(right_of_app), 42 | &right, 43 | &env, 44 | &rest); 45 | init_cont(&c->c, right_of_app_type); 46 | c->right = right; 47 | c->env = env; 48 | c->rest = rest; 49 | return (cont*)c; 50 | } 51 | 52 | cont *make_finish_app(tagged *left_val, cont *rest) { 53 | finish_app *c = gc_malloc2(sizeof(finish_app), 54 | &left_val, 55 | &rest); 56 | init_cont(&c->c, finish_app_type); 57 | c->left_val = left_val; 58 | c->rest = rest; 59 | return (cont*)c; 60 | } 61 | 62 | cont *make_finish_if0(tagged *thn, tagged *els, env *env, cont *rest) { 63 | finish_if0 *c = gc_malloc4(sizeof(finish_if0), 64 | &thn, 65 | &els, 66 | &env, 67 | &rest); 68 | init_cont(&c->c, finish_if0_type); 69 | c->thn = thn; 70 | c->els = els; 71 | c->env = env; 72 | c->rest = rest; 73 | 74 | return (cont*)c; 75 | } 76 | 77 | #if USE_JIT 78 | static void init_jitted(jitted *j, jitted_proc code, jitted_proc tail_code, cont *rest) { 79 | j->code = code; 80 | j->tail_code = tail_code; 81 | j->rest = rest; 82 | } 83 | 84 | cont *make_right_jitted(jitted_proc code, jitted_proc tail_code, cont *rest, env *env) { 85 | right_jitted *c = gc_malloc2(sizeof(right_jitted), 86 | &env, 87 | &rest); 88 | init_cont(&c->j.c, right_jitted_type); 89 | init_jitted(&c->j, code, tail_code, rest); 90 | c->env = env; 91 | 92 | return (cont*)c; 93 | } 94 | 95 | cont *make_finish_jitted(jitted_proc code, jitted_proc tail_code, cont *rest, tagged* val) { 96 | finish_jitted *c = gc_malloc2(sizeof(finish_jitted), 97 | &rest, 98 | &val); 99 | init_cont(&c->j.c, finish_jitted_type); 100 | init_jitted(&c->j, code, tail_code, rest); 101 | c->val = val; 102 | 103 | return (cont*)c; 104 | } 105 | 106 | cont *make_interp(tagged* expr, cont *rest) { 107 | interp *c = gc_malloc2(sizeof(interp), 108 | &expr, 109 | &rest); 110 | init_cont(&c->c, interp_type); 111 | c->expr = expr; 112 | c->rest = rest; 113 | return (cont*)c; 114 | } 115 | #endif 116 | -------------------------------------------------------------------------------- /continue.h: -------------------------------------------------------------------------------- 1 | #ifndef __CONTINUE_H__ 2 | #define __CONTINUE_H__ 3 | 4 | #include "struct.h" 5 | 6 | enum { 7 | done_type = 200, 8 | right_of_bin_type, 9 | finish_bin_type, 10 | right_of_app_type, 11 | finish_app_type, 12 | finish_if0_type, 13 | # if USE_JIT 14 | right_jitted_type, 15 | finish_jitted_type, 16 | interp_type, 17 | # endif 18 | }; 19 | 20 | typedef struct cont { 21 | int type; 22 | } cont; 23 | 24 | typedef struct right_of_bin { 25 | cont c; 26 | int op; 27 | tagged *right; 28 | env *env; 29 | cont *rest; 30 | } right_of_bin; 31 | 32 | typedef struct finish_bin { 33 | cont c; 34 | int op; 35 | tagged *left_val; 36 | cont *rest; 37 | } finish_bin; 38 | 39 | typedef struct right_of_app { 40 | cont c; 41 | tagged *right; 42 | env *env; 43 | cont *rest; 44 | } right_of_app; 45 | 46 | typedef struct finish_app { 47 | cont c; 48 | tagged *left_val; 49 | cont *rest; 50 | } finish_app; 51 | 52 | typedef struct finish_if0 { 53 | cont c; 54 | tagged *thn; 55 | tagged *els; 56 | env *env; 57 | cont *rest; 58 | } finish_if0; 59 | 60 | #if USE_JIT 61 | typedef struct jitted { 62 | cont c; 63 | jitted_proc code; 64 | jitted_proc tail_code; 65 | cont *rest; 66 | } jitted; 67 | 68 | typedef struct right_jitted { 69 | jitted j; 70 | env* env; 71 | } right_jitted; 72 | 73 | typedef struct finish_jitted { 74 | jitted j; 75 | tagged* val; 76 | } finish_jitted; 77 | 78 | typedef struct interp { 79 | cont c; 80 | tagged* expr; 81 | cont *rest; 82 | } interp; 83 | #endif 84 | 85 | 86 | cont *make_done(); 87 | cont *make_right_of_bin(int op, tagged *right, env *env, cont *rest); 88 | cont *make_finish_bin(int op, tagged *left_val, cont *rest); 89 | cont *make_right_of_app(tagged *right, env *env, cont *rest); 90 | cont *make_finish_app(tagged *left_val, cont *rest); 91 | cont *make_finish_if0(tagged *thn, tagged *els, env *env, cont *rest); 92 | #if USE_JIT 93 | cont *make_right_jitted(jitted_proc code, jitted_proc tail_code, cont *rest, env *env); 94 | cont *make_finish_jitted(jitted_proc code, jitted_proc tail_code, cont *rest, tagged* val); 95 | cont *make_interp(tagged*expr, cont *rest); 96 | #endif 97 | 98 | #endif 99 | -------------------------------------------------------------------------------- /eval.c: -------------------------------------------------------------------------------- 1 | #include "eval.h" 2 | #include "continue.h" 3 | #include "fail.h" 4 | #include "lookup.h" 5 | #include "jit.h" 6 | #include "gc.h" 7 | 8 | #define PERFORM_TODOS(_val, _todos) val = _val; todos = _todos; goto todo 9 | #define EVAL(_expr, _e, _todos) expr = _expr; e = _e; todos = _todos; goto eval 10 | 11 | tagged* expr; 12 | env* e; 13 | cont* todos; 14 | tagged *val; 15 | 16 | void eval_star(hash_table* d) 17 | { 18 | 19 | eval: 20 | switch(TAGGED_TYPE(expr)) { 21 | case num_type: 22 | PERFORM_TODOS(expr, todos); 23 | case func_type: /* literal function can appear as a result of compilation */ 24 | PERFORM_TODOS(expr, todos); 25 | case sym_type: 26 | PERFORM_TODOS(env_lookup((symbol*)expr, e, d), todos); 27 | case debruijn_type: 28 | { 29 | # define db ((debruijn_expr*)expr) 30 | PERFORM_TODOS(env_lookup_by_pos(db->pos, e), todos); 31 | # undef db 32 | } 33 | case plus_type: 34 | case minus_type: 35 | case times_type: 36 | { 37 | # define bn ((bin_op_expr*)expr) 38 | 39 | todos = make_right_of_bin(bn->t.type, 40 | bn->right, 41 | e, 42 | todos); 43 | EVAL(bn->left, e, todos); 44 | 45 | # undef bn 46 | } 47 | case app_type: 48 | { 49 | # define bn ((bin_op_expr*)expr) 50 | 51 | todos = make_right_of_app(bn->right, 52 | e, 53 | todos); 54 | EVAL(bn->left, e, todos); 55 | 56 | # undef bn 57 | } 58 | case lambda_type: 59 | { 60 | # define lam ((lambda_expr *)expr) 61 | 62 | val = make_func(expr, 63 | e); 64 | PERFORM_TODOS(val, todos); 65 | 66 | # undef lam 67 | } 68 | case if0_type: 69 | { 70 | # define if0 ((if0_expr *)expr) 71 | 72 | todos = make_finish_if0(if0->thn, 73 | if0->els, 74 | e, 75 | todos); 76 | 77 | EVAL(if0->tst, e, todos); 78 | 79 | # undef if0 80 | } 81 | } 82 | 83 | fail("unrecognized expression"); 84 | 85 | todo: 86 | switch (TAGGED_TYPE(todos)) { 87 | case done_type: 88 | return; 89 | case right_of_bin_type: 90 | { 91 | # define gl ((right_of_bin *)todos) 92 | cont* new_todos; 93 | 94 | new_todos = make_finish_bin(gl->op, val, gl->rest); 95 | 96 | EVAL(gl->right, gl->env, new_todos); 97 | 98 | # undef gl 99 | } 100 | case finish_bin_type: 101 | { 102 | # define gr ((finish_bin *)todos) 103 | 104 | tagged *l = gr->left_val; 105 | tagged *r = val; 106 | int ln, rn, vn; 107 | 108 | if (TAGGED_TYPE(l) != num_type) 109 | fail("not a number"); 110 | if (TAGGED_TYPE(r) != num_type) 111 | fail("not a number"); 112 | 113 | ln = NUM_VAL(l); 114 | rn = NUM_VAL(r); 115 | 116 | switch(gr->op) { 117 | case plus_type: 118 | vn = ln + rn; 119 | break; 120 | case minus_type: 121 | vn = ln - rn; 122 | break; 123 | case times_type: 124 | vn = ln * rn; 125 | break; 126 | } 127 | 128 | val = make_num(vn); 129 | PERFORM_TODOS(val, gr->rest); 130 | 131 | # undef gr 132 | } 133 | case right_of_app_type: 134 | { 135 | # define gl ((right_of_app *)todos) 136 | cont* new_todos; 137 | 138 | new_todos = make_finish_app(val, gl->rest); 139 | EVAL(gl->right, gl->env, new_todos); 140 | 141 | # undef gl 142 | } 143 | case finish_app_type: 144 | { 145 | # define gr ((finish_app *)todos) 146 | # define fn (gr->left_val) 147 | 148 | if (TAGGED_TYPE(fn) == func_type) { 149 | # define fv ((func_val *)fn) 150 | 151 | e = make_env(fv->lam->arg_name, val, fv->e); 152 | 153 | if (jit(fv, d)) { 154 | # if USE_JIT 155 | jitted_proc code = fv->lam->code; 156 | todos = gr->rest; 157 | /* `code` may update `todos` */ 158 | PERFORM_TODOS(code(&todos), todos); 159 | # endif 160 | } else { 161 | EVAL(fv->lam->body, e, gr->rest); 162 | } 163 | 164 | # undef fv 165 | } else 166 | fail("not a function"); 167 | 168 | # undef fn 169 | # undef gr 170 | } 171 | case finish_if0_type: 172 | { 173 | # define gi ((finish_if0 *)todos) 174 | 175 | if (TAGGED_TYPE(val) == num_type) { 176 | if (NUM_VAL(val) == 0) { 177 | EVAL(gi->thn, gi->env, gi->rest); 178 | } else { 179 | EVAL(gi->els, gi->env, gi->rest); 180 | } 181 | } else 182 | fail("not a number"); 183 | 184 | # undef gi 185 | } 186 | # if USE_JIT 187 | case right_jitted_type: 188 | case finish_jitted_type: 189 | { 190 | # define gj ((jitted *)todos) 191 | /* `gj->code` updates `todos` */ 192 | PERFORM_TODOS(gj->code(), todos); 193 | # undef gj 194 | } 195 | case interp_type: 196 | { 197 | # define gi ((interp *)todos) 198 | EVAL(gi->expr, e, gi->rest); 199 | # undef gi 200 | } 201 | # endif 202 | } 203 | 204 | fail("unrecognized continuation"); 205 | } 206 | 207 | tagged* eval(tagged* _expr, env* _e, hash_table* d) 208 | { 209 | enable_gc(); 210 | 211 | expr = _expr; 212 | e = _e; 213 | todos = make_done(); 214 | eval_star(d); 215 | 216 | disable_gc(); 217 | 218 | return val; 219 | } 220 | -------------------------------------------------------------------------------- /eval.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __EVAL_H__ 3 | #define __EVAL_H__ 4 | 5 | #include "struct.h" 6 | #include "hash.h" 7 | 8 | tagged* eval(tagged* expr, env* e, hash_table* d); 9 | 10 | extern struct tagged* expr; 11 | extern struct env* e; 12 | extern struct cont* todos; 13 | extern struct tagged *val; 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /fail.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "fail.h" 4 | 5 | void* fail(char *s) { 6 | printf("%s\n", s); 7 | exit(1); 8 | return NULL; /* but not really */ 9 | } 10 | -------------------------------------------------------------------------------- /fail.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __FAIL_H__ 3 | #define __FAIL_H__ 4 | 5 | void* fail(char *s); 6 | 7 | #endif 8 | -------------------------------------------------------------------------------- /gc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "gc.h" 5 | #include "eval.h" 6 | #include "struct.h" 7 | #include "continue.h" 8 | #include "jit.h" 9 | #include "fail.h" 10 | 11 | static char *to_start, *to_pos, *to_end; 12 | static char *from_start, *from_end; 13 | static int gc_verbose; 14 | 15 | void gc_init(int heap_size, int verbose) { 16 | to_start = malloc(heap_size); 17 | to_pos = to_start; 18 | to_end = to_start + heap_size; 19 | 20 | from_start = malloc(heap_size); 21 | from_end = from_start + heap_size; 22 | 23 | gc_verbose = verbose; 24 | } 25 | 26 | static void collect_garbage(void *p1, void *p2, void *p3, void *p4); 27 | 28 | /************************************************************/ 29 | 30 | static int enabled = 0; 31 | 32 | void enable_gc() 33 | { 34 | enabled++; 35 | } 36 | 37 | void disable_gc() 38 | { 39 | enabled--; 40 | } 41 | 42 | /************************************************************/ 43 | 44 | typedef struct gcable { 45 | int tag; 46 | void *forward; 47 | } gcable; 48 | 49 | static int align_size(int sz) 50 | { 51 | /* make sure there's enough room for a warding pointer: */ 52 | if (sz < sizeof(gcable)) 53 | sz = sizeof(gcable); 54 | 55 | /* 16-byte alignment: */ 56 | if ((sz % 16) > 0) { 57 | sz += (16 - (sz % 16)); 58 | } 59 | 60 | return sz; 61 | } 62 | 63 | /************************************************************/ 64 | 65 | void *gc_malloc4(int sz, void *p1, void *p2, void *p3, void *p4) 66 | { 67 | if (enabled) { 68 | sz = align_size(sz); 69 | while (1) { 70 | if (to_pos + sz < to_end) { 71 | void *p = to_pos; 72 | to_pos += sz; 73 | return p; 74 | } else { 75 | collect_garbage(p1, p2, p3, p4); 76 | if (to_pos + sz >= to_end) 77 | return fail("out of memory"); 78 | } 79 | } 80 | } else { 81 | return malloc(sz); 82 | } 83 | } 84 | 85 | void *gc_malloc0(int sz) 86 | { 87 | return gc_malloc4(sz, NULL, NULL, NULL, NULL); 88 | } 89 | 90 | void *gc_malloc1(int sz, void *p1) 91 | { 92 | return gc_malloc4(sz, p1, NULL, NULL, NULL); 93 | } 94 | 95 | void *gc_malloc2(int sz, void *p1, void *p2) 96 | { 97 | return gc_malloc4(sz, p1, p2, NULL, NULL); 98 | } 99 | 100 | void *gc_malloc3(int sz, void *p1, void *p2, void *p3) 101 | { 102 | return gc_malloc4(sz, p1, p2, p3, NULL); 103 | } 104 | 105 | int gc_is_collectable(void *p) 106 | { 107 | return (!((uintptr_t)p & 0x1) 108 | && ((char*)p >= to_start) 109 | && ((char*)p < to_end)); 110 | } 111 | 112 | /************************************************************/ 113 | 114 | static int gcable_size(int tag) 115 | { 116 | int sz; 117 | 118 | switch (tag) { 119 | # if !FIXNUM_ENCODING 120 | case num_type: 121 | sz = sizeof(num_val); 122 | break; 123 | # endif 124 | case func_type: 125 | sz = sizeof(func_val); 126 | break; 127 | case sym_type: 128 | sz = sizeof(symbol); 129 | break; 130 | case plus_type: 131 | case minus_type: 132 | case times_type: 133 | case app_type: 134 | sz = sizeof(bin_op_expr); 135 | break; 136 | case lambda_type: 137 | sz = sizeof(lambda_expr); 138 | break; 139 | case env_type: 140 | sz = sizeof(env); 141 | break; 142 | case done_type: 143 | sz = sizeof(cont); 144 | break; 145 | case right_of_bin_type: 146 | sz = sizeof(right_of_bin); 147 | break; 148 | case finish_bin_type: 149 | sz = sizeof(finish_bin); 150 | break; 151 | case right_of_app_type: 152 | sz = sizeof(right_of_app); 153 | break; 154 | case finish_app_type: 155 | sz = sizeof(finish_app); 156 | break; 157 | case finish_if0_type: 158 | sz = sizeof(finish_if0); 159 | break; 160 | # if USE_JIT 161 | case right_jitted_type: 162 | sz = sizeof(right_jitted); 163 | break; 164 | case finish_jitted_type: 165 | sz = sizeof(finish_jitted); 166 | break; 167 | case interp_type: 168 | sz = sizeof(interp); 169 | break; 170 | # endif 171 | 172 | default: 173 | fail("bad tag for sizeof"); 174 | return 0; 175 | } 176 | 177 | return align_size(sz); 178 | } 179 | 180 | static void paint_gray(void *_pp) 181 | /* Paint the object at *pp gray and update *pp, or 182 | if the object is already gray/black, just update 183 | *pp using the forwarding pointer. */ 184 | { 185 | void **pp = (void **)_pp; 186 | 187 | /* First, check whether the referenced object is gcable, 188 | because it might instead have been allocated with 189 | gc disabled, or it might be a number encoded with an 190 | odd address: */ 191 | if (!((uintptr_t)(*pp) & 0x1) 192 | && ((char*)*pp >= from_start) 193 | && ((char*)*pp < from_end)) { 194 | /* It's a reference to a gcable object */ 195 | gcable *p = (gcable *)*pp; 196 | 197 | if (p->tag == -1) { 198 | /* already gray or black, so use forwarding pointer */ 199 | *pp = p->forward; 200 | } else { 201 | /* paint it gray: */ 202 | void *dest = to_pos; 203 | int sz; 204 | 205 | sz = gcable_size(p->tag); 206 | 207 | to_pos += sz; 208 | memcpy(dest, p, sz); 209 | 210 | /* install forwarding pointer: */ 211 | p->tag = -1; 212 | p->forward = dest; 213 | 214 | *pp = dest; 215 | } 216 | } 217 | } 218 | 219 | static void follow_one_gray_pointer(void *p) 220 | { 221 | switch (((gcable *)p)->tag) { 222 | case num_type: 223 | break; 224 | case func_type: 225 | { 226 | func_val *fv = (func_val *)p; 227 | paint_gray(&fv->lam); 228 | paint_gray(&fv->e); 229 | } 230 | break; 231 | case sym_type: 232 | break; 233 | case plus_type: 234 | case minus_type: 235 | case times_type: 236 | case app_type: 237 | { 238 | bin_op_expr *bn = (bin_op_expr *)p; 239 | paint_gray(&bn->left); 240 | paint_gray(&bn->right); 241 | } 242 | break; 243 | case lambda_type: 244 | { 245 | lambda_expr *lam = (lambda_expr *)p; 246 | paint_gray(&lam->arg_name); 247 | paint_gray(&lam->body); 248 | } 249 | break; 250 | case env_type: 251 | { 252 | env *e = (env *)p; 253 | paint_gray(&e->id); 254 | paint_gray(&e->val); 255 | paint_gray(&e->rest); 256 | } 257 | break; 258 | case done_type: 259 | break; 260 | case right_of_bin_type: 261 | { 262 | right_of_bin *gl = (right_of_bin *)p; 263 | paint_gray(&gl->right); 264 | paint_gray(&gl->env); 265 | paint_gray(&gl->rest); 266 | } 267 | break; 268 | case finish_bin_type: 269 | { 270 | finish_bin *gr = (finish_bin *)p; 271 | paint_gray(&gr->left_val); 272 | paint_gray(&gr->rest); 273 | } 274 | break; 275 | case right_of_app_type: 276 | { 277 | right_of_app *gl = (right_of_app *)p; 278 | paint_gray(&gl->right); 279 | paint_gray(&gl->env); 280 | paint_gray(&gl->rest); 281 | } 282 | break; 283 | case finish_app_type: 284 | { 285 | finish_app *gr = (finish_app *)p; 286 | paint_gray(&gr->left_val); 287 | paint_gray(&gr->rest); 288 | } 289 | break; 290 | case finish_if0_type: 291 | { 292 | finish_if0 *gi = (finish_if0 *)p; 293 | paint_gray(&gi->thn); 294 | paint_gray(&gi->els); 295 | paint_gray(&gi->env); 296 | paint_gray(&gi->rest); 297 | } 298 | break; 299 | # if USE_JIT 300 | case right_jitted_type: 301 | { 302 | right_jitted *gj = (right_jitted *)p; 303 | paint_gray(&gj->j.rest); 304 | paint_gray(&gj->env); 305 | } 306 | break; 307 | case finish_jitted_type: 308 | { 309 | finish_jitted *gj = (finish_jitted *)p; 310 | paint_gray(&gj->j.rest); 311 | paint_gray(&gj->val); 312 | } 313 | break; 314 | case interp_type: 315 | { 316 | interp *gi = (interp *)p; 317 | paint_gray(&gi->expr); 318 | paint_gray(&gi->rest); 319 | } 320 | break; 321 | # endif 322 | default: 323 | fail("bad tag for paint_gray content"); 324 | break; 325 | } 326 | } 327 | 328 | static void collect_garbage(void *p1, void *p2, void *p3, void *p4) 329 | { 330 | char *old_start, *old_end, *gray_pos; 331 | int old_size = to_pos - to_start; 332 | 333 | old_start = to_start; 334 | old_end = to_end; 335 | 336 | to_start = from_start; 337 | to_end = from_end; 338 | to_pos = to_start; 339 | 340 | from_start = old_start; 341 | from_end = old_end; 342 | 343 | paint_gray(&expr); 344 | paint_gray(&e); 345 | paint_gray(&todos); 346 | paint_gray(&val); 347 | if (p1) paint_gray(p1); 348 | if (p2) paint_gray(p2); 349 | if (p3) paint_gray(p3); 350 | if (p4) paint_gray(p4); 351 | # if USE_JIT 352 | push_jit_roots(paint_gray); 353 | # endif 354 | 355 | gray_pos = to_start; 356 | while (gray_pos < to_pos) { 357 | follow_one_gray_pointer(gray_pos); 358 | gray_pos += gcable_size(((gcable *)gray_pos)->tag); 359 | } 360 | 361 | if (gc_verbose) 362 | printf("[collected %d]\n", (int)(old_size - (to_pos - to_start))); 363 | } 364 | -------------------------------------------------------------------------------- /gc.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __GC_H__ 3 | #define __GC_H__ 4 | 5 | void gc_init(int heap_size, int verbose); 6 | 7 | void enable_gc(); 8 | void disable_gc(); 9 | 10 | void *gc_malloc0(int sz); 11 | void *gc_malloc1(int sz, void *p1); 12 | void *gc_malloc2(int sz, void *p1, void *p2); 13 | void *gc_malloc3(int sz, void *p1, void *p2, void *p3); 14 | void *gc_malloc4(int sz, void *p1, void *p2, void *p3, void *p4); 15 | 16 | int gc_is_collectable(void *p); 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /hash.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "hash.h" 4 | 5 | const double load_factor = 0.5; 6 | 7 | typedef struct entry { 8 | void* key; 9 | void* val; 10 | } entry; 11 | 12 | struct hash_table { 13 | int size; 14 | int count; 15 | entry *a; 16 | compare_proc compare_key; 17 | hash_proc hash_key; 18 | }; 19 | 20 | void resize_hash_table(hash_table *ht); 21 | 22 | void reset_hash_table(hash_table *ht, int size) 23 | { 24 | int i; 25 | 26 | ht->size = size; 27 | ht->count = 0; 28 | 29 | ht->a = (entry*)malloc(ht->size * sizeof(entry)); 30 | for (i = 0; i < size; i++) 31 | ht->a[i].key = NULL; 32 | } 33 | 34 | hash_table* make_hash_table(compare_proc compare_key, 35 | hash_proc hash_key) 36 | { 37 | hash_table *ht; 38 | 39 | ht = (hash_table *)malloc(sizeof(hash_table)); 40 | ht->compare_key = compare_key; 41 | ht-> hash_key = hash_key; 42 | 43 | reset_hash_table(ht, 8); 44 | 45 | return ht; 46 | } 47 | 48 | void* hash_get(hash_table *ht, void* k) 49 | { 50 | int n = ht->hash_key(k) % ht->size; 51 | 52 | while (1) { 53 | if (!ht->a[n].key) 54 | return NULL; 55 | if (!ht->compare_key(ht->a[n].key, k)) 56 | return ht->a[n].val; 57 | n = (n + 1) % ht->size; 58 | } 59 | } 60 | 61 | void hash_set(hash_table *ht, void* k, void* val) 62 | { 63 | int n = ht->hash_key(k) % ht->size; 64 | 65 | while (1) { 66 | if (!ht->a[n].key) 67 | break; 68 | if (!ht->compare_key(ht->a[n].key, k)) { 69 | ht->a[n].val = val; 70 | return; 71 | } 72 | n = (n + 1) % ht->size; 73 | } 74 | 75 | ht->a[n].key = k; 76 | ht->a[n].val = val; 77 | 78 | ht->count++; 79 | 80 | if (ht->count > ht->size * load_factor) 81 | resize_hash_table(ht); 82 | } 83 | 84 | void resize_hash_table(hash_table *ht) { 85 | int i, size = ht->size; 86 | entry *a = ht->a; 87 | 88 | reset_hash_table(ht, size * 2); 89 | for (i = 0; i < size; i++) { 90 | if (a[i].key) 91 | hash_set(ht, a[i].key, a[i].val); 92 | } 93 | } 94 | 95 | int hash_count(hash_table *ht) 96 | { 97 | return ht->count; 98 | } 99 | 100 | struct hash_iter { 101 | int pos; 102 | }; 103 | 104 | hash_iter* hash_iterate_new(hash_table *ht) { 105 | hash_iter* i = (hash_iter*)malloc(sizeof(hash_iter)); 106 | i->pos = 0; 107 | return i; 108 | } 109 | 110 | hash_iter* hash_iterate_next(hash_table *ht, hash_iter* i) { 111 | i->pos++; 112 | if (i->pos >= ht->size) 113 | return NULL; 114 | else 115 | return i; 116 | } 117 | 118 | void* hash_iterate_key(hash_table *ht, hash_iter* i) { 119 | return ht->a[i->pos].key; 120 | } 121 | -------------------------------------------------------------------------------- /hash.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __HASH_H__ 3 | #define __HASH_H__ 4 | 5 | typedef int (*compare_proc)(void* a, void* b); 6 | /* compare result: 0 => same, not 0 => different */ 7 | 8 | typedef int (*hash_proc)(void* a); 9 | /* hash result must be non-negative */ 10 | 11 | struct hash_table; 12 | typedef struct hash_table hash_table; 13 | 14 | hash_table* make_hash_table(compare_proc compare_key, 15 | hash_proc hash_key); 16 | void* hash_get(hash_table *ht, void* k); 17 | void hash_set(hash_table *ht, void* k, void* val); 18 | int hash_count(hash_table *ht); 19 | 20 | struct hash_iter; 21 | typedef struct hash_iter hash_iter; 22 | 23 | hash_iter* hash_iterate_new(hash_table *ht); 24 | hash_iter* hash_iterate_next(hash_table *ht, hash_iter* i); 25 | void* hash_iterate_key(hash_table *ht, hash_iter* i); 26 | 27 | #endif 28 | -------------------------------------------------------------------------------- /jit.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "struct.h" 3 | 4 | 5 | #if !USE_JIT 6 | 7 | #include "hash.h" 8 | 9 | int jit(func_val* fv, hash_table* d) { 10 | return FALSE; 11 | } 12 | 13 | #else 14 | 15 | #include 16 | #include "gc.h" 17 | #include "eval.h" 18 | #include "continue.h" 19 | #include "lookup.h" 20 | #include "fail.h" 21 | 22 | #define jit_movi_p(dest, addr) jit_movi(dest, (jit_word_t)(addr)) 23 | #define jit_pushargi_p(addr) jit_pushargi((jit_word_t)(addr)) 24 | 25 | static int inited = 0; 26 | 27 | typedef struct context { 28 | hash_table* d; 29 | symbol* arg_name; 30 | int stack_pos; 31 | env *env; 32 | int env_start; 33 | int specialize; 34 | 35 | tagged* inline_arg; 36 | struct context *inline_from; 37 | } context; 38 | 39 | static jit_state_t *_jit; 40 | 41 | static void jit_expr(tagged* expr, context *ctx); 42 | static void jit_variable(int pos, context *ctx); 43 | static void jit_cont_expr(tagged* expr, int cont_type, context *ctx); 44 | static jitted_proc jit_continue_by_interp(tagged* body); 45 | 46 | static void jit_cont_make(tagged* expr, context *ctx, int cont_type, int jit_cont_type); 47 | 48 | static void do_jit_next(); 49 | static void continue_or_return(); 50 | 51 | static void jit_check_type(int need_type, int reg, char *complain); 52 | static void jit_set_stack(int stack_pos, int reg); 53 | static void jit_get_stack(int reg, int stack_pos); 54 | static void jit_prep_possible_gc(int stack_pos, int tmp_reg); 55 | static void jit_movi_maybe_gc(int reg, tagged* v); 56 | 57 | static void jit_maybe_specialize(int stack_pos, context *ctx); 58 | static func_val *realloc_lam(func_val *fv); 59 | static tagged* extract_known(int pos, context *ctx); 60 | 61 | static int no_calls(tagged* expr, context *ctx); 62 | static int want_to_jit(lambda_expr* lam); 63 | static int definitely_number(tagged* expr); 64 | static int definitely_function(tagged* expr); 65 | static int can_inline(bin_op_expr* bn, context *ctx, int without_introducing_calls, func_val **_fv); 66 | 67 | #define STACK_SIZE 64 68 | static tagged* stack[STACK_SIZE]; 69 | static int stack_gc_depth = 0; 70 | 71 | #define MAX_CODE_ROOTS 128 72 | static tagged* code_roots[MAX_CODE_ROOTS]; 73 | static int code_roots_count = 0; 74 | 75 | #define FRAME_SIZE 64 76 | 77 | void push_jit_roots(void (*paint_gray)(void *)) 78 | { 79 | int i; 80 | 81 | for (i = 0; i < code_roots_count; i++) 82 | paint_gray(&code_roots[i]); 83 | 84 | for (i = 0; i < stack_gc_depth; i++) 85 | paint_gray(&stack[i]); 86 | } 87 | 88 | #if !FIXNUM_ENCODING 89 | # error "JIT requires fixnum encoding" 90 | #endif 91 | 92 | static void init_context(context *ctx, hash_table* d, symbol* arg_name, env* e) 93 | { 94 | ctx->d = d; 95 | ctx->arg_name = arg_name; 96 | ctx->stack_pos = 0; 97 | ctx->env = e; 98 | ctx->env_start = 1; 99 | ctx->specialize = 0; 100 | 101 | ctx->inline_arg = NULL; 102 | ctx->inline_from = NULL; 103 | } 104 | 105 | int jit(func_val *fv, hash_table* d) 106 | { 107 | jit_state_t *old_jit; 108 | jit_node_t *after_prolog; 109 | lambda_expr *lam = fv->lam; 110 | context ctx; 111 | 112 | init_context(&ctx, d, lam->arg_name, fv->e); 113 | 114 | if ((fv->specialize_counter == 1) && want_to_jit(lam)) { 115 | fv->specialize_counter = 0; 116 | if (fv->e) { 117 | fv = realloc_lam(fv); 118 | lam = fv->lam; 119 | ctx.env = fv->e; 120 | ctx.arg_name = lam->arg_name; 121 | ctx.specialize = 1; 122 | } 123 | } 124 | 125 | if (lam->code) 126 | return TRUE; /* already JIT-compiled */ 127 | 128 | if (lam->tail_code) 129 | return FALSE; /* tail code continues via interp */ 130 | 131 | if (!want_to_jit(lam)) { 132 | lam->tail_code = jit_continue_by_interp(lam->body); 133 | return FALSE; 134 | } 135 | 136 | if (!inited) { 137 | inited = 1; 138 | init_jit(NULL); 139 | } 140 | 141 | old_jit = _jit; 142 | _jit = jit_new_state(); 143 | 144 | jit_prolog(); 145 | jit_frame(FRAME_SIZE); 146 | after_prolog = jit_indirect(); 147 | 148 | jit_expr(lam->body, &ctx); 149 | 150 | continue_or_return(); 151 | 152 | lam->code = jit_emit(); 153 | lam->tail_code = jit_address(after_prolog); 154 | 155 | jit_clear_state(); 156 | _jit = old_jit; 157 | 158 | return TRUE; 159 | } 160 | 161 | jitted_proc jit_cont(tagged* expr, context *ctx, int cont_type, int jit_cont_type, jitted_proc *_tail_code) 162 | { 163 | jitted_proc code; 164 | jit_state_t *old_jit; 165 | jit_node_t *after_prolog; 166 | 167 | old_jit = _jit; 168 | _jit = jit_new_state(); 169 | 170 | jit_prolog(); 171 | jit_frame(FRAME_SIZE); 172 | after_prolog = jit_indirect(); 173 | 174 | jit_ldi(JIT_R2, &todos); 175 | 176 | jit_ldxi(JIT_R1, JIT_R2, offsetof(jitted, rest)); 177 | jit_sti(&todos, JIT_R1); 178 | 179 | switch (jit_cont_type) { 180 | case right_jitted_type: 181 | jit_ldxi(JIT_R1, JIT_R2, offsetof(right_jitted, env)); 182 | jit_sti(&e, JIT_R1); 183 | break; 184 | case finish_jitted_type: 185 | jit_ldxi(JIT_R1, JIT_R2, offsetof(finish_jitted, val)); 186 | break; 187 | } 188 | 189 | jit_ldi(JIT_R0, &val); 190 | 191 | jit_cont_expr(expr, cont_type, ctx); 192 | 193 | continue_or_return(); 194 | 195 | code = jit_emit(); 196 | *_tail_code = jit_address(after_prolog); 197 | 198 | jit_clear_state(); 199 | _jit = old_jit; 200 | 201 | return code; 202 | } 203 | 204 | void continue_or_return() 205 | { 206 | /* Stay in the JITted world if the continuation is one of ours */ 207 | jit_node_t *test, *this_one; 208 | 209 | jit_ldi(JIT_R2, &todos); 210 | jit_ldxi_i(JIT_R1, JIT_R2, offsetof(cont, type)); 211 | 212 | test = jit_bnei(JIT_R1, right_jitted_type); 213 | this_one = jit_label(); 214 | do_jit_next(); 215 | 216 | jit_patch(test); 217 | test = jit_beqi(JIT_R1, finish_jitted_type); 218 | jit_patch_at(test, this_one); 219 | 220 | jit_prep_possible_gc(0, JIT_R2); 221 | jit_retr(JIT_R0); 222 | } 223 | 224 | jitted_proc jit_continue_by_interp(tagged* body) 225 | { 226 | jit_state_t *old_jit; 227 | jitted_proc code; 228 | jit_node_t *after_prolog; 229 | 230 | if (!inited) { 231 | inited = 1; 232 | init_jit(NULL); 233 | } 234 | 235 | old_jit = _jit; 236 | _jit = jit_new_state(); 237 | 238 | jit_prolog(); 239 | jit_frame(FRAME_SIZE); 240 | 241 | after_prolog = jit_indirect(); 242 | 243 | jit_movi_maybe_gc(JIT_R0, body); 244 | jit_ldi(JIT_R1, &todos); 245 | 246 | jit_prepare(); 247 | jit_pushargr(JIT_R0); 248 | jit_pushargr(JIT_R1); 249 | jit_finishi(make_interp); 250 | 251 | jit_retval(JIT_R0); 252 | jit_sti(&todos, JIT_R0); 253 | 254 | jit_prep_possible_gc(0, JIT_R2); 255 | 256 | jit_movi_p(JIT_R0, make_num(0)); 257 | jit_retr(JIT_R0); 258 | 259 | (void)jit_emit(); 260 | code = jit_address(after_prolog); 261 | 262 | jit_clear_state(); 263 | _jit = old_jit; 264 | 265 | return code; 266 | } 267 | 268 | static void jit_expr_push(tagged* expr, context *ctx) 269 | { 270 | ctx->stack_pos++; 271 | jit_expr(expr, ctx); 272 | --ctx->stack_pos; 273 | } 274 | 275 | static void jit_expr(tagged* expr, context *ctx) 276 | { 277 | switch (TAGGED_TYPE(expr)) { 278 | case num_type: 279 | case func_type: 280 | jit_movi_maybe_gc(JIT_R0, expr); 281 | break; 282 | case sym_type: 283 | { 284 | int pos; 285 | if (same_symbol((symbol*)expr, ctx->arg_name)) 286 | jit_variable(0, ctx); 287 | else { 288 | pos = env_lookup_pos((symbol *)expr, ctx->env); 289 | if (pos != -1) 290 | jit_variable(pos+1, ctx); 291 | else 292 | jit_movi_maybe_gc(JIT_R0, lookup(ctx->d, (symbol *)expr)); 293 | } 294 | } 295 | break; 296 | case debruijn_type: 297 | { 298 | int pos = ((debruijn_expr*)expr)->pos; 299 | jit_variable(pos, ctx); 300 | } 301 | break; 302 | case plus_type: 303 | case minus_type: 304 | case times_type: 305 | { 306 | bin_op_expr* bn = (bin_op_expr*)expr; 307 | 308 | if (no_calls(bn->left, ctx) && no_calls(bn->right, ctx)) { 309 | jit_expr(bn->left, ctx); 310 | 311 | jit_set_stack(ctx->stack_pos, JIT_R0); 312 | 313 | jit_expr_push(bn->right, ctx); 314 | 315 | jit_get_stack(JIT_R1, ctx->stack_pos); 316 | 317 | jit_cont_expr(expr, finish_bin_type, ctx); 318 | } else { 319 | jit_cont_make(expr, ctx, right_of_bin_type, right_jitted_type); 320 | jit_expr(bn->left, ctx); 321 | do_jit_next(); 322 | } 323 | } 324 | break; 325 | case if0_type: 326 | { 327 | if0_expr* if0 = (if0_expr*)expr; 328 | 329 | if (no_calls(if0->tst, ctx)) { 330 | jit_expr(if0->tst, ctx); 331 | 332 | jit_cont_expr(expr, finish_if0_type, ctx); 333 | } else { 334 | jit_cont_make(expr, ctx, finish_if0_type, right_jitted_type); 335 | jit_expr(if0->tst, ctx); 336 | do_jit_next(); 337 | } 338 | } 339 | break; 340 | case lambda_type: 341 | { 342 | lambda_expr *lam = (lambda_expr *)expr; 343 | 344 | jit_ldi(JIT_R0, &e); 345 | 346 | jit_prep_possible_gc(ctx->stack_pos, JIT_R2); 347 | 348 | jit_prepare(); 349 | jit_pushargi_p(lam); 350 | jit_pushargr(JIT_R0); 351 | jit_finishi(make_func); 352 | jit_retval(JIT_R0); 353 | } 354 | break; 355 | case app_type: 356 | { 357 | bin_op_expr* bn = (bin_op_expr*)expr; 358 | func_val *fv; 359 | 360 | if (can_inline(bn, ctx, FALSE, &fv)) { 361 | /* inline a call */ 362 | context in_ctx; 363 | init_context(&in_ctx, ctx->d, fv->lam->arg_name, fv->e); 364 | in_ctx.inline_arg = bn->right; 365 | in_ctx.inline_from = ctx; 366 | jit_expr(fv->lam->body, &in_ctx); 367 | } else { 368 | if (no_calls(bn->left, ctx) && no_calls(bn->right, ctx)) { 369 | jit_expr(bn->left, ctx); 370 | 371 | jit_set_stack(ctx->stack_pos, JIT_R0); 372 | 373 | jit_expr_push(bn->right, ctx); 374 | 375 | jit_get_stack(JIT_R1, ctx->stack_pos); 376 | 377 | jit_cont_expr(expr, finish_app_type, ctx); 378 | } else { 379 | jit_cont_make(expr, ctx, right_of_app_type, right_jitted_type); 380 | jit_expr(bn->left, ctx); 381 | do_jit_next(); 382 | } 383 | } 384 | } 385 | break; 386 | default: 387 | fail("unrecognized expression in JIT compile"); 388 | } 389 | } 390 | 391 | static void jit_variable(int pos, context *ctx) 392 | { 393 | tagged* val; 394 | val = extract_known(pos, ctx); 395 | if (val) { 396 | if (TAGGED_TYPE(val) == debruijn_type) { 397 | /* due to inlining */ 398 | jit_variable(pos + ((debruijn_expr*)val)->pos + 1, ctx); 399 | } else if (TAGGED_TYPE(val) == sym_type) { 400 | /* due to inlining */ 401 | 402 | } else 403 | jit_expr(val, ctx); 404 | } else if ((pos == 0) && ctx->inline_arg) { 405 | jit_expr(ctx->inline_arg, ctx->inline_from); 406 | } else { 407 | jit_ldi(JIT_R2, &e); 408 | while (pos--) 409 | jit_ldxi(JIT_R2, JIT_R2, offsetof(env, rest)); 410 | jit_ldxi(JIT_R0, JIT_R2, offsetof(env, val)); 411 | } 412 | } 413 | 414 | static void jit_cont_expr(tagged* expr, int cont_type, context *ctx) 415 | { 416 | switch (cont_type) { 417 | case right_of_bin_type: 418 | { 419 | bin_op_expr* bn = (bin_op_expr*)expr; 420 | 421 | if (no_calls(bn->right, ctx)) { 422 | jit_set_stack(ctx->stack_pos, JIT_R0); 423 | jit_expr_push(bn->right, ctx); 424 | jit_get_stack(JIT_R1, ctx->stack_pos); 425 | jit_cont_expr(expr, finish_bin_type, ctx); 426 | } else { 427 | jit_cont_make(expr, ctx, finish_bin_type, finish_jitted_type); 428 | jit_expr(bn->right, ctx); 429 | do_jit_next(); 430 | } 431 | } 432 | break; 433 | case finish_bin_type: 434 | { 435 | bin_op_expr* bn = (bin_op_expr*)expr; 436 | 437 | /* JIT_R1 has left arg, JIT_R0 has right arg */ 438 | 439 | if (!definitely_number(bn->left)) 440 | jit_check_type(num_type, JIT_R1, "not a number"); 441 | if (!definitely_number(bn->right)) 442 | jit_check_type(num_type, JIT_R0, "not a number"); 443 | 444 | jit_rshi(JIT_R1, JIT_R1, 1); 445 | jit_rshi(JIT_R0, JIT_R0, 1); 446 | 447 | switch (TAGGED_TYPE(expr)) { 448 | case plus_type: 449 | jit_addr(JIT_R0, JIT_R1, JIT_R0); 450 | break; 451 | case minus_type: 452 | jit_subr(JIT_R0, JIT_R1, JIT_R0); 453 | break; 454 | case times_type: 455 | jit_mulr(JIT_R0, JIT_R1, JIT_R0); 456 | break; 457 | default: 458 | fail("unknown arithmetic"); 459 | } 460 | 461 | jit_lshi(JIT_R0, JIT_R0, 1); 462 | jit_ori(JIT_R0, JIT_R0, 0x1); 463 | } 464 | break; 465 | case finish_if0_type: 466 | { 467 | if0_expr* if0 = (if0_expr*)expr; 468 | jit_node_t *branch, *done; 469 | 470 | if (!definitely_number(if0->tst)) 471 | jit_check_type(num_type, JIT_R0, "not a number"); 472 | 473 | jit_rshi(JIT_R0, JIT_R0, 1); 474 | branch = jit_bnei(JIT_R0, 0); 475 | 476 | jit_expr(if0->thn, ctx); 477 | done = jit_jmpi(); 478 | 479 | jit_patch(branch); 480 | jit_expr(if0->els, ctx); 481 | 482 | jit_patch(done); 483 | } 484 | break; 485 | case right_of_app_type: 486 | { 487 | bin_op_expr* bn = (bin_op_expr*)expr; 488 | 489 | if (no_calls(bn->right, ctx)) { 490 | jit_set_stack(ctx->stack_pos, JIT_R0); 491 | jit_expr_push(bn->right, ctx); 492 | jit_get_stack(JIT_R1, ctx->stack_pos); 493 | jit_cont_expr(expr, finish_app_type, ctx); 494 | } else { 495 | jit_cont_make(expr, ctx, finish_app_type, finish_jitted_type); 496 | jit_expr(bn->right, ctx); 497 | do_jit_next(); 498 | } 499 | } 500 | break; 501 | case finish_app_type: 502 | { 503 | bin_op_expr* bn = (bin_op_expr*)expr; 504 | jit_node_t *branch; 505 | 506 | /* JIT_R1 has function, JIT_R0 has argument */ 507 | if (!definitely_function(bn->left)) 508 | jit_check_type(func_type, JIT_R1, "not a function"); 509 | 510 | /* Save function & arg on stack in case of GC */ 511 | jit_set_stack(ctx->stack_pos, JIT_R1); 512 | jit_set_stack(ctx->stack_pos+1, JIT_R0); 513 | 514 | jit_prep_possible_gc(ctx->stack_pos + 2, JIT_R2); 515 | 516 | jit_maybe_specialize(ctx->stack_pos, ctx); 517 | 518 | jit_ldxi(JIT_R2, JIT_R1, offsetof(func_val, lam)); 519 | jit_ldxi(JIT_R0, JIT_R2, offsetof(lambda_expr, tail_code)); 520 | branch = jit_bnei(JIT_R0, (jit_word_t)NULL); 521 | 522 | { 523 | /* Not yet JIT-compiled, so compile it now */ 524 | jit_movi_p(JIT_R0, ctx->d); 525 | jit_prepare(); 526 | jit_pushargr(JIT_R1); 527 | jit_pushargr(JIT_R0); 528 | jit_finishi(jit); 529 | } 530 | 531 | jit_patch(branch); 532 | 533 | /* Extend the environment */ 534 | jit_get_stack(JIT_R1, ctx->stack_pos); 535 | jit_get_stack(JIT_R0, ctx->stack_pos+1); 536 | jit_ldxi(JIT_R2, JIT_R1, offsetof(func_val, e)); 537 | jit_ldxi(JIT_R1, JIT_R1, offsetof(func_val, lam)); 538 | jit_ldxi(JIT_R1, JIT_R1, offsetof(lambda_expr, arg_name)); 539 | 540 | jit_prepare(); 541 | jit_pushargr(JIT_R1); /* argument name */ 542 | jit_pushargr(JIT_R0); /* argument value */ 543 | jit_pushargr(JIT_R2); /* env */ 544 | jit_finishi(make_env); 545 | jit_retval(JIT_R0); 546 | 547 | jit_sti(&e, JIT_R0); 548 | 549 | /* Jump to the called function's body */ 550 | jit_get_stack(JIT_R1, ctx->stack_pos); 551 | jit_ldxi(JIT_R0, JIT_R1, offsetof(func_val, lam)); 552 | jit_ldxi(JIT_R0, JIT_R0, offsetof(lambda_expr, tail_code)); 553 | jit_jmpr(JIT_R0); 554 | } 555 | break; 556 | default: 557 | fail("unrecognized continuation type in JIT compile"); 558 | } 559 | } 560 | 561 | static void jit_cont_make(tagged* expr, context *ctx, int cont_type, int jit_cont_type) 562 | { 563 | jitted_proc cont_code, cont_tail_code; 564 | 565 | cont_code = jit_cont(expr, ctx, cont_type, jit_cont_type, &cont_tail_code); 566 | 567 | jit_prep_possible_gc(0, JIT_R2); 568 | 569 | jit_ldi(JIT_R2, &todos); 570 | 571 | jit_prepare(); 572 | jit_movi_p(JIT_R1, cont_code); 573 | jit_pushargr(JIT_R1); /* code pointer */ 574 | jit_movi_p(JIT_R1, cont_tail_code); 575 | jit_pushargr(JIT_R1); 576 | jit_pushargr(JIT_R2); /* continuation */ 577 | switch (jit_cont_type) { 578 | case right_jitted_type: 579 | jit_ldi(JIT_R0, &e); 580 | jit_pushargr(JIT_R0); /* environment */ 581 | jit_finishi(make_right_jitted); 582 | break; 583 | case finish_jitted_type: 584 | jit_pushargr(JIT_R0); /* value to save */ 585 | jit_finishi(make_finish_jitted); 586 | break; 587 | } 588 | jit_retval(JIT_R0); 589 | 590 | jit_sti(&todos, JIT_R0); 591 | } 592 | 593 | static void jit_check_type(int need_type, int reg, char *complain) 594 | { 595 | jit_node_t *ok, *not_ok; 596 | 597 | if (need_type == num_type) 598 | ok = jit_bmsi(reg, 0x1); 599 | else { 600 | not_ok = jit_bmsi(reg, 0x1); 601 | jit_ldxi_i(JIT_R2, reg, offsetof(tagged, type)); 602 | ok = jit_beqi(JIT_R2, need_type); 603 | jit_patch(not_ok); 604 | } 605 | 606 | jit_prepare(); 607 | jit_pushargi_p(complain); 608 | jit_finishi(fail); 609 | 610 | jit_patch(ok); 611 | } 612 | 613 | static void do_jit_next() 614 | { 615 | /* We know that the current continuation has type finish_jitted[_with_val] */ 616 | jit_sti(&val, JIT_R0); 617 | jit_ldi(JIT_R2, &todos); 618 | jit_ldxi(JIT_R2, JIT_R2, offsetof(jitted, tail_code)); 619 | jit_jmpr(JIT_R2); 620 | } 621 | 622 | static void jit_set_stack(int stack_pos, int reg) 623 | { 624 | if (stack_pos >= STACK_SIZE) 625 | fail("stack too small for JIT-generated code"); 626 | 627 | jit_sti(&stack[stack_pos], reg); 628 | } 629 | 630 | static void jit_get_stack(int reg, int stack_pos) 631 | { 632 | jit_ldi(reg, &stack[stack_pos]); 633 | } 634 | 635 | static void jit_prep_possible_gc(int stack_pos, int tmp_reg) 636 | { 637 | jit_movi(tmp_reg, stack_pos); 638 | jit_sti_i(&stack_gc_depth, tmp_reg); 639 | } 640 | 641 | static void jit_movi_maybe_gc(int reg, tagged* v) 642 | { 643 | if (gc_is_collectable(v)) { 644 | if (code_roots_count >= MAX_CODE_ROOTS) 645 | fail("too many GCable values in JIT-generated code"); 646 | code_roots[code_roots_count] = v; 647 | jit_ldi(reg, &code_roots[code_roots_count]); 648 | code_roots_count++; 649 | } else 650 | jit_movi_p(reg, v); 651 | } 652 | 653 | static void jit_maybe_specialize(int stack_pos, context *ctx) 654 | { 655 | /* JIT_R1 holds a function, and the function is also 656 | on the local stack at position 0 */ 657 | jit_node_t *branch, *branch2; 658 | 659 | /* Check specialization counter */ 660 | jit_ldxi_i(JIT_R2, JIT_R1, offsetof(func_val, specialize_counter)); 661 | branch = jit_beqi(JIT_R2, 0); 662 | 663 | jit_subi(JIT_R2, JIT_R2, 1); 664 | jit_stxi_i(offsetof(func_val, specialize_counter), JIT_R1, JIT_R2); 665 | 666 | /* If specialize_counter goes to 1, then specialize */ 667 | branch2 = jit_bnei(JIT_R2, 1); 668 | jit_movi_p(JIT_R0, ctx->d); 669 | jit_prepare(); 670 | jit_pushargr(JIT_R1); 671 | jit_pushargr(JIT_R0); 672 | jit_finishi(jit); 673 | 674 | /* Reload function into JIT_R1 */ 675 | jit_get_stack(JIT_R1, stack_pos); 676 | 677 | jit_patch(branch); 678 | jit_patch(branch2); 679 | } 680 | 681 | static func_val *realloc_lam(func_val *fv) 682 | { 683 | lambda_expr* lam = fv->lam; 684 | 685 | if (gc_is_collectable(fv)) { 686 | code_roots[code_roots_count++] = (tagged*)fv; 687 | lam = (lambda_expr*)make_lambda(lam->arg_name, 688 | lam->body); 689 | fv = (func_val*)code_roots[--code_roots_count]; 690 | } else { 691 | disable_gc(); 692 | lam = (lambda_expr*)make_lambda(lam->arg_name, 693 | lam->body); 694 | enable_gc(); 695 | } 696 | fv->lam = lam; 697 | 698 | return fv; 699 | } 700 | 701 | static tagged* extract_known(int pos, context *ctx) 702 | { 703 | if (ctx->specialize && (pos >= ctx->env_start)) { 704 | /* specializing; use known value */ 705 | env *env = ctx->env; 706 | pos -= ctx->env_start; 707 | while (pos--) 708 | env = env->rest; 709 | return env->val; 710 | } else 711 | return NULL; 712 | } 713 | 714 | static int no_calls(tagged* expr, context *ctx) 715 | { 716 | switch (TAGGED_TYPE(expr)) { 717 | case app_type: 718 | return ctx && can_inline((bin_op_expr*)expr, ctx, TRUE, NULL); 719 | case plus_type: 720 | case minus_type: 721 | case times_type: 722 | { 723 | bin_op_expr* bn = (bin_op_expr*)expr; 724 | 725 | return no_calls(bn->left, ctx) && no_calls(bn->right, ctx); 726 | } 727 | case if0_type: 728 | { 729 | if0_expr* if0 = (if0_expr*)expr; 730 | 731 | return (no_calls(if0->tst, ctx) 732 | && no_calls(if0->thn, ctx) 733 | && no_calls(if0->els, ctx)); 734 | } 735 | } 736 | 737 | return TRUE; 738 | } 739 | 740 | static int want_to_jit(lambda_expr* lam) 741 | { 742 | return TRUE; 743 | } 744 | 745 | static int definitely_number(tagged* expr) 746 | { 747 | switch (TAGGED_TYPE(expr)) { 748 | case num_type: 749 | case plus_type: 750 | case minus_type: 751 | case times_type: 752 | return TRUE; 753 | } 754 | 755 | return FALSE; 756 | } 757 | 758 | static int definitely_function(tagged* expr) 759 | { 760 | switch (TAGGED_TYPE(expr)) { 761 | case lambda_type: 762 | case func_type: 763 | return TRUE; 764 | } 765 | 766 | return FALSE; 767 | } 768 | 769 | static int can_inline(bin_op_expr* bn, context *ctx, int without_introducing_calls, func_val **_fv) 770 | { 771 | if (TAGGED_TYPE(bn->left) == debruijn_type) { 772 | tagged* val = extract_known(((debruijn_expr*)bn->left)->pos, ctx); 773 | if (val && TAGGED_TYPE(val) == func_type) { 774 | /* Simpe enough argument? */ 775 | switch (TAGGED_TYPE(bn->right)) { 776 | case num_type: 777 | case func_type: 778 | case debruijn_type: 779 | case sym_type: 780 | { 781 | func_val* fv = (func_val*)val; 782 | if (_fv) 783 | *_fv = fv; 784 | if (without_introducing_calls) 785 | return no_calls(fv->lam->body, NULL); 786 | return TRUE; 787 | } 788 | break; 789 | } 790 | } 791 | } 792 | 793 | return FALSE; 794 | } 795 | 796 | #endif /* USE_JIT */ 797 | -------------------------------------------------------------------------------- /jit.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __JIT_H__ 3 | #define __JIT_H__ 4 | 5 | int jit(func_val *fv, hash_table* d); 6 | 7 | #if USE_JIT 8 | void push_jit_roots(void (*paint_gray)(void *)); 9 | #endif 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /lookup.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "struct.h" 5 | #include "lookup.h" 6 | #include "fail.h" 7 | 8 | static int compare_sym(void* _s1, void* _s2) { 9 | return strcmp(((symbol*)_s1)->s, ((symbol*)_s2)->s); 10 | } 11 | 12 | static int hash_sym(void* _s) { 13 | char* s = ((symbol *)_s)->s; 14 | int i, r = 0; 15 | 16 | for (i = 0; s[i] != 0; i++) { 17 | r *= 10; 18 | r += s[i]; 19 | } 20 | 21 | if (r < 0) r = -r; 22 | 23 | return r; 24 | } 25 | 26 | hash_table* make_dict() { 27 | return make_hash_table(compare_sym, hash_sym); 28 | } 29 | 30 | tagged* lookup(hash_table* d, symbol* id) { 31 | tagged *val; 32 | 33 | val = hash_get(d, id); 34 | if (!val) 35 | fail("undefined"); 36 | 37 | return val; 38 | } 39 | 40 | /*****************************************/ 41 | 42 | tagged* env_lookup(symbol *id, env* e, hash_table* d) { 43 | while (e) { 44 | if (same_symbol(id, e->id)) 45 | return e->val; 46 | e = e->rest; 47 | } 48 | 49 | return lookup(d, id); 50 | } 51 | 52 | int env_lookup_pos(symbol *id, env* e) { 53 | int pos = 0; 54 | while (e) { 55 | if (same_symbol(id, e->id)) 56 | return pos; 57 | pos++; 58 | e = e->rest; 59 | } 60 | 61 | return -1; 62 | } 63 | 64 | tagged* env_lookup_by_pos(int pos, env* e) { 65 | while (e && pos--) { 66 | e = e->rest; 67 | } 68 | 69 | if (!e) 70 | fail("bad position"); 71 | return e->val; 72 | } 73 | -------------------------------------------------------------------------------- /lookup.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __LOOKUP_H__ 3 | #define __LOOKUP_H__ 4 | 5 | #include "hash.h" 6 | #include "struct.h" 7 | 8 | hash_table* make_dict(); 9 | tagged* lookup(hash_table* d, symbol* id); 10 | tagged* env_lookup(symbol *id, env* e, hash_table* d); 11 | 12 | int env_lookup_pos(symbol *id, env* e); 13 | tagged* env_lookup_by_pos(int pos, env* e); 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "hash.h" 5 | #include "struct.h" 6 | #include "lookup.h" 7 | #include "eval.h" 8 | #include "compile.h" 9 | #include "check.h" 10 | #include "gc.h" 11 | #include "test.h" 12 | 13 | #define RUN_FIB 1 14 | #define RUN_FOREVER 0 15 | 16 | #if RUN_FIB 17 | # define HEAP_SIZE 100000 18 | #else 19 | # define HEAP_SIZE 1000 20 | #endif 21 | 22 | int main() 23 | { 24 | init_test(); 25 | init_forever_test(); 26 | init_fib_test(); 27 | 28 | gc_init(HEAP_SIZE, FALSE); 29 | 30 | test(); 31 | 32 | # if RUN_FIB 33 | fib_test(); 34 | # endif 35 | 36 | # if RUN_FOREVER 37 | /* runs -- and GCs -- forever in constant space: */ 38 | forever_test(); 39 | # endif 40 | 41 | printf("all tests passed\n"); 42 | 43 | return 0; 44 | } 45 | -------------------------------------------------------------------------------- /print.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "print.h" 3 | 4 | void print_val(tagged *t) { 5 | switch(TAGGED_TYPE(t)) { 6 | case num_type: 7 | printf("%ld", (long)NUM_VAL(t)); 8 | break; 9 | case func_type: 10 | printf("#"); 11 | break; 12 | } 13 | printf("\n"); 14 | } 15 | -------------------------------------------------------------------------------- /print.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __PRINT_H__ 3 | #define __PRINT_H__ 4 | 5 | #include "struct.h" 6 | 7 | void print_val(tagged *val); 8 | 9 | #endif 10 | -------------------------------------------------------------------------------- /struct.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "struct.h" 5 | #include "gc.h" 6 | 7 | static void init_tagged(tagged *t, int tag) { 8 | t->type = tag; 9 | } 10 | 11 | #if !FIXNUM_ENCODING 12 | tagged* make_num(int n) { 13 | num_val *nv = (num_val *)gc_malloc0(sizeof(num_val)); 14 | init_tagged(&nv->t, num_type); 15 | nv->n = n; 16 | return (tagged*)nv; 17 | } 18 | #endif 19 | 20 | tagged* make_func(tagged *lam, env *e) { 21 | func_val *fv = (func_val *)gc_malloc2(sizeof(func_val), 22 | &lam, 23 | &e); 24 | init_tagged(&fv->t, func_type); 25 | fv->lam = (lambda_expr*)lam; 26 | fv->e = e; 27 | 28 | # if USE_JIT 29 | fv->specialize_counter = SPECIALIZE_AFTER_COUNT + 1; 30 | # endif 31 | 32 | return (tagged*)fv; 33 | } 34 | 35 | symbol* make_symbol(char *s) { 36 | symbol *sym = (symbol *)gc_malloc0(sizeof(symbol)); 37 | init_tagged(&sym->t, sym_type); 38 | sym->s = strdup(s); 39 | return sym; 40 | } 41 | 42 | int same_symbol(symbol* a, symbol *b) 43 | { 44 | return !strcmp(a->s, b->s); 45 | } 46 | 47 | tagged* make_debruijn(int pos) { 48 | debruijn_expr *db = (debruijn_expr *)gc_malloc0(sizeof(debruijn_expr)); 49 | init_tagged(&db->t, debruijn_type); 50 | db->pos = pos; 51 | return (tagged*)db; 52 | } 53 | 54 | tagged* make_bin_op(int type, tagged *left, tagged *right) { 55 | bin_op_expr *bin = (bin_op_expr *)gc_malloc2(sizeof(bin_op_expr), 56 | &left, 57 | &right); 58 | init_tagged(&bin->t, type); 59 | bin->left = left; 60 | bin->right = right; 61 | return (tagged*)bin; 62 | } 63 | 64 | tagged* make_plus(tagged *left, tagged *right) { 65 | return make_bin_op(plus_type, left, right); 66 | } 67 | 68 | tagged* make_minus(tagged *left, tagged *right) { 69 | return make_bin_op(minus_type, left, right); 70 | } 71 | 72 | tagged* make_times(tagged *left, tagged *right) { 73 | return make_bin_op(times_type, left, right); 74 | } 75 | 76 | tagged* make_app(tagged *left, tagged *right) { 77 | return make_bin_op(app_type, left, right); 78 | } 79 | 80 | tagged* make_lambda(symbol *arg_name, tagged *body) { 81 | lambda_expr *lam = (lambda_expr *)gc_malloc2(sizeof(lambda_expr), 82 | &arg_name, 83 | &body); 84 | init_tagged(&lam->t, lambda_type); 85 | lam->arg_name = arg_name; 86 | lam->body = body; 87 | # if USE_JIT 88 | lam->code = NULL; 89 | lam->tail_code = NULL; 90 | # endif 91 | return (tagged*)lam; 92 | } 93 | 94 | tagged* make_if0(tagged *tst, tagged *thn, tagged *els) { 95 | if0_expr *if0 = (if0_expr *)gc_malloc3(sizeof(if0_expr), 96 | &tst, 97 | &thn, 98 | &els); 99 | init_tagged(&if0->t, if0_type); 100 | if0->tst = tst; 101 | if0->thn = thn; 102 | if0->els = els; 103 | return (tagged*)if0; 104 | } 105 | 106 | env* make_env(symbol *id, tagged *val, env *rest) 107 | { 108 | env *e = (env *)gc_malloc3(sizeof(env), 109 | &id, 110 | &val, 111 | &rest); 112 | e->type = env_type; 113 | e->id = id; 114 | e->val = val; 115 | e->rest = rest; 116 | return e; 117 | } 118 | -------------------------------------------------------------------------------- /struct.h: -------------------------------------------------------------------------------- 1 | #ifndef __STRUCT_H__ 2 | #define __STRUCT_H__ 3 | 4 | #include 5 | 6 | #define TRUE 1 7 | #define FALSE 0 8 | 9 | #define FIXNUM_ENCODING 1 10 | 11 | #ifndef USE_JIT 12 | # define USE_JIT 0 13 | #endif 14 | 15 | #define SPECIALIZE_AFTER_COUNT 100 16 | 17 | enum { 18 | num_type, 19 | func_type, 20 | sym_type, 21 | debruijn_type, 22 | plus_type, 23 | minus_type, 24 | times_type, 25 | app_type, 26 | lambda_type, 27 | if0_type 28 | }; 29 | 30 | enum { 31 | env_type = 100 32 | }; 33 | 34 | typedef struct env env; 35 | typedef struct lambda_expr lambda_expr; 36 | 37 | typedef struct tagged { 38 | int type; 39 | } tagged; 40 | 41 | #if !FIXNUM_ENCODING 42 | # define TAGGED_TYPE(t) ((t)->type) 43 | #else 44 | # define TAGGED_TYPE(t) ((((intptr_t)(t)) & 0x1) ? num_type : ((t)->type)) 45 | #endif 46 | 47 | #if !FIXNUM_ENCODING 48 | typedef struct num_val { 49 | tagged t; 50 | int n; 51 | } num_val; 52 | # define NUM_VAL(v) (((num_val *)(v))->n) 53 | #else 54 | # define NUM_VAL(v) (((intptr_t)(v)) >> 1) 55 | #endif 56 | 57 | #if USE_JIT 58 | typedef tagged* (*jitted_proc)(); 59 | #endif 60 | 61 | typedef struct func_val { 62 | tagged t; 63 | lambda_expr *lam; 64 | env* e; 65 | # if USE_JIT 66 | int specialize_counter; 67 | # endif 68 | } func_val; 69 | 70 | typedef struct symbol { 71 | tagged t; 72 | char *s; 73 | } symbol; 74 | 75 | typedef struct debruijn_expr { 76 | tagged t; 77 | int pos; 78 | } debruijn_expr; 79 | 80 | typedef struct bin_op_expr { 81 | tagged t; 82 | tagged *left, *right; 83 | } bin_op_expr; 84 | 85 | typedef struct lambda_expr { 86 | tagged t; 87 | symbol *arg_name; 88 | tagged *body; 89 | # if USE_JIT 90 | jitted_proc code; 91 | jitted_proc tail_code; 92 | # endif 93 | } lambda_expr; 94 | 95 | typedef struct if0_expr { 96 | tagged t; 97 | tagged *tst; 98 | tagged *thn; 99 | tagged *els; 100 | } if0_expr; 101 | 102 | struct env { 103 | int type; 104 | symbol *id; 105 | tagged *val; 106 | struct env *rest; 107 | }; 108 | 109 | #if !FIXNUM_ENCODING 110 | tagged* make_num(int n); 111 | #else 112 | # define make_num(n) ((tagged *)(intptr_t)(((n) << 1) | 0x1)) 113 | #endif 114 | 115 | tagged* make_func(tagged *lambda, env *e); 116 | symbol* make_symbol(char *s); 117 | int same_symbol(symbol* a, symbol *b); 118 | tagged* make_debruijn(int pos); 119 | tagged* make_bin_op(int type, tagged *left, tagged *right); 120 | tagged* make_plus(tagged *left, tagged *right); 121 | tagged* make_minus(tagged *left, tagged *right); 122 | tagged* make_times(tagged *left, tagged *right); 123 | tagged* make_app(tagged *left, tagged *right); 124 | tagged* make_lambda(symbol *arg_name, tagged *body); 125 | tagged* make_if0(tagged *tst, tagged *thn, tagged *els); 126 | 127 | env* make_env(symbol *id, tagged *val, env *rest); 128 | 129 | #endif 130 | -------------------------------------------------------------------------------- /test.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "hash.h" 3 | #include "lookup.h" 4 | #include "struct.h" 5 | #include "eval.h" 6 | #include "compile.h" 7 | #include "check.h" 8 | #include "test.h" 9 | 10 | static tagged* zero; 11 | static tagged* one; 12 | static tagged* seven; 13 | static tagged* eight; 14 | static tagged* six; 15 | static tagged* fortynine; 16 | static tagged* branch0; 17 | static tagged* branch1; 18 | static symbol* f; 19 | static symbol* x; 20 | static symbol* y; 21 | static symbol* z; 22 | static tagged* f_var; 23 | static tagged* x_var; 24 | static tagged* z_var; 25 | static tagged* id_lam; 26 | static tagged* id_func; 27 | static tagged* fofz; 28 | static tagged* idofone; 29 | static tagged* eightofone; 30 | static tagged* fiftysix; 31 | static tagged* eightbybranch0; 32 | static tagged* ninebybranch1; 33 | static tagged* app_lam; 34 | 35 | static hash_table* empty_d; 36 | static hash_table* fz_d; 37 | 38 | static env* y_env; 39 | 40 | static tagged* c_one; 41 | static tagged* c_seven; 42 | static tagged* c_eight; 43 | static tagged* c_six; 44 | static tagged* c_fortynine; 45 | static tagged* c_branch0; 46 | static tagged* c_branch1; 47 | static tagged* c_z_var; 48 | static tagged* c_id_lam; 49 | static tagged* c_fofz; 50 | static tagged* c_idofone; 51 | static tagged* c_eightofone; 52 | static tagged* c_fiftysix; 53 | static tagged* c_eightbybranch0; 54 | static tagged* c_ninebybranch1; 55 | 56 | static tagged* partial_c_one; 57 | 58 | 59 | void init_test() 60 | { 61 | zero = make_num(0); 62 | one = make_num(1); 63 | seven = make_num(7); 64 | eight = make_plus(one, seven); 65 | six = make_minus(seven, one); 66 | fortynine = make_times(seven, seven); 67 | branch0 = make_if0(zero, seven, eight); 68 | branch1 = make_if0(one, seven, eight); 69 | f = make_symbol("f"); 70 | x = make_symbol("x"); 71 | y = make_symbol("x"); 72 | z = make_symbol("z"); 73 | f_var = (tagged*)f; 74 | x_var = (tagged*)x; 75 | z_var = (tagged*)z; 76 | id_lam = make_lambda(x, x_var); 77 | id_func = make_func(make_lambda(x, x_var), NULL); 78 | fofz = make_app(f_var, z_var); 79 | idofone = make_app(id_lam, one); 80 | eightofone = make_app(make_lambda(x, eight), one); 81 | fiftysix = make_app(make_lambda(x, make_times(eightofone, seven)), one); 82 | eightbybranch0 = make_app(make_lambda(x, make_plus(branch0, one)), one); 83 | ninebybranch1 = make_app(make_lambda(x, make_plus(branch1, one)), one); 84 | app_lam = make_lambda(x, make_app(x_var, one)); 85 | 86 | empty_d = make_dict(); 87 | fz_d = make_dict(); 88 | 89 | hash_set(fz_d, f, id_func); 90 | hash_set(fz_d, z, seven); 91 | 92 | c_one = compile(one, NULL, empty_d); 93 | c_seven = compile(seven, NULL, fz_d); 94 | c_eight = compile(eight, NULL, fz_d); 95 | c_six = compile(six, NULL, fz_d); 96 | c_fortynine = compile(fortynine, NULL, fz_d); 97 | c_branch0 = compile(branch0, NULL, fz_d); 98 | c_branch1 = compile(branch1, NULL, fz_d); 99 | c_z_var = compile(z_var, NULL, fz_d); 100 | c_id_lam = compile(id_lam, NULL, fz_d); 101 | c_fofz = compile(fofz, NULL, fz_d); 102 | c_idofone = compile(idofone, NULL, fz_d); 103 | c_eightofone = compile(eightofone, NULL, fz_d); 104 | c_fiftysix = compile(fiftysix, NULL, fz_d); 105 | c_eightbybranch0 = compile(eightbybranch0, NULL, fz_d); 106 | c_ninebybranch1 = compile(ninebybranch1, NULL, fz_d); 107 | 108 | partial_c_one = make_app(compile(app_lam, NULL, fz_d), 109 | id_lam); 110 | 111 | y_env = make_env(y, one, NULL); 112 | } 113 | 114 | void test() 115 | { 116 | check_ptr(env_lookup(f, NULL, fz_d), id_func); 117 | check_ptr(env_lookup(z, NULL, fz_d), seven); 118 | check_ptr(env_lookup(y, y_env, fz_d), one); 119 | 120 | check_num_val(eval(one, NULL, empty_d), 1); 121 | 122 | check_num_val(eval(seven, NULL, fz_d), 7); 123 | check_num_val(eval(eight, NULL, fz_d), 8); 124 | check_num_val(eval(six, NULL, fz_d), 6); 125 | check_num_val(eval(fortynine, NULL, fz_d), 49); 126 | check_num_val(eval(branch0, NULL, fz_d), 7); 127 | check_num_val(eval(branch1, NULL, fz_d), 8); 128 | check_num_val(eval(z_var, NULL, fz_d), 7); 129 | check_func_val(eval(id_lam, NULL, fz_d)); 130 | 131 | check_num_val(eval(fofz, NULL, fz_d), 7); 132 | check_num_val(eval(idofone, NULL, fz_d), 1); 133 | check_num_val(eval(eightofone, NULL, fz_d), 8); 134 | check_num_val(eval(fiftysix, NULL, fz_d), 56); 135 | check_num_val(eval(eightbybranch0, NULL, fz_d), 8); 136 | check_num_val(eval(ninebybranch1, NULL, fz_d), 9); 137 | 138 | check_num_val(eval(c_one, NULL, empty_d), 1); 139 | 140 | check_num_val(eval(c_seven, NULL, fz_d), 7); 141 | check_num_val(eval(c_eight, NULL, fz_d), 8); 142 | check_num_val(eval(c_six, NULL, fz_d), 6); 143 | check_num_val(eval(c_fortynine, NULL, fz_d), 49); 144 | check_num_val(eval(c_branch0, NULL, fz_d), 7); 145 | check_num_val(eval(c_branch1, NULL, fz_d), 8); 146 | check_num_val(eval(c_z_var, NULL, fz_d), 7); 147 | check_func_val(eval(c_id_lam, NULL, fz_d)); 148 | 149 | check_num_val(eval(c_fofz, NULL, fz_d), 7); 150 | check_num_val(eval(c_idofone, NULL, fz_d), 1); 151 | check_num_val(eval(c_eightofone, NULL, fz_d), 8); 152 | check_num_val(eval(c_fiftysix, NULL, fz_d), 56); 153 | check_num_val(eval(c_eightbybranch0, NULL, fz_d), 8); 154 | check_num_val(eval(c_ninebybranch1, NULL, fz_d), 9); 155 | 156 | check_num_val(eval(partial_c_one, NULL, fz_d), 1); 157 | } 158 | 159 | /* ************************************************************ */ 160 | /* infinite-loop test */ 161 | 162 | static symbol* forever; 163 | static tagged* forever_var; 164 | static tagged *forever_func; 165 | static hash_table* forever_d; 166 | static tagged *app_forever; 167 | 168 | void init_forever_test() 169 | { 170 | forever = make_symbol("forever"); 171 | forever_var = (tagged*)forever; 172 | forever_func = make_func(make_lambda(x, 173 | make_app(forever_var, x_var)), 174 | NULL); 175 | 176 | forever_d = make_dict(); 177 | app_forever = make_app(forever_var, make_num(0)); 178 | 179 | hash_set(forever_d, forever, forever_func); 180 | } 181 | 182 | void forever_test() 183 | { 184 | eval(app_forever, NULL, forever_d); 185 | } 186 | 187 | /* ************************************************************ */ 188 | /* a Y combinator */ 189 | 190 | static tagged* Y; 191 | 192 | static tagged* make_let(symbol* lhs, tagged* rhs, tagged* body) 193 | { 194 | return make_app(make_lambda(lhs, body), rhs); 195 | } 196 | 197 | static void init_Y() 198 | { 199 | symbol* proc; 200 | symbol* fX; 201 | tagged* proc_var; 202 | tagged* fX_var; 203 | 204 | if (Y) return; 205 | 206 | proc = make_symbol("proc"); 207 | proc_var = (tagged*)proc; 208 | fX = make_symbol("fX"); 209 | fX_var = (tagged*)fX; 210 | 211 | Y = make_lambda(proc, 212 | make_let(fX, 213 | make_lambda(fX, 214 | make_let(f, 215 | make_lambda(x, 216 | make_app(make_app(fX_var, fX_var), 217 | x_var)), 218 | make_app(proc_var, f_var))), 219 | make_app(fX_var, fX_var))); 220 | } 221 | 222 | /* ************************************************************ */ 223 | /* fib test */ 224 | 225 | static hash_table* fib_d; 226 | static tagged* two; 227 | static symbol* fib; 228 | static tagged* fib_var; 229 | static tagged* fib_lam; 230 | static tagged* fib_func; 231 | static tagged* fib_Y; 232 | 233 | static symbol* alt_fib; 234 | static symbol* make_fib; 235 | static symbol* get_self; 236 | static symbol* check1; 237 | static symbol* check2; 238 | static symbol* base; 239 | static tagged* alt_fib_var; 240 | static tagged* make_fib_var; 241 | static tagged* get_self_var; 242 | static tagged* check1_var; 243 | static tagged* check2_var; 244 | static tagged* base_var; 245 | static tagged* make_fib_body; 246 | static tagged* alt_fib_func; 247 | static tagged* app_alt_fib; 248 | 249 | static tagged* thirty; 250 | static tagged* app_fib; 251 | static tagged* app_Y_fib; 252 | static int fib_result; 253 | 254 | static tagged* c_app_Y_fib; 255 | 256 | static tagged* make_fib_lam(tagged* self, tagged* check1_x, tagged* check2_x, tagged* base_val) 257 | { 258 | return make_lambda(x, 259 | make_if0(check1_x, 260 | base_val, 261 | make_if0(check2_x, 262 | base_val, 263 | make_plus(make_app(self, 264 | make_minus(x_var, one)), 265 | make_app(self, 266 | make_minus(x_var, two)))))); 267 | } 268 | 269 | void init_fib_test() 270 | { 271 | env *env; 272 | 273 | init_Y(); 274 | 275 | fib_d = make_dict(); 276 | two = make_num(2); 277 | fib = make_symbol("fib"); 278 | fib_var = (tagged*)fib; 279 | fib_lam = make_fib_lam(fib_var, x_var, make_minus(x_var, one), one); 280 | fib_func = make_func(fib_lam, NULL); 281 | 282 | fib_Y = make_app(Y, make_lambda(fib, fib_lam)); 283 | 284 | thirty = make_num(30); 285 | 286 | app_fib = make_app(fib_var, thirty); 287 | app_Y_fib = make_app(fib_Y, thirty); 288 | 289 | fib_result = 1346269; 290 | 291 | hash_set(fib_d, fib, fib_func); 292 | compile_function(fib, fib_d); 293 | 294 | c_app_Y_fib = compile(app_Y_fib, NULL, empty_d); 295 | 296 | /* abstracts fib over tests for two base cases and the base-case result */ 297 | alt_fib = make_symbol("alt-fib"); 298 | make_fib = make_symbol("make-fib"); 299 | get_self = make_symbol("get-self"); 300 | check1 = make_symbol("check1"); 301 | check2 = make_symbol("check2"); 302 | base = make_symbol("base"); 303 | alt_fib_var = (tagged*)alt_fib; 304 | make_fib_var = (tagged*)make_fib; 305 | get_self_var = (tagged*)get_self; 306 | check1_var = (tagged*)check1; 307 | check2_var = (tagged*)check2; 308 | base_var = (tagged*)base; 309 | make_fib_body = make_fib_lam(make_app(get_self_var, one), 310 | make_app(check1_var, x_var), 311 | make_app(check2_var, x_var), 312 | base_var); 313 | 314 | env = make_env(get_self, make_func(make_lambda(x, alt_fib_var), NULL), NULL); 315 | env = make_env(check1, make_func(make_lambda(x, x_var), NULL), env); 316 | env = make_env(check2, make_func(make_lambda(x, make_minus(x_var, one)), NULL), env); 317 | env = make_env(base, one, env); 318 | alt_fib_func = make_func(make_fib_body, env); 319 | 320 | hash_set(fib_d, alt_fib, alt_fib_func); 321 | compile_function(alt_fib, fib_d); 322 | 323 | app_alt_fib = make_app(alt_fib_var, thirty); 324 | } 325 | 326 | void fib_test() 327 | { 328 | check_num_val(eval(app_fib, NULL, fib_d), fib_result); 329 | } 330 | 331 | void fib_Y_test() 332 | { 333 | check_num_val(eval(c_app_Y_fib, NULL, empty_d), fib_result); 334 | } 335 | 336 | void fib_alt_test() 337 | { 338 | check_num_val(eval(app_alt_fib, NULL, fib_d), fib_result); 339 | } 340 | -------------------------------------------------------------------------------- /test.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __TEST_H__ 3 | #define __TEST_H__ 4 | 5 | void init_test(); 6 | void test(); 7 | 8 | void init_forever_test(); 9 | void forever_test(); 10 | 11 | void init_fib_test(); 12 | void fib_test(); 13 | void fib_Y_test(); 14 | void fib_alt_test(); 15 | 16 | #endif 17 | --------------------------------------------------------------------------------