-
Notifications
You must be signed in to change notification settings - Fork 0
/
vm.c
195 lines (178 loc) · 8.45 KB
/
vm.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
#include "vm.h"
#include "symbol.h"
#include "builtin.h"
#include <assert.h>
#include <stdio.h>
static ciapos_sexp install_builtins(ciapos_vm *self, ciapos_sexp thread) {
ciapos_sexp env = ciapos_mkenvironment(&self->top_of_heap, 128);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "+"), ciapos_builtin_add);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "-"), ciapos_builtin_subtract);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "*"), ciapos_builtin_multiply);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "/"), ciapos_builtin_divide);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "%"), ciapos_builtin_mod);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "alias"), ciapos_builtin_alias);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "in-pkg"), ciapos_builtin_inpkg);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "typeof"), ciapos_builtin_typeof);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "with-type"), ciapos_builtin_withtype);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "tuple"), ciapos_builtin_tuple);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "tuple-set!"), ciapos_builtin_set);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "tuple-get"), ciapos_builtin_get);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "set-expansion"), ciapos_builtin_setexpansion);
ciapos_environment_put(env, ciapos_symbolof(&self->registry, "env-set"), ciapos_builtin_envset);
ciapos_sexp newthread = ciapos_mktuple(&self->top_of_heap, 2);
ciapos_tuple_put(newthread, 0, env);
ciapos_tuple_put(newthread, 1, thread);
return newthread;
}
void ciapos_vm_init(ciapos_vm *self) {
ciapos_symreg_init(&self->registry);
self->top_of_heap = NULL;
self->stack = (ciapos_sexp) { .tag = CIAPOS_TAGNIL, .debug_info = 0 };
self->stack = install_builtins(self, self->stack);
ciapos_sym2sexp_init(&self->macros, 256, NULL, NULL);
}
void ciapos_vm_deinit(ciapos_vm *self) {
ciapos_symreg_deinit(&self->registry);
while (self->top_of_heap) {
ciapos_gc_header *tmp = self->top_of_heap;
self->top_of_heap = self->top_of_heap->next;
ciapos_gc_deinit(tmp);
}
}
static ciapos_sexp lookup(ciapos_sexp stack, ciapos_symbol id) {
while (stack.tag != CIAPOS_TAGNIL) {
assert(stack.tag == CIAPOS_TAGTUP);
assert(stack.tuple->length == 2);
ciapos_sexp env = ciapos_tuple_get(stack, 0);
if (ciapos_environment_has(env, id)) {
return ciapos_environment_get(env, id);
}
stack = ciapos_tuple_get(stack, 1);
}
assert(!"undefined variable");
}
static ciapos_sexp ciapos_vm_eval_withstack(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp expr);
static ciapos_sexp eval_args(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp args) {
if (args.tag == CIAPOS_TAGNIL) return args;
assert(args.tag == CIAPOS_TAGTUP);
assert(args.tuple->length == 2);
ciapos_sexp result = ciapos_mktuple(&self->top_of_heap, 2);
ciapos_tuple_put(result, 0, ciapos_vm_eval_withstack(self, stack, ciapos_tuple_get(args, 0)));
ciapos_tuple_put(result, 1, eval_args(self, stack, ciapos_tuple_get(args, 1)));
return result;
}
static void extract_args(ciapos_sexp frame, ciapos_sexp arglist, ciapos_sexp args) {
if (arglist.tag == CIAPOS_TAGNIL || args.tag == CIAPOS_TAGNIL) {
assert(args.tag == arglist.tag);
return;
}
if (arglist.tag == CIAPOS_TAGSYM) ciapos_environment_put(frame, arglist.symbol, args);
assert(args.tag == CIAPOS_TAGTUP);
assert(arglist.tag == CIAPOS_TAGTUP);
ciapos_sexp argname = ciapos_tuple_get(arglist, 0);
ciapos_sexp argval = ciapos_tuple_get(args, 0);
assert(argname.tag == CIAPOS_TAGSYM);
ciapos_environment_put(frame, argname.symbol, argval);
extract_args(frame, ciapos_tuple_get(arglist, 1), ciapos_tuple_get(args, 1));
}
static ciapos_sexp ciapos_vm_eval_withstack(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp expr);
ciapos_sexp ciapos_vm_eval(ciapos_vm *self, ciapos_sexp expr) {
return ciapos_vm_eval_withstack(self, self->stack, expr);
}
static ciapos_sexp usercode_eval(ciapos_vm *vm, ciapos_sexp fbody, ciapos_sexp env, ciapos_sexp args) {
ciapos_sexp arglist = ciapos_tuple_get(fbody, 0);
ciapos_sexp frame = ciapos_mkenvironment(&vm->top_of_heap, 16);
extract_args(frame, arglist, args);
ciapos_sexp newenv = ciapos_mktuple(&vm->top_of_heap, 2);
ciapos_tuple_put(newenv, 0, frame);
ciapos_tuple_put(newenv, 1, env);
env = newenv;
ciapos_sexp result;
fbody = ciapos_tuple_get(fbody, 1);
assert(fbody.tag == CIAPOS_TAGTUP);
do {
result = ciapos_vm_eval_withstack(vm, env, ciapos_tuple_get(fbody, 0));
fbody = ciapos_tuple_get(fbody, 1);
} while (fbody.tag == CIAPOS_TAGTUP);
assert(fbody.tag == CIAPOS_TAGNIL);
return result;
}
static ciapos_sexp parsefn(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp args) {
assert(args.tag == CIAPOS_TAGTUP);
assert(args.tuple->length == 2);
ciapos_sexp paramlist = ciapos_tuple_get(args, 0);
for (ciapos_sexp a = paramlist;
a.tag != CIAPOS_TAGNIL;
a = ciapos_tuple_get(a, 1))
{
assert(a.tag == CIAPOS_TAGTUP);
assert(a.tuple->length == 2);
assert(ciapos_tuple_get(a, 0).tag == CIAPOS_TAGSYM);
}
assert(ciapos_tuple_get(args, 1).tag != CIAPOS_TAGNIL);
return ciapos_mkfunction(&self->top_of_heap, usercode_eval, args, stack);
}
static ciapos_sexp expand_subexpr(ciapos_vm *self, ciapos_sexp expr);
static ciapos_sexp macroexpand(ciapos_vm *self, ciapos_sexp expr) {
if (expr.tag != CIAPOS_TAGTUP) return expr;
ciapos_sexp car = ciapos_tuple_get(expr, 0);
if (car.tag == CIAPOS_TAGSYM && ciapos_sym2sexp_has(&self->macros, car.symbol)) {
ciapos_sexp result = ciapos_function_eval(
ciapos_sym2sexp_get(&self->macros, car.symbol),
self,
ciapos_tuple_get(expr, 1));
result.debug_info = expr.debug_info;
return result;
}
return expand_subexpr(self, expr);
}
static ciapos_sexp expand_subexpr(ciapos_vm *self, ciapos_sexp expr) {
ciapos_sexp newexpr = ciapos_mktuple(&self->top_of_heap, expr.tuple->length);
newexpr.debug_info = expr.debug_info;
ptrdiff_t i;
for (i = 0; i < expr.tuple->length - 1; i++) {
if (ciapos_tuple_get(expr, i).tag == CIAPOS_TAGTUP) {
ciapos_tuple_put(newexpr, i, macroexpand(self, ciapos_tuple_get(expr, i)));
} else {
ciapos_tuple_put(newexpr, i, ciapos_tuple_get(expr, i));
}
}
if (ciapos_tuple_get(expr, i).tag == CIAPOS_TAGTUP) {
ciapos_tuple_put(newexpr, i, expand_subexpr(self, ciapos_tuple_get(expr, i)));
} else {
ciapos_tuple_put(newexpr, i, ciapos_tuple_get(expr, i));
}
return newexpr;
}
static ciapos_sexp ciapos_vm_eval_withstack(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp expr) {
expr = macroexpand(self, expr);
switch (expr.tag) {
case CIAPOS_TAGNIL: case CIAPOS_TAGINT: case CIAPOS_TAGREAL: case CIAPOS_TAGSTR: case CIAPOS_TAGOPAQUE:
case CIAPOS_TAGFN: return expr;
case CIAPOS_TAGSYM: return lookup(stack, expr.symbol);
case CIAPOS_TAGTUP: default:
assert(expr.tuple->length == 2);
ciapos_sexp fexpr = ciapos_tuple_get(expr, 0);
if (fexpr.tag == CIAPOS_TAGSYM) {
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:quote")) {
ciapos_sexp args = ciapos_tuple_get(expr, 1);
assert(args.tag == CIAPOS_TAGTUP);
assert(args.tuple->length == 2);
assert(ciapos_tuple_get(args, 1).tag == CIAPOS_TAGNIL);
return ciapos_tuple_get(args, 0);
}
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:lambda")) {
ciapos_sexp args = ciapos_tuple_get(expr, 1);
return parsefn(self, stack, args);
}
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:env")) {
assert(ciapos_tuple_get(expr, 1).tag == CIAPOS_TAGNIL);
return stack;
}
}
ciapos_sexp function = ciapos_vm_eval_withstack(self, stack, fexpr);
assert(function.tag == CIAPOS_TAGFN);
ciapos_sexp args = eval_args(self, stack, ciapos_tuple_get(expr, 1));
return ciapos_function_eval(function, self, args);
}
}