From: Kaz Wesley Date: Sun, 28 Jan 2018 03:48:14 +0000 (-0800) Subject: Define UVECTOR and ATOM X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=58a5ffdfec139a0c9d399f603b77a764ae8607f7;p=muddle-interpreter.git Define UVECTOR and ATOM Signed-off-by: Kaz Wesley --- diff --git a/src/Makefile.am b/src/Makefile.am index 2da8bbd..922b9b6 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -1,3 +1,3 @@ bin_PROGRAMS = muddle -muddle_SOURCES = main.c read.c eval.c print.c alloc.c object.c +muddle_SOURCES = main.c read.c eval.c print.c alloc.c object.c atom.c muddle_CFLAGS = -Wall -Wno-unused-function -Werror=implicit-function-declaration -Werror=incompatible-pointer-types diff --git a/src/alloc.h b/src/alloc.h index 2c7e6a0..58ee808 100644 --- a/src/alloc.h +++ b/src/alloc.h @@ -34,10 +34,15 @@ object *HEAP_OBJECT (heap_ptr p); pool_ptr pool_alloc (uint32_t len); heap_ptr heap_alloc (uint32_t len); +inline static heap_ptr +heap_alloc_uv (uint32_t len) +{ + return heap_alloc ((len + 1) >> 1); +} // given a headerless array of objects of known size, // copy it backwards into newly-allocated pool space -pool_ptr pool_copy_array_rev (const pool_object *objs, uint32_t len); -heap_ptr heap_copy_array_rev (const object *objs, uint32_t len); +pool_ptr pool_copy_array_rev (const pool_object * objs, uint32_t len); +heap_ptr heap_copy_array_rev (const object * objs, uint32_t len); #endif // ALLOC_H diff --git a/src/atom.c b/src/atom.c new file mode 100644 index 0000000..38cadc0 --- /dev/null +++ b/src/atom.c @@ -0,0 +1,20 @@ +/* +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 +Foundation, either version 3 of the License, or (at your option) any +later version. + +This file is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Affero General Public License for more details. + +You should have received a copy of the GNU Affero General Public +License along with this file. If not, see +. +*/ + +#include "alloc.h" +#include "atom.h" diff --git a/src/atom.h b/src/atom.h new file mode 100644 index 0000000..5b71ad3 --- /dev/null +++ b/src/atom.h @@ -0,0 +1,34 @@ +/* +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 +Foundation, either version 3 of the License, or (at your option) any +later version. + +This file is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Affero General Public License for more details. + +You should have received a copy of the GNU Affero General Public +License along with this file. If not, see +. +*/ + +#ifndef ATOM_H +#define ATOM_H + +#include "object.h" + +typedef struct +{ + evaltype type; // UNBOUND/LOCI + // bindid + // value ptr + // oblist ptr + // type ptr + const char pname[]; +} atom_body; + +#endif diff --git a/src/eval.c b/src/eval.c index e563fdf..f322946 100644 --- a/src/eval.c +++ b/src/eval.c @@ -111,25 +111,25 @@ eval_rest () // store result of previous call pool_object *prev_res = as_pool (&ret); list_object *tail = as_list (&cf->locals[1]); - *POOL_OBJECT (tail->head) = (pool_object) + *POOL_OBJECT (tail->val.head) = (pool_object) { - .type = prev_res->type,.rest = tail->head + 1,.val = prev_res->val}; + .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val}; // 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) + assert (args->val.head); + args->val.head = POOL_OBJECT (args->val.head)->rest; + if (!args->val.head) { - POOL_OBJECT (tail->head)->rest = 0; + POOL_OBJECT (tail->val.head)->rest = 0; RETURN (cf->locals[0]); } - tail->head++; + tail->val.head++; // eval next element END_LOCALS (); - CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->head), 1), + CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1), eval_rest); } @@ -145,7 +145,7 @@ eval () case EVALTYPE_LIST: // Handle `head` now; then iterate on `.rest`. - if (!cf->args.body[0].list.head) + if (!cf->args.body[0].list.val.head) RETURN (cf->args.body[0]); // locals: { list_object list, list_object tail } cst += 2; @@ -157,11 +157,11 @@ eval () END_LOCALS (); CALL_THEN (eval, new_tuple ((object *) - POOL_OBJECT (cf->args.body[0].list.head), 1), + POOL_OBJECT (cf->args.body[0].list.val.head), 1), eval_rest); case EVALTYPE_FORM: // `<>` is a special case. - if (!cf->args.body[0].list.head) + if (!cf->args.body[0].list.val.head) { cf->args.body[0].type = EVALTYPE_FALSE; RETURN (cf->args.body[0]); @@ -170,7 +170,7 @@ eval () END_LOCALS (); CALL_THEN (eval, new_tuple ((object *) - POOL_OBJECT (cf->args.body[0].list.head), 1), + POOL_OBJECT (cf->args.body[0].list.val.head), 1), call); /* case EVALTYPE_VECTOR: TAILCALL(eval_vector); diff --git a/src/main.c b/src/main.c index 0819cc9..6645f6e 100644 --- a/src/main.c +++ b/src/main.c @@ -105,9 +105,9 @@ main () // Eval the thing cf->prevcst = cst; push_frame (eval, new_tuple (st.pos, 1), 0); - while (cf->cont.fn) + while (cf->cont.val.fn) { - cf->cont.fn (); + cf->cont.val.fn (); } // Print the thing print_object (&ret); diff --git a/src/object.c b/src/object.c index a2a81a6..ff65f41 100644 --- a/src/object.c +++ b/src/object.c @@ -21,7 +21,7 @@ License along with this file. If not, see uint32_t list_length (const list_object * o) { - const pool_object *p = POOL_OBJECT (o->head); + const pool_object *p = POOL_OBJECT (o->val.head); uint32_t n = 0; while (p) { diff --git a/src/object.h b/src/object.h index 1d9918e..ec322b5 100644 --- a/src/object.h +++ b/src/object.h @@ -31,14 +31,18 @@ typedef uint32_t evaltype; enum { // pool OK + TYPEPRIM_LOSE = 0x00000000, TYPEPRIM_FIX32 = 0x00010000, TYPEPRIM_FIX64 = 0x00020000, TYPEPRIM_LIST = 0x00030000, TYPEPRIM_VECTOR = 0x00040000, - TYPEPRIM_SUBR = 0x00050000, + TYPEPRIM_UVECTOR = 0x00050000, + TYPEPRIM_SUBR = 0x00060000, + TYPEPRIM_ATOM = 0x00070000, // can't be in pool TYPEPRIM_NOPOOL_MASK = 0x70000000, + TYPEPRIM_VECTOR_BODY = 0x70000000, TYPEPRIM_TUPLE = 0x70010000, // TYPEPRIM is half of EVALTYPE @@ -47,6 +51,8 @@ enum enum { + EVALTYPE_LOSE = TYPEPRIM_LOSE, + EVALTYPE_FIX32 = TYPEPRIM_FIX32, EVALTYPE_FIX64 = TYPEPRIM_FIX64, @@ -57,8 +63,16 @@ enum EVALTYPE_VECTOR = TYPEPRIM_VECTOR, + EVALTYPE_UVECTOR = TYPEPRIM_UVECTOR, + EVALTYPE_OBLIST, + EVALTYPE_SUBR = TYPEPRIM_SUBR, + EVALTYPE_ATOM = TYPEPRIM_ATOM, + + EVALTYPE_VECTOR_BODY = TYPEPRIM_VECTOR_BODY, + EVALTYPE_ATOM_BODY, + EVALTYPE_TUPLE = TYPEPRIM_TUPLE, }; @@ -106,44 +120,88 @@ about types. typedef union object object; +typedef struct +{ + alignas (8) uint32_t _pad; + int32_t n; +} fix32_val; typedef struct { alignas (16) evaltype type; pool_ptr rest; - uint32_t _pad; - int32_t val; + fix32_val val; } fix32_object; +typedef struct +{ + alignas (8) int64_t n; +} fix64_val; typedef struct { alignas (16) evaltype type; pool_ptr rest; - int64_t val; + fix64_val val; } fix64_object; +typedef struct +{ + alignas (8) uint32_t _pad; + pool_ptr head; +} list_val; typedef struct { alignas (16) evaltype type; pool_ptr rest; - uint32_t _pad; - pool_ptr head; + list_val val; } list_object; +typedef struct +{ + alignas (8) uint32_t len; + heap_ptr body; +} vector_val; typedef struct { alignas (16) evaltype type; pool_ptr rest; - uint32_t len; - heap_ptr body; + vector_val val; } vector_object; +typedef struct +{ + alignas (8) uint32_t len; + heap_ptr body; +} uvector_val; +typedef struct +{ + alignas (16) evaltype type; + pool_ptr rest; + uvector_val val; +} uvector_object; + +typedef struct +{ + alignas (8) void (*fn) (); +} subr_val; typedef struct { alignas (16) evaltype type; pool_ptr rest; - void (*fn) (); + subr_val val; } subr_object; +typedef struct +{ + alignas (8) uint32_t _pad; + heap_ptr body; +} atom_val; +typedef struct +{ + alignas (16) evaltype type; + pool_ptr rest; + atom_val val; +} atom_object; + typedef struct { alignas (16) @@ -155,6 +213,14 @@ typedef struct // uniq_id uid ?? } tuple_object; +typedef struct +{ + alignas (16) evaltype type; + uint32_t grow; + uint32_t len; + uint32_t gc; +} dope_object; + /// Object of a type that can be stored in the pool. /// NB. a pool_object* can point outside the pool; contrast with pool_ptr. typedef union pool_object @@ -162,6 +228,7 @@ typedef union pool_object /// any pool object has a type and a rest struct { + // NB. never take the address of these type-punned fields! alignas (16) evaltype type; pool_ptr rest; opaque64 val; @@ -171,13 +238,28 @@ typedef union pool_object fix64_object fix64; list_object list; vector_object vector; + uvector_object uvector; + atom_object atom; } pool_object; +/// Value half of a poolable object, for storage in a uvector. +typedef union +{ + fix32_val fix32; + fix64_val fix64; + list_val list; + vector_val vector; + uvector_val uvector; + subr_val subr; + atom_val atom; +} uv_val; + union object { /// any object has a type struct { + // NB. never take the address of these type-punned fields! alignas (16) evaltype type; opaque32 _unknown0; opaque64 _unknown1; @@ -189,6 +271,8 @@ union object fix64_object fix64; list_object list; vector_object vector; + uvector_object uvector; + atom_object atom; tuple_object tuple; }; @@ -201,7 +285,10 @@ new_fix32 (int32_t n) { return (fix32_object) { - .type = EVALTYPE_FIX32,.rest = 0,.val = n}; + .type = EVALTYPE_FIX32,.rest = 0,.val = (fix32_val) + { + .n = n} + }; } static inline fix64_object @@ -209,7 +296,10 @@ new_fix64 (int64_t n) { return (fix64_object) { - .type = EVALTYPE_FIX64,.rest = 0,.val = n}; + .type = EVALTYPE_FIX64,.rest = 0,.val = (fix64_val) + { + .n = n} + }; } static inline list_object @@ -217,7 +307,10 @@ new_list (pool_ptr head) { return (list_object) { - .type = EVALTYPE_LIST,.rest = 0,.head = head,}; + .type = EVALTYPE_LIST,.rest = 0,.val = (list_val) + { + .head = head} + ,}; } static inline vector_object @@ -225,7 +318,21 @@ new_vector (heap_ptr body, uint32_t length) { return (vector_object) { - .type = EVALTYPE_VECTOR,.rest = 0,.len = length,.body = body,}; + .type = EVALTYPE_VECTOR,.rest = 0,.val = (vector_val) + { + .len = length,.body = body} + ,}; +} + +static inline uvector_object +new_uvector (heap_ptr body, uint32_t length) +{ + return (uvector_object) + { + .type = EVALTYPE_VECTOR,.rest = 0,.val = (uvector_val) + { + .len = length,.body = body} + }; } static inline tuple_object @@ -233,7 +340,7 @@ new_tuple (object * body, uint32_t length) { return (tuple_object) { - .type = EVALTYPE_TUPLE,.len = length,.body = body,}; + .type = EVALTYPE_TUPLE,.len = length,.body = body}; } static inline subr_object @@ -241,7 +348,21 @@ new_subr (void (*fn) ()) { return (subr_object) { - .type = EVALTYPE_SUBR,.rest = 0,.fn = fn,}; + .type = EVALTYPE_SUBR,.rest = 0,.val = (subr_val) + { + .fn = fn} + }; +} + +static inline atom_object +new_atom (pool_ptr body) +{ + return (atom_object) + { + .type = EVALTYPE_ATOM,.rest = 0,.val = (atom_val) + { + .body = body} + }; } /** @@ -268,6 +389,13 @@ as_vector (object * o) return &o->vector; } +static inline uvector_object * +as_uvector (object * o) +{ + assert (TYPEPRIM_EQ (o->type, EVALTYPE_UVECTOR)); + return &o->uvector; +} + static inline pool_object * as_pool (object * p) { diff --git a/src/print.c b/src/print.c index 8f089a3..3a5866a 100644 --- a/src/print.c +++ b/src/print.c @@ -27,12 +27,12 @@ License along with this file. If not, see static void print_vector_body (const vector_object * o) { - const object *p = HEAP_OBJECT (o->body); + const object *p = HEAP_OBJECT (o->val.body); if (!p) return; - if (o->len) + if (o->val.len) print_object (&p[0]); - for (uint32_t i = 1; i < o->len; i++) + for (uint32_t i = 1; i < o->val.len; i++) { printf (" "); print_object (&p[i]); @@ -42,7 +42,7 @@ print_vector_body (const vector_object * o) static void print_list_body (const list_object * o) { - const pool_object *p = POOL_OBJECT (o->head); + const pool_object *p = POOL_OBJECT (o->val.head); if (!p) return; print_object ((const object *) p); @@ -59,10 +59,10 @@ print_object (const object * o) switch (o->type) { case EVALTYPE_FIX32: - printf ("%d", o->fix32.val); + printf ("%d", o->fix32.val.n); break; case EVALTYPE_FIX64: - printf ("%ld", o->fix64.val); + printf ("%ld", o->fix64.val.n); break; case EVALTYPE_LIST: printf ("("); diff --git a/src/read.c b/src/read.c index dd12916..b8570f3 100644 --- a/src/read.c +++ b/src/read.c @@ -114,7 +114,7 @@ static uint32_t obj_get_fix32(const object *o) { */ static int -read_num (const char *p, reader_stack *st) +read_num (const char *p, reader_stack * st) { int i = 0; // Use an unsigned intermediate to simplify overflow checks. @@ -151,7 +151,7 @@ read_num (const char *p, reader_stack *st) if (p[0] != '-') { if (x <= INT32_MAX) - (--(st->pos))->fix32 = new_fix32 ((int32_t)x); + (--(st->pos))->fix32 = new_fix32 ((int32_t) x); else if (x <= INT64_MAX) (--(st->pos))->fix64 = new_fix64 (x); else @@ -159,24 +159,24 @@ read_num (const char *p, reader_stack *st) } else { - if (-x >= (uint64_t)INT32_MIN) - (--(st->pos))->fix32 = new_fix32 (0 - (int32_t)x); - else if (-x >= (uint64_t)INT64_MIN) - (--(st->pos))->fix64 = new_fix64 (0 - (int64_t)x); + if (-x >= (uint64_t) INT32_MIN) + (--(st->pos))->fix32 = new_fix32 (0 - (int32_t) x); + else if (-x >= (uint64_t) INT64_MIN) + (--(st->pos))->fix64 = new_fix64 (0 - (int64_t) x); else goto read_float; } st->framelen++; return i; - read_float: - assert(0 && "unimplemented: promote num to float"); +read_float: + assert (0 && "unimplemented: promote num to float"); return i; } // stack[0..len]: objs in current list // stack[len]: parent len const char * -read_token (const char *p, reader_stack *st) +read_token (const char *p, reader_stack * st) { p += count_whitespace (p); switch (p[0]) @@ -206,7 +206,10 @@ read_token (const char *p, reader_stack *st) } *--(st->pos) = (object) { - .fix32.type = type,.fix32.rest = 0,.fix32.val = st->framelen,}; + .fix32.type = type,.fix32.rest = 0,.fix32.val = (fix32_val) + { + .n = st->framelen} + ,}; st->framelen = 0; break; } @@ -231,11 +234,10 @@ read_token (const char *p, reader_stack *st) // pop frame, push new LIST st->pos += st->framelen; assert (st->pos->type == type); - st->framelen = st->pos->fix32.val + 1; + st->framelen = st->pos->fix32.val.n + 1; // overwrite the frame marker with the collection it became - st->pos->list = (list_object) - { - .type = type,.rest = 0,.head = o}; + st->pos->list = new_list (o); + st->pos->list.type = type; break; } case ']': @@ -247,7 +249,7 @@ read_token (const char *p, reader_stack *st) uint32_t len = st->framelen; st->pos += st->framelen; assert (st->pos->type == EVALTYPE_VECTOR); - st->framelen = st->pos->fix32.val + 1; + st->framelen = st->pos->fix32.val.n + 1; st->pos->vector = new_vector (h, len); break; } @@ -257,7 +259,13 @@ read_token (const char *p, reader_stack *st) if (n) return p + n; - // TODO: try read pname + n = count_pname (p); + if (n > 0) + { + (--(st->pos))->atom = new_atom (0); + st->framelen++; + return p + n; + } fprintf (stderr, "read unimplemented for char: '%c'\n", *p); assert (0 && "read unimplemented for char");