altos/lisp: Cache freed cons and stack items
[fw/altos] / src / lisp / ao_lisp_eval.c
1 /*
2  * Copyright © 2016 Keith Packard <keithp@keithp.com>
3  *
4  * This program is free software; you can redistribute it and/or modify
5  * it under the terms of the GNU General Public License as published by
6  * the Free Software Foundation, either version 2 of the License, or
7  * (at your option) any later version.
8  *
9  * This program is distributed in the hope that it will be useful, but
10  * WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12  * General Public License for more details.
13  */
14
15 #define DBG_EVAL 0
16 #include "ao_lisp.h"
17 #include <assert.h>
18
19 const struct ao_lisp_type ao_lisp_stack_type;
20
21 static int
22 stack_size(void *addr)
23 {
24         (void) addr;
25         return sizeof (struct ao_lisp_stack);
26 }
27
28 static void
29 stack_mark(void *addr)
30 {
31         struct ao_lisp_stack    *stack = addr;
32         for (;;) {
33                 ao_lisp_poly_mark(stack->sexprs, 0);
34                 ao_lisp_poly_mark(stack->values, 0);
35                 /* no need to mark values_tail */
36                 ao_lisp_poly_mark(stack->frame, 0);
37                 ao_lisp_poly_mark(stack->list, 0);
38                 stack = ao_lisp_poly_stack(stack->prev);
39                 if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack))
40                         break;
41         }
42 }
43
44 static void
45 stack_move(void *addr)
46 {
47         struct ao_lisp_stack    *stack = addr;
48
49         while (stack) {
50                 struct ao_lisp_stack    *prev;
51                 int                     ret;
52                 (void) ao_lisp_poly_move(&stack->sexprs, 0);
53                 (void) ao_lisp_poly_move(&stack->values, 0);
54                 (void) ao_lisp_poly_move(&stack->values_tail, 0);
55                 (void) ao_lisp_poly_move(&stack->frame, 0);
56                 (void) ao_lisp_poly_move(&stack->list, 0);
57                 prev = ao_lisp_poly_stack(stack->prev);
58                 if (!prev)
59                         break;
60                 ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev);
61                 if (prev != ao_lisp_poly_stack(stack->prev))
62                         stack->prev = ao_lisp_stack_poly(prev);
63                 if (ret)
64                         break;
65                 stack = prev;
66         }
67 }
68
69 const struct ao_lisp_type ao_lisp_stack_type = {
70         .size = stack_size,
71         .mark = stack_mark,
72         .move = stack_move,
73         .name = "stack"
74 };
75
76 struct ao_lisp_stack            *ao_lisp_stack;
77 ao_poly                         ao_lisp_v;
78
79 struct ao_lisp_stack            *ao_lisp_stack_free_list;
80
81 ao_poly
82 ao_lisp_set_cond(struct ao_lisp_cons *c)
83 {
84         ao_lisp_stack->state = eval_cond;
85         ao_lisp_stack->sexprs = ao_lisp_cons_poly(c);
86         return AO_LISP_NIL;
87 }
88
89 static void
90 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
91 {
92         stack->state = eval_sexpr;
93         stack->sexprs = AO_LISP_NIL;
94         stack->values = AO_LISP_NIL;
95         stack->values_tail = AO_LISP_NIL;
96 }
97
98
99 static int
100 ao_lisp_stack_push(void)
101 {
102         struct ao_lisp_stack    *stack;
103         if (ao_lisp_stack_free_list) {
104                 stack = ao_lisp_stack_free_list;
105                 ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev);
106         } else {
107                 stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
108                 if (!stack)
109                         return 0;
110         }
111         stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
112         stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
113         stack->list = AO_LISP_NIL;
114         ao_lisp_stack = stack;
115         ao_lisp_stack_reset(stack);
116         DBGI("stack push\n");
117         DBG_FRAMES();
118         DBG_IN();
119         return 1;
120 }
121
122 static void
123 ao_lisp_stack_pop(void)
124 {
125         ao_poly prev;
126
127         if (!ao_lisp_stack)
128                 return;
129         prev = ao_lisp_stack->prev;
130         ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list);
131         ao_lisp_stack_free_list = ao_lisp_stack;
132
133         ao_lisp_stack = ao_lisp_poly_stack(prev);
134         if (ao_lisp_stack)
135                 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
136         else
137                 ao_lisp_frame_current = NULL;
138         DBG_OUT();
139         DBGI("stack pop\n");
140         DBG_FRAMES();
141 }
142
143 static void
144 ao_lisp_stack_clear(void)
145 {
146         ao_lisp_stack = NULL;
147         ao_lisp_frame_current = NULL;
148         ao_lisp_v = AO_LISP_NIL;
149 }
150
151 static int
152 func_type(ao_poly func)
153 {
154         if (func == AO_LISP_NIL)
155                 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
156         switch (ao_lisp_poly_type(func)) {
157         case AO_LISP_BUILTIN:
158                 return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK;
159         case AO_LISP_LAMBDA:
160                 return ao_lisp_poly_lambda(func)->args;
161         default:
162                 ao_lisp_error(AO_LISP_INVALID, "not a func");
163                 return -1;
164         }
165 }
166
167 /*
168  * Flattened eval to avoid stack issues
169  */
170
171 /*
172  * Evaluate an s-expression
173  *
174  * For a list, evaluate all of the elements and
175  * then execute the resulting function call.
176  *
177  * Each element of the list is evaluated in
178  * a clean stack context.
179  *
180  * The current stack state is set to 'formal' so that
181  * when the evaluation is complete, the value
182  * will get appended to the values list.
183  *
184  * For other types, compute the value directly.
185  */
186
187 static int
188 ao_lisp_eval_sexpr(void)
189 {
190         DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n");
191         switch (ao_lisp_poly_type(ao_lisp_v)) {
192         case AO_LISP_CONS:
193                 if (ao_lisp_v == AO_LISP_NIL) {
194                         if (!ao_lisp_stack->values) {
195                                 /*
196                                  * empty list evaluates to empty list
197                                  */
198                                 ao_lisp_v = AO_LISP_NIL;
199                                 ao_lisp_stack->state = eval_val;
200                         } else {
201                                 /*
202                                  * done with arguments, go execute it
203                                  */
204                                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car;
205                                 ao_lisp_stack->state = eval_exec;
206                         }
207                 } else {
208                         if (!ao_lisp_stack->values)
209                                 ao_lisp_stack->list = ao_lisp_v;
210                         /*
211                          * Evaluate another argument and then switch
212                          * to 'formal' to add the value to the values
213                          * list
214                          */
215                         ao_lisp_stack->sexprs = ao_lisp_v;
216                         ao_lisp_stack->state = eval_formal;
217                         if (!ao_lisp_stack_push())
218                                 return 0;
219                         /*
220                          * push will reset the state to 'sexpr', which
221                          * will evaluate the expression
222                          */
223                         ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
224                 }
225                 break;
226         case AO_LISP_ATOM:
227                 DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
228                 ao_lisp_v = ao_lisp_atom_get(ao_lisp_v);
229                 /* fall through */
230         case AO_LISP_INT:
231         case AO_LISP_STRING:
232         case AO_LISP_BUILTIN:
233         case AO_LISP_LAMBDA:
234                 ao_lisp_stack->state = eval_val;
235                 break;
236         }
237         DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n");
238         return 1;
239 }
240
241 /*
242  * A value has been computed.
243  *
244  * If the value was computed from a macro,
245  * then we want to reset the current context
246  * to evaluate the macro result again.
247  *
248  * If not a macro, then pop the stack.
249  * If the stack is empty, we're done.
250  * Otherwise, the stack will contain
251  * the next state.
252  */
253
254 static int
255 ao_lisp_eval_val(void)
256 {
257         DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n");
258         /*
259          * Value computed, pop the stack
260          * to figure out what to do with the value
261          */
262         ao_lisp_stack_pop();
263         DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1);
264         return 1;
265 }
266
267 /*
268  * A formal has been computed.
269  *
270  * If this is the first formal, then check to see if we've got a
271  * lamda/lexpr or macro/nlambda.
272  *
273  * For lambda/lexpr, go compute another formal.  This will terminate
274  * when the sexpr state sees nil.
275  *
276  * For macro/nlambda, we're done, so move the sexprs into the values
277  * and go execute it.
278  *
279  * Macros have an additional step of saving a stack frame holding the
280  * macro value execution context, which then gets the result of the
281  * macro to run
282  */
283
284 static int
285 ao_lisp_eval_formal(void)
286 {
287         ao_poly                 formal;
288         struct ao_lisp_stack    *prev;
289
290         DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n");
291
292         /* Check what kind of function we've got */
293         if (!ao_lisp_stack->values) {
294                 switch (func_type(ao_lisp_v)) {
295                 case AO_LISP_FUNC_LAMBDA:
296                 case AO_LISP_FUNC_LEXPR:
297                         DBGI(".. lambda or lexpr\n");
298                         break;
299                 case AO_LISP_FUNC_MACRO:
300                         /* Evaluate the result once more */
301                         ao_lisp_stack->state = eval_sexpr;
302                         if (!ao_lisp_stack_push())
303                                 return 0;
304
305                         /* After the function returns, take that
306                          * value and re-evaluate it
307                          */
308                         prev = ao_lisp_poly_stack(ao_lisp_stack->prev);
309                         ao_lisp_stack->state = eval_sexpr;
310                         ao_lisp_stack->sexprs = prev->sexprs;
311                         prev->sexprs = AO_LISP_NIL;
312
313                         DBGI(".. start macro\n");
314                         DBGI(".. sexprs       "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
315                         DBGI(".. values       "); DBG_POLY(ao_lisp_stack->values); DBG("\n");
316                         DBG_FRAMES();
317
318                         /* fall through ... */
319                 case AO_LISP_FUNC_NLAMBDA:
320                         DBGI(".. nlambda or macro\n");
321
322                         /* use the raw sexprs as values */
323                         ao_lisp_stack->values = ao_lisp_stack->sexprs;
324                         ao_lisp_stack->values_tail = AO_LISP_NIL;
325                         ao_lisp_stack->state = eval_exec;
326
327                         /* ready to execute now */
328                         return 1;
329                 case -1:
330                         return 0;
331                 }
332         }
333
334         /* Append formal to list of values */
335         formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL));
336         if (!formal)
337                 return 0;
338
339         if (ao_lisp_stack->values_tail)
340                 ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal;
341         else
342                 ao_lisp_stack->values = formal;
343         ao_lisp_stack->values_tail = formal;
344
345         DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n");
346
347         /*
348          * Step to the next argument, if this is last, then
349          * 'sexpr' will end up switching to 'exec'
350          */
351         ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
352
353         ao_lisp_stack->state = eval_sexpr;
354
355         DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n");
356         return 1;
357 }
358
359 /*
360  * Start executing a function call
361  *
362  * Most builtins are easy, just call the function.
363  * 'cond' is magic; it sticks the list of clauses
364  * in 'sexprs' and switches to 'cond' state. That
365  * bit of magic is done in ao_lisp_set_cond.
366  *
367  * Lambdas build a new frame to hold the locals and
368  * then re-use the current stack context to evaluate
369  * the s-expression from the lambda.
370  */
371
372 static int
373 ao_lisp_eval_exec(void)
374 {
375         ao_poly v;
376         struct ao_lisp_builtin  *builtin;
377
378         DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n");
379         ao_lisp_stack->sexprs = AO_LISP_NIL;
380         switch (ao_lisp_poly_type(ao_lisp_v)) {
381         case AO_LISP_BUILTIN:
382                 ao_lisp_stack->state = eval_val;
383                 builtin = ao_lisp_poly_builtin(ao_lisp_v);
384                 v = ao_lisp_func(builtin) (
385                         ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr));
386                 DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) {
387                                 struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
388                                 ao_poly atom = ao_lisp_arg(cons, 1);
389                                 ao_poly val = ao_lisp_arg(cons, 2);
390                                 DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n");
391                         });
392                 builtin = ao_lisp_poly_builtin(ao_lisp_v);
393                 if (builtin->args & AO_LISP_FUNC_FREE_ARGS)
394                         ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values));
395
396                 ao_lisp_v = v;
397                 DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n");
398                 DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
399                 break;
400         case AO_LISP_LAMBDA:
401                 ao_lisp_stack->state = eval_sexpr;
402                 DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
403                 ao_lisp_v = ao_lisp_lambda_eval();
404                 DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n");
405                 DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
406                 break;
407         }
408         ao_lisp_stack->values = AO_LISP_NIL;
409         ao_lisp_stack->values_tail = AO_LISP_NIL;
410         return 1;
411 }
412
413 /*
414  * Start evaluating the next cond clause
415  *
416  * If the list of clauses is empty, then
417  * the result of the cond is nil.
418  *
419  * Otherwise, set the current stack state to 'cond_test' and create a
420  * new stack context to evaluate the test s-expression. Once that's
421  * complete, we'll land in 'cond_test' to finish the clause.
422  */
423 static int
424 ao_lisp_eval_cond(void)
425 {
426         DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
427         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
428         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
429         if (!ao_lisp_stack->sexprs) {
430                 ao_lisp_v = AO_LISP_NIL;
431                 ao_lisp_stack->state = eval_val;
432         } else {
433                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car;
434                 if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) {
435                         ao_lisp_error(AO_LISP_INVALID, "invalid cond clause");
436                         return 0;
437                 }
438                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
439                 ao_lisp_stack->state = eval_cond_test;
440                 if (!ao_lisp_stack_push())
441                         return 0;
442                 ao_lisp_stack->state = eval_sexpr;
443         }
444         return 1;
445 }
446
447 /*
448  * Finish a cond clause.
449  *
450  * Check the value from the test expression, if
451  * non-nil, then set up to evaluate the value expression.
452  *
453  * Otherwise, step to the next clause and go back to the 'cond'
454  * state
455  */
456 static int
457 ao_lisp_eval_cond_test(void)
458 {
459         DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
460         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
461         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
462         if (ao_lisp_v) {
463                 struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car);
464                 struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr);
465
466                 if (c) {
467                         ao_lisp_stack->state = eval_sexpr;
468                         ao_lisp_v = c->car;
469                 } else
470                         ao_lisp_stack->state = eval_val;
471         } else {
472                 ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
473                 DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
474                 ao_lisp_stack->state = eval_cond;
475         }
476         return 1;
477 }
478
479 /*
480  * Evaluate a list of sexprs, returning the value from the last one.
481  *
482  * ao_lisp_progn records the list in stack->sexprs, so we just need to
483  * walk that list. Set ao_lisp_v to the car of the list and jump to
484  * eval_sexpr. When that's done, it will land in eval_val. For all but
485  * the last, leave a stack frame with eval_progn set so that we come
486  * back here. For the last, don't add a stack frame so that we can
487  * just continue on.
488  */
489 static int
490 ao_lisp_eval_progn(void)
491 {
492         DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
493         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
494         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
495
496         if (!ao_lisp_stack->sexprs) {
497                 ao_lisp_v = AO_LISP_NIL;
498                 ao_lisp_stack->state = eval_val;
499         } else {
500                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car;
501                 ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
502                 if (ao_lisp_stack->sexprs) {
503                         ao_lisp_stack->state = eval_progn;
504                         if (!ao_lisp_stack_push())
505                                 return 0;
506                 }
507                 ao_lisp_stack->state = eval_sexpr;
508         }
509         return 1;
510 }
511
512 /*
513  * Conditionally execute a list of sexprs while the first is true
514  */
515 static int
516 ao_lisp_eval_while(void)
517 {
518         DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
519         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
520         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
521
522         if (!ao_lisp_stack->sexprs) {
523                 ao_lisp_v = AO_LISP_NIL;
524                 ao_lisp_stack->state = eval_val;
525         } else {
526                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car;
527                 ao_lisp_stack->state = eval_while_test;
528                 if (!ao_lisp_stack_push())
529                         return 0;
530                 ao_lisp_stack->state = eval_sexpr;
531         }
532         return 1;
533 }
534
535 /*
536  * Check the while condition, terminate the loop if nil. Otherwise keep going
537  */
538 static int
539 ao_lisp_eval_while_test(void)
540 {
541         DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
542         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
543         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
544
545         if (ao_lisp_v) {
546                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
547                 if (ao_lisp_v)
548                         ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
549                 ao_lisp_stack->state = eval_while;
550                 if (!ao_lisp_stack_push())
551                         return 0;
552         }
553         else
554                 ao_lisp_stack->state = eval_val;
555         return 1;
556 }
557
558 static int (*const evals[])(void) = {
559         [eval_sexpr] = ao_lisp_eval_sexpr,
560         [eval_val] = ao_lisp_eval_val,
561         [eval_formal] = ao_lisp_eval_formal,
562         [eval_exec] = ao_lisp_eval_exec,
563         [eval_cond] = ao_lisp_eval_cond,
564         [eval_cond_test] = ao_lisp_eval_cond_test,
565         [eval_progn] = ao_lisp_eval_progn,
566         [eval_while] = ao_lisp_eval_while,
567         [eval_while_test] = ao_lisp_eval_while_test,
568 };
569
570 /*
571  * Called at restore time to reset all execution state
572  */
573
574 void
575 ao_lisp_eval_clear_globals(void)
576 {
577         ao_lisp_stack = NULL;
578         ao_lisp_frame_current = NULL;
579         ao_lisp_v = AO_LISP_NIL;
580 }
581
582 int
583 ao_lisp_eval_restart(void)
584 {
585         return ao_lisp_stack_push();
586 }
587
588 ao_poly
589 ao_lisp_eval(ao_poly _v)
590 {
591         ao_lisp_v = _v;
592
593         if (!ao_lisp_stack_push())
594                 return AO_LISP_NIL;
595
596         while (ao_lisp_stack) {
597                 if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) {
598                         ao_lisp_stack_clear();
599                         return AO_LISP_NIL;
600                 }
601         }
602         DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");});
603         ao_lisp_frame_current = NULL;
604         return ao_lisp_v;
605 }