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
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
#include <lcq/pit/runtime/eval.h>
/* add a new stack frame to the vm (with a tag and callsite annotation) */
static void vm_push_code_func(pit_runtime *rt, pit_value code, pit_value tag, pit_annotation ann, pit_value bound) {
pit_callstack_entry ent;
ent.tag = tag;
ent.ann = ann;
ent.code = code;
ent.bound = bound;
if (pit_vec_push(pit_callstack_entry)(rt->callstack, ent) < 0) {
pit_error(rt, "call stack overflow");
}
}
/* add a new stack frame to the vm (with no annotation) */
static void vm_push_code(pit_runtime *rt, pit_value code, pit_value bound) {
pit_annotation ann;
ann.line = -1;
ann.column = -1;
vm_push_code_func(rt, code, PIT_NIL, ann, bound);
}
static void vm_push(pit_runtime *rt, pit_value v) {
if (pit_vec_push(pit_value)(rt->result_stack, v) < 0) {
pit_error(rt, "vm stack overflow");
}
}
static pit_value vm_pop(pit_runtime *rt) {
pit_value ret = PIT_NIL;
if (pit_vec_pop(pit_value)(rt->result_stack, &ret) < 0) {
pit_error(rt, "vm stack underflow");
}
return ret;
}
static pit_value vm_bind_or_replace(pit_runtime *rt, pit_value nm, pit_value cell, pit_value bound) {
if (pit_value_list_contains_eq(rt, nm, bound)) {
/* if we're already responsible for unbinding this symbol (e.g. in a tail call), */
/* simply replace the old binding - this keeps the binding stack from growing for TCO purposes */
pit_symtab_replace(rt, nm, cell);
} else {
pit_symtab_bind(rt, nm, cell);
bound = pit_value_cons(rt, nm, bound);
}
return bound;
}
static void vm_call_lisp(pit_runtime *rt, pit_value tag, pit_value closure, pit_value args, pit_value bound) {
pit_value env = pit_value_array_get(rt, closure, 0);
pit_value anames = pit_value_array_get(rt, closure, 1);
pit_value arg_rest_nm = pit_value_array_get(rt, closure, 2);
pit_value body = pit_value_array_get(rt, closure, 3);
if (rt->error != PIT_NIL) return;
while (env != PIT_NIL) { /* first, bind all entries in the closure */
pit_value b = pit_value_cons_car(rt, env);
pit_value nm = pit_value_cons_car(rt, b);
bound = vm_bind_or_replace(rt, nm, pit_value_cons_cdr(rt, b), bound);
env = pit_value_cons_cdr(rt, env);
}
while (anames != PIT_NIL) { /* bind all argument names to their values */
pit_value nm = pit_value_cons_car(rt, anames);
pit_value cell = pit_value_cell_new(rt, PIT_NIL);
if (arg_rest_nm != PIT_NIL && pit_value_eq(nm, arg_rest_nm)) {
pit_value_cell_set(rt, cell, args, nm);
bound = vm_bind_or_replace(rt, nm, cell, bound);
break;
} else {
pit_value_cell_set(rt, cell, pit_value_cons_car(rt, args), nm);
bound = vm_bind_or_replace(rt, nm, cell, bound);
}
args = pit_value_cons_cdr(rt, args);
anames = pit_value_cons_cdr(rt, anames);
}
pit_annotation ann;
ann.line = -1;
ann.column = -1;
vm_push_code_func(rt, body, tag, ann, bound);
}
static bool vm_call(pit_runtime *rt, pit_value f, pit_value args, pit_value bound) {
char buf[256] = {0};
if (pit_value_is_symbol(rt, f)) f = pit_symtab_fget(rt, f);
switch (pit_value_sort(f)) {
case PIT_VALUE_SORT_REF: {
pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, f));
if (!h) { pit_error(rt, "bad ref for function"); return false; }
switch (h->hsort) {
case PIT_VALUE_HEAVY_SORT_NATIVEFUNC: {
vm_push(rt, h->in.nativefunc.f(rt, args, h->in.nativefunc.data));
/* if we've performed a native call, the frame is over - unbind everything left over */
while (bound != PIT_NIL) {
pit_symtab_unbind(rt, pit_value_cons_car(rt, bound));
bound = pit_value_cons_cdr(rt, bound);
}
break;
}
case PIT_VALUE_HEAVY_SORT_FUNC:
vm_call_lisp(rt, h->in.func.nm, h->in.func.closure, args, bound);
break;
default: {
i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true);
buf[end] = 0;
pit_error(rt, "attempted to apply non-function ref: %s", buf);
return false;
}
}
break;
}
default: {
i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true);
buf[end] = 0;
pit_error(rt, "attempted to apply non-function value: %s", buf);
return false;
}
}
return true;
}
/* remove all empty frames atop the stack. if unbind is true, unbind all associated bindings */
/* if unbind is false, return all the bindings that need to be unbound, in order */
/* the intention is that if we're finishing a frame "normally", we can just unbind everything */
/* if we're finishing a frame by pushing another frame that should run within this frame's context */
/* (e.g. a tail call or other control flow), we can give that new frame responsibility for this frame's */
/* bindings. this allows us to avoid growing the call stack while also ensuring that things are unbound */
/* at the correct time. */
static pit_value vm_erase_empty(pit_runtime *rt, bool unbind) {
pit_callstack_entry *ent = NULL;
pit_value ret = PIT_NIL;
if (rt->callstack->next < 1) return ret;
while ((ent = pit_vec_get(pit_callstack_entry)(rt->callstack, rt->callstack->next - 1))
&& ent->code == PIT_NIL) {
pit_value bound = ent->bound;
if (unbind) { /* we only unbind unconditionally when searching for the next instruction */
while (bound != PIT_NIL) { /* unbind everything we bound for the frame, in reverse */
pit_symtab_unbind(rt, pit_value_cons_car(rt, bound));
bound = pit_value_cons_cdr(rt, bound);
}
} else {
ret = pit_value_list_append(rt, bound, ret);
}
pit_vec_pop(pit_callstack_entry)(rt->callstack, NULL); /* pop the frame, and try again */
}
return ret;
}
/* run one instruction of the VM */
bool pit_vm_run_one(pit_runtime *rt) {
vm_erase_empty(rt, true);
if (rt->callstack->next < 1) return false;
pit_callstack_entry *ent = pit_vec_get(pit_callstack_entry)(rt->callstack, rt->callstack->next - 1);
if (ent == NULL) { pit_error(rt, "malformed call stack"); return false; }
pit_value ins = pit_value_cons_car(rt, ent->code);
if (ins == PIT_NIL) { pit_error(rt, "malformed vm instruction: %v %v", ins); return false; }
ent->code = pit_value_cons_cdr(rt, ent->code);
pit_value op = pit_value_cons_car(rt, ins);
if (pit_symtab_symbol_name_match_cstr(rt, op, "literal")) {
/* push a lisp value to the vm stack */
vm_push(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, ins)));
} else if (pit_symtab_symbol_name_match_cstr(rt, op, "lambda")) {
/* pop an argument list, a free variable list, and a body block */
/* create and push a function */
/* notably, this builds the closure by recording the currently-bound cells for each free variable! */
pit_value args = vm_pop(rt);
pit_value freevars = vm_pop(rt);
pit_value body = vm_pop(rt);
vm_push(rt, pit_value_func_lambda(rt, args, freevars, body));
} else if (pit_symtab_symbol_name_match_cstr(rt, op, "drop")) {
/* pop a value and ignore it */
vm_pop(rt);
} else if (pit_symtab_symbol_name_match_cstr(rt, op, "get")) {
/* pop a symbol and look up its value */
vm_push(rt, pit_symtab_get(rt, vm_pop(rt)));
} else if (pit_symtab_symbol_name_match_cstr(rt, op, "fget")) {
/* pop a symbol and look up its function value */
vm_push(rt, pit_symtab_fget(rt, vm_pop(rt)));
} else if (pit_symtab_symbol_name_match_cstr(rt, op, "if")) {
/* pop a condition, a then-block, and an else-block */
/* run the then-block if the condition is true, otherwise run the else-block */
pit_value c = vm_pop(rt);
pit_value t = vm_pop(rt);
pit_value e = vm_pop(rt);
pit_value bindings = vm_erase_empty(rt, false);
vm_push_code(rt, c != PIT_NIL ? t : e, bindings);
} else if (pit_symtab_symbol_name_match_cstr(rt, op, "apply")) {
/* pop an arity n and a function, and then n arguments, and apply the function */
i64 arity = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, ins)));
pit_value f = vm_pop(rt);
pit_value args = PIT_NIL;
while (arity-- > 0) args = pit_value_cons(rt, vm_pop(rt), args);
pit_value bindings = vm_erase_empty(rt, false);
if (!vm_call(rt, f, args, bindings)) return false;
} else {
pit_error(rt, "unknown vm operation");
return false;
}
vm_erase_empty(rt, true);
return true;
}
/* run the VM until evaluation of this code finishes, returning the result */
pit_value pit_vm_eval(pit_runtime *rt, pit_value v) {
i64 start = rt->callstack->next;
vm_push_code(rt, v, PIT_NIL);
while (rt->callstack->next > start && pit_vm_run_one(rt)) pit_gc_if_necessary(rt);
return vm_pop(rt);
}
/* run the VM until this function call finishes, returning the result */
pit_value pit_vm_apply(pit_runtime *rt, pit_value f, pit_value args) {
i64 start = rt->callstack->next;
vm_call(rt, f, args, PIT_NIL);
while (rt->callstack->next > start && pit_vm_run_one(rt)) pit_gc_if_necessary(rt);
return vm_pop(rt);
}
|
