From: Kaz Wesley Date: Thu, 18 Jan 2018 22:25:02 +0000 (-0800) Subject: Implement EVAL for LISTs X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=6c1eef40f411ff4eec7a3f7599a81be7fae07e2a;p=muddle-interpreter.git Implement EVAL for LISTs Signed-off-by: Kaz Wesley --- diff --git a/src/alloc.c b/src/alloc.c index 7209060..24f102b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -19,20 +19,40 @@ License along with this file. If not, see #include "alloc.h" #include "object.h" +extern pool_object *pool; +extern pool_ptr ptop; + +pool_ptr +pool_alloc (uint32_t len) +{ + pool_ptr p = ptop; + ptop += len; + return p; +} + +pool_object * +POOL_OBJECT (pool_ptr p) +{ + if (!p) + return (pool_object *) 0; + return &pool[p]; +} + pool_ptr pool_copy_array_rev (const pool_object * objs, uint32_t len) { if (!len) return 0; - pool_object *xs = pool_alloc (len); - for (int i = 0; i < (int) len; i++) + pool_ptr p = pool_alloc (len); + for (int i = 0; i < len; i++) { - xs[i].type = objs[len - 1 - (unsigned) i].type; - xs[i].rest = POOL_PTR (&xs[i + 1]); - xs[i].val = objs[len - 1 - (unsigned) i].val; + pool[p + i] = (pool_object) + { + .type = objs[len - i - 1].type,.rest = p + i + 1,.val = + objs[len - i - 1].val}; } - xs[len - 1].rest = 0; - return POOL_PTR (xs); + pool[p + len - 1].rest = 0; + return p; } heap_ptr diff --git a/src/alloc.h b/src/alloc.h index 239a7e0..594ee87 100644 --- a/src/alloc.h +++ b/src/alloc.h @@ -23,38 +23,18 @@ License along with this file. If not, see #include #include -/// 0, or a "pointer" to an object allocated in the pool and fully-initialized +/// 0, or a "pointer" to an object allocated in the pool typedef uint32_t pool_ptr; -/// 0, or a "pointer" to an object allocated in the heap and fully-initialized +/// 0, or a "pointer" to an object allocated in the heap typedef int32_t heap_ptr; typedef union pool_object pool_object; typedef union object object; -extern char *pool; // pool_object extern char *vhp_base; // object extern char *vhp; // object -static inline pool_object * -POOL_OBJECT (pool_ptr p) -{ - return (pool_object *) (uintptr_t) p; -} - -static inline bool -IS_VALID_POOL_OBJECT (pool_object * p) -{ - pool_ptr pp = (pool_ptr) (uintptr_t) p; - return (uintptr_t) pp == (uintptr_t) p; -} - -static inline pool_ptr -POOL_PTR (pool_object * p) -{ - pool_ptr pp = (pool_ptr) (uintptr_t) p; - assert (IS_VALID_POOL_OBJECT (p)); - return pp; -} +pool_object *POOL_OBJECT (pool_ptr p); // TODO make (heap_ptr)0 nullish static inline object * @@ -64,13 +44,7 @@ OBJECT_OF_HEAP_PTR (heap_ptr p) return (object *) (vhp_base + (p << 4)); } -static inline pool_object * -pool_alloc (uint32_t len) -{ - char *pp = pool; - pool += (len << 4); - return (pool_object *) pp; -} +pool_ptr pool_alloc (uint32_t len); static inline heap_ptr HEAP_PTR_OF_OBJECT (object * p) diff --git a/src/eval.c b/src/eval.c index 7bbcad7..e563fdf 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1,5 +1,5 @@ /* -Copyright (C) 2017 Keziah Wesley +Copyright (C) 2017-2018 Keziah Wesley You can redistribute and/or modify this file under the terms of the GNU Affero General Public License as published by the Free Software @@ -47,10 +47,13 @@ void pop_frame () { cf = (frame *) cf->prevframe.body; - cst = (object *) cf - sizeof (frame) / sizeof (object); + cst = cf->prevcst; } #define RETURN(x) do { ret = (x); pop_frame(); return; } while (0) +// invoke before pushing args onto stack for child call +// TODO: replace with PUSH_ARG interface? +#define END_LOCALS() do { cf->prevcst = cst; } while (0) #define CALL_THEN(fn, args, cont) do { push_frame(fn, args, cont); return; } while (0) #define TAILCALL(fn) do { cf->cont = fn; return; } while (0) @@ -65,21 +68,69 @@ pop_frame () return mcall(evaluator, len); */ +/* +2 ways to call an applicable: +- generically: `` +- applicably: `` + +generic calls must perform wrapping + */ + +// * applicable (SUBR / simple FUNCTION): eval whole form, call impl +// * FSUBR: call impl +// * complex FUNCTION: call impl + +// Upon initial entry, `cf->args.body[0]` is the FORM, and +// `ret` is the result of evaluating the FORM's first position. +// Typically, the first position will be an ATOM, which is +// self-evaluating; its value is to be looked up according to the +// first-position resolution rules: +// * look for a GVAL +// * look for a LVAL static void -eval_list () +call () +{ + switch (ret.type) + { + /* + case EVALTYPE_ATOM: + break; + case EVALTYPE_FIX32: + case EVALTYPE_FIX64: + break; + */ + default: + assert (0 && "I don't know how to call that"); + } +} + +// locals: { list_object list, list_object tail } +static void +eval_rest () { // store result of previous call - cf->locals[1] = ret; + pool_object *prev_res = as_pool (&ret); + list_object *tail = as_list (&cf->locals[1]); + *POOL_OBJECT (tail->head) = (pool_object) + { + .type = prev_res->type,.rest = tail->head + 1,.val = prev_res->val}; - // get next input, and advance input pointer - pool_ptr rest_in = as_list(&cf->args.body[0])->head; - if (!rest_in) - RETURN(cf->locals[0]); - POOL_OBJECT(as_list(&cf->locals[1])->head)->rest = - as_list(&cf->locals[1])->head + (pool_ptr)sizeof(pool_object); + // advance input and output + assert (cf->args.len == 1); + list_object *args = as_list (&cf->args.body[0]); + assert (args->head); + args->head = POOL_OBJECT (args->head)->rest; + if (!args->head) + { + POOL_OBJECT (tail->head)->rest = 0; + RETURN (cf->locals[0]); + } + tail->head++; // eval next element - CALL_THEN (eval, new_tuple ((object*)POOL_OBJECT(rest_in), 1), eval_list); + END_LOCALS (); + CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->head), 1), + eval_rest); } void @@ -93,6 +144,7 @@ eval () RETURN (cf->args.body[0]); case EVALTYPE_LIST: // Handle `head` now; then iterate on `.rest`. + if (!cf->args.body[0].list.head) RETURN (cf->args.body[0]); // locals: { list_object list, list_object tail } @@ -100,11 +152,27 @@ eval () // Allocate the new list contiguously and keep track of the // current tail so we can build it in forward order. cf->locals[0].list = - new_list (POOL_PTR (pool_alloc (list_length (&cf->args.body[0].list)))); + new_list (pool_alloc (list_length (&cf->args.body[0].list))); cf->locals[1] = cf->locals[0]; - CALL_THEN (eval, new_tuple ((object*)POOL_OBJECT (cf->args.body[0].list.head), 1), eval_list); + END_LOCALS (); + CALL_THEN (eval, + new_tuple ((object *) + POOL_OBJECT (cf->args.body[0].list.head), 1), + eval_rest); + case EVALTYPE_FORM: + // `<>` is a special case. + if (!cf->args.body[0].list.head) + { + cf->args.body[0].type = EVALTYPE_FALSE; + RETURN (cf->args.body[0]); + } + // Eval first position, then apply to args + END_LOCALS (); + CALL_THEN (eval, + new_tuple ((object *) + POOL_OBJECT (cf->args.body[0].list.head), 1), + call); /* - case EVALTYPE_FORM: TAILCALL(eval_form); case EVALTYPE_VECTOR: TAILCALL(eval_vector); */ default: diff --git a/src/eval.h b/src/eval.h index 22b5374..7318c9d 100644 --- a/src/eval.h +++ b/src/eval.h @@ -24,6 +24,7 @@ License along with this file. If not, see void eval (); void push_frame (void (*fn) (), tuple_object args, void (*cont) ()); +/* TODO: don't expose this in header */ // stack: // <0> args... // <0> frametop @@ -39,6 +40,7 @@ struct frame tuple_object args; tuple_object prevframe; // <0> framebottom (state saved before child call) + object *prevcst; // <0> temps, <1> args object locals[]; diff --git a/src/main.c b/src/main.c index b57ee6d..6c6124e 100644 --- a/src/main.c +++ b/src/main.c @@ -1,5 +1,5 @@ /* -Copyright (C) 2017 Keziah Wesley +Copyright (C) 2017-2018 Keziah Wesley You can redistribute and/or modify this file under the terms of the GNU Affero General Public License as published by the Free Software @@ -26,7 +26,8 @@ License along with this file. If not, see #include // TODO: put these in interpreter-wide ctx object -char *pool; +pool_object *pool; +pool_ptr ptop; char *vhp_base; char *vhp; @@ -53,10 +54,10 @@ int main () { // The REST pool (in low mem). - char *pool_base = + pool = mmap (0, POOL_OBJCT * sizeof (object), PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0); - pool = pool_base; + ptop = 1; // 0 is null // The CONTROL STACKs (TODO: per-PROCESS). object *cst_base = @@ -83,7 +84,7 @@ main () while ((n = read (STDIN_FILENO, buf, sizeof (buf))) > 0) { // mock GC (no object persistence) - pool = pool_base; + ptop = 1; vhp = vhp_base; // terminate input assert (buf[n - 1] == '\n'); @@ -99,10 +100,10 @@ main () } assert (p); if (!st.framelen) - continue; + continue; assert (st.framelen == 1); - /* // Eval the thing + cf->prevcst = cst; push_frame (eval, new_tuple (st.pos, 1), 0); while (cf->cont.fn) { @@ -110,15 +111,12 @@ main () } // Print the thing print_object (&ret); - */ - // debugging: print without eval - print_object (st.pos); printf ("\n"); // Loop! } munmap (cst_base, STACK_OBJCT * sizeof (object)); munmap (vhp_base, VECTOR_OBJCT * sizeof (object)); - munmap (pool_base, POOL_OBJCT * sizeof (object)); + munmap (pool, POOL_OBJCT * sizeof (object)); return 0; } diff --git a/src/object.h b/src/object.h index cb1ade1..80c886e 100644 --- a/src/object.h +++ b/src/object.h @@ -53,6 +53,7 @@ enum EVALTYPE_LIST = TYPEPRIM_LIST, EVALTYPE_FORM, + EVALTYPE_FALSE, EVALTYPE_VECTOR = TYPEPRIM_VECTOR, @@ -262,8 +263,7 @@ as_vector (object * o) static inline pool_object * as_pool (object * p) { - if (TYPEPRIM (p->type) & TYPEPRIM_NOPOOL_MASK) - return 0; + assert (!(TYPEPRIM (p->type) & TYPEPRIM_NOPOOL_MASK)); return (pool_object *) p; }