From 11cb03b1d336ee90c422be27588f57be573a9546 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 2 Nov 2016 22:56:01 -0700 Subject: [PATCH] altos/lisp: Separate out values from atoms This enables changing values of atoms declared as constants, should enable lets, and with some work, even lexical scoping. this required changing the constant computation to run ao_lisp_collect() before dumping the block of constant data, and that uncovered some minor memory manager bugs. Signed-off-by: Keith Packard --- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 105 ++++++++++++++----- src/lisp/ao_lisp_atom.c | 51 +++++++-- src/lisp/ao_lisp_builtin.c | 37 +++++-- src/lisp/ao_lisp_cons.c | 27 ++++- src/lisp/ao_lisp_eval.c | 5 +- src/lisp/ao_lisp_frame.c | 191 ++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_make_const.c | 44 +++++++- src/lisp/ao_lisp_mem.c | 168 +++++++++++++++++++++++++----- src/lisp/ao_lisp_prim.c | 41 ++++---- src/lisp/ao_lisp_read.c | 23 ++-- src/nucleao-32/Makefile | 3 + src/test/Makefile | 4 +- src/test/ao_lisp_test.c | 3 +- 14 files changed, 597 insertions(+), 108 deletions(-) create mode 100644 src/lisp/ao_lisp_frame.c diff --git a/src/lisp/Makefile b/src/lisp/Makefile index e8c3c02c..9e2fb58c 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -16,7 +16,8 @@ SRCS=\ ao_lisp_poly.c \ ao_lisp_prim.c \ ao_lisp_builtin.c \ - ao_lisp_read.c + ao_lisp_read.c \ + ao_lisp_frame.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d4108662..98e99acb 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,9 +15,12 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ +#include + #if !defined(AO_LISP_TEST) && !defined(AO_LISP_MAKE_CONST) #include #define AO_LISP_ALTOS 1 +#define abort() ao_panic(1) #endif #include @@ -27,9 +30,14 @@ #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#define ao_lisp_pool ao_lisp_const +#define AO_LISP_POOL AO_LISP_POOL_CONST #define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) +#define _ao_lisp_atom_set ao_lisp_atom_poly(ao_lisp_atom_intern("set")) #else #include "ao_lisp_const.h" +#define AO_LISP_POOL 1024 +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #endif /* Primitive types */ @@ -46,13 +54,11 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; /* These have a type value at the start of the struct */ #define AO_LISP_ATOM 4 #define AO_LISP_BUILTIN 5 -#define AO_LISP_NUM_TYPE 6 +#define AO_LISP_FRAME 6 +#define AO_LISP_NUM_TYPE 7 #define AO_LISP_NIL 0 -#define AO_LISP_POOL 1024 - -extern uint8_t ao_lisp_pool[AO_LISP_POOL]; extern uint16_t ao_lisp_top; #define AO_LISP_OOM 0x01 @@ -68,37 +74,31 @@ ao_lisp_is_const(ao_poly poly) { return poly & AO_LISP_CONST; } +#define AO_LISP_POOL_BASE (ao_lisp_pool - 4) +#define AO_LISP_CONST_BASE (ao_lisp_const - 4) + +#define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) +#define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) + static inline void * ao_lisp_ref(ao_poly poly) { if (poly == AO_LISP_NIL) return NULL; if (poly & AO_LISP_CONST) - return (void *) ((ao_lisp_const - 4) + (poly & AO_LISP_REF_MASK)); - else - return (void *) ((ao_lisp_pool - 4) + (poly & AO_LISP_REF_MASK)); + return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); + return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); } static inline ao_poly ao_lisp_poly(const void *addr, ao_poly type) { const uint8_t *a = addr; - if (addr == NULL) + if (a == NULL) return AO_LISP_NIL; - if (ao_lisp_pool <= a && a < ao_lisp_pool + AO_LISP_POOL) - return (a - (ao_lisp_pool - 4)) | type; - else if (ao_lisp_const <= a && a <= ao_lisp_const + AO_LISP_POOL_CONST) - return AO_LISP_CONST | (a - (ao_lisp_const - 4)) | type; - else { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } + if (AO_LISP_IS_CONST(a)) + return AO_LISP_CONST | (a - AO_LISP_CONST_BASE) | type; + return (a - AO_LISP_POOL_BASE) | type; } -#define AO_LISP_POLY(addr, type) (((ao_lisp_pool <= ((uint8_t *) (a)) && \ - ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) ? \ - ((uint8_t *) (a) - (ao_lisp_pool - 4)) : \ - (((uint8_t *) (a) - (ao_lisp_const - 4)) | AO_LISP_POOL_CONST)) | \ - (type)) - struct ao_lisp_type { void (*mark)(void *addr); int (*size)(void *addr); @@ -113,11 +113,32 @@ struct ao_lisp_cons { struct ao_lisp_atom { uint8_t type; uint8_t pad[1]; - ao_poly val; ao_poly next; char name[]; }; +struct ao_lisp_val { + ao_poly atom; + ao_poly val; +}; + +struct ao_lisp_frame { + uint8_t num; + uint8_t readonly; + ao_poly next; + struct ao_lisp_val vals[]; +}; + +static inline struct ao_lisp_frame * +ao_lisp_poly_frame(ao_poly poly) { + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_frame_poly(struct ao_lisp_frame *frame) { + return ao_lisp_poly(frame, AO_LISP_OTHER); +} + #define AO_LISP_LAMBDA 0 #define AO_LISP_NLAMBDA 1 #define AO_LISP_MACRO 2 @@ -160,6 +181,11 @@ ao_lisp_poly_other(ao_poly poly) { return ao_lisp_ref(poly); } +static inline uint8_t +ao_lisp_other_type(void *other) { + return *((uint8_t *) other); +} + static inline ao_poly ao_lisp_other_poly(const void *other) { @@ -175,9 +201,9 @@ ao_lisp_mem_round(int size) #define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) static inline int ao_lisp_poly_type(ao_poly poly) { - int type = poly & 3; + int type = poly & AO_LISP_TYPE_MASK; if (type == AO_LISP_OTHER) - return *((uint8_t *) ao_lisp_poly_other(poly)); + return ao_lisp_other_type(ao_lisp_poly_other(poly)); return type; } @@ -249,6 +275,9 @@ ao_lisp_mark(const struct ao_lisp_type *type, void *addr); int ao_lisp_mark_memory(void *addr, int size); +void * +ao_lisp_move_map(void *addr); + void * ao_lisp_move(const struct ao_lisp_type *type, void *addr); @@ -259,6 +288,9 @@ ao_lisp_move_memory(void *addr, int size); void * ao_lisp_alloc(int size); +void +ao_lisp_collect(void); + int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); @@ -303,6 +335,12 @@ ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); +ao_poly +ao_lisp_atom_get(ao_poly atom); + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val); + /* int */ void ao_lisp_int_print(ao_poly i); @@ -325,6 +363,8 @@ ao_lisp_eval(ao_poly p); void ao_lisp_builtin_print(ao_poly b); +extern const struct ao_lisp_type ao_lisp_builtin_type; + /* read */ ao_poly ao_lisp_read(void); @@ -333,4 +373,19 @@ ao_lisp_read(void); ao_poly ao_lisp_read_eval_print(void); +/* frame */ +extern const struct ao_lisp_type ao_lisp_frame_type; + +int +ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom); + +struct ao_lisp_frame * +ao_lisp_frame_new(int num, int readonly); + +struct ao_lisp_frame * +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index aaa84b8d..e5d28c3b 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -17,6 +17,12 @@ #include "ao_lisp.h" +#if 0 +#define DBG(...) printf(__VA_ARGS__) +#else +#define DBG(...) +#endif + static int name_size(char *name) { return sizeof(struct ao_lisp_atom) + strlen(name) + 1; @@ -34,31 +40,38 @@ static void atom_mark(void *addr) { struct ao_lisp_atom *atom = addr; + DBG ("\tatom start %s\n", atom->name); for (;;) { - ao_lisp_poly_mark(atom->val); atom = ao_lisp_poly_atom(atom->next); if (!atom) break; + DBG("\t\tatom mark %s %d\n", atom->name, (uint8_t *) atom - ao_lisp_const); if (ao_lisp_mark_memory(atom, atom_size(atom))) break; } + DBG ("\tatom done\n"); } static void atom_move(void *addr) { struct ao_lisp_atom *atom = addr; + DBG("\tatom move start %s %d next %s %d\n", + atom->name, ((uint8_t *) atom - ao_lisp_const), + atom->next ? ao_lisp_poly_atom(atom->next)->name : "(none)", + atom->next ? ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const) : 0); for (;;) { struct ao_lisp_atom *next; - atom->val = ao_lisp_poly_move(atom->val); next = ao_lisp_poly_atom(atom->next); next = ao_lisp_move_memory(next, atom_size(next)); if (!next) break; + DBG("\t\tatom move %s %d->%d\n", next->name, ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const), ((uint8_t *) next - ao_lisp_const)); atom->next = ao_lisp_atom_poly(next); atom = next; } + DBG("\tatom move end\n"); } const struct ao_lisp_type ao_lisp_atom_type = { @@ -73,7 +86,6 @@ struct ao_lisp_atom * ao_lisp_atom_intern(char *name) { struct ao_lisp_atom *atom; -// int b; for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { if (!strcmp(atom->name, name)) @@ -85,19 +97,46 @@ ao_lisp_atom_intern(char *name) return atom; } #endif - if (!ao_lisp_atoms) - ao_lisp_root_add(&ao_lisp_atom_type, (void **) &ao_lisp_atoms); atom = ao_lisp_alloc(name_size(name)); if (atom) { atom->type = AO_LISP_ATOM; atom->next = ao_lisp_atom_poly(ao_lisp_atoms); + if (!ao_lisp_atoms) + ao_lisp_root_add(&ao_lisp_atom_type, &ao_lisp_atoms); ao_lisp_atoms = atom; strcpy(atom->name, name); - atom->val = AO_LISP_NIL; } return atom; } +static struct ao_lisp_frame *globals; + +ao_poly +ao_lisp_atom_get(ao_poly atom) +{ + struct ao_lisp_frame *frame = globals; +#ifdef ao_builtin_frame + if (!frame) + frame = ao_lisp_poly_frame(ao_builtin_frame); +#endif + return ao_lisp_frame_get(frame, atom); +} + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val) +{ + if (!ao_lisp_frame_set(globals, atom, val)) { + globals = ao_lisp_frame_add(globals, atom, val); + if (!globals->next) { + ao_lisp_root_add(&ao_lisp_frame_type, &globals); +#ifdef ao_builtin_frame + globals->next = ao_builtin_frame; +#endif + } + } + return val; +} + void ao_lisp_atom_print(ao_poly a) { diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 63fb69fd..8c481793 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -14,6 +14,31 @@ #include "ao_lisp.h" +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + void ao_lisp_builtin_print(ao_poly b) { @@ -120,20 +145,12 @@ ao_lisp_quote(struct ao_lisp_cons *cons) ao_poly ao_lisp_set(struct ao_lisp_cons *cons) { - ao_poly atom, val; if (!check_argc(cons, 2, 2)) return AO_LISP_NIL; if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) return AO_LISP_NIL; - atom = cons->car; - val = ao_lisp_poly_cons(cons->cdr)->car; - if (ao_lisp_is_const(atom)) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - ao_lisp_poly_atom(atom)->val = val; - return val; + return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car); } ao_poly @@ -157,6 +174,8 @@ ao_lisp_print(struct ao_lisp_cons *cons) val = cons->car; ao_lisp_poly_print(val); cons = ao_lisp_poly_cons(cons->cdr); + if (cons) + printf(" "); } return val; } diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 65908e30..f8a34ed4 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -14,6 +14,23 @@ #include "ao_lisp.h" +#define OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_const)) + +#if 0 +static int cons_depth; +#define DBG(...) do { int d; for (d = 0; d < cons_depth; d++) printf (" "); printf(__VA_ARGS__); } while(0) +#define DBG_IN() (cons_depth++) +#define DBG_OUT() (cons_depth--) +#define DBG_PR(c) ao_lisp_cons_print(ao_lisp_cons_poly(c)) +#define DBG_PRP(p) ao_lisp_poly_print(p) +#else +#define DBG(...) +#define DBG_IN() +#define DBG_OUT() +#define DBG_PR(c) +#define DBG_PRP(p) +#endif + static void cons_mark(void *addr) { struct ao_lisp_cons *cons = addr; @@ -38,17 +55,25 @@ static void cons_move(void *addr) { struct ao_lisp_cons *cons = addr; + DBG_IN(); + DBG("move cons start %d\n", OFFSET(cons)); for (;;) { struct ao_lisp_cons *cdr; + ao_poly car; - cons->car = ao_lisp_poly_move(cons->car); + car = ao_lisp_poly_move(cons->car); + DBG(" moved car %d -> %d\n", OFFSET(ao_lisp_ref(cons->car)), OFFSET(ao_lisp_ref(car))); + cons->car = car; cdr = ao_lisp_poly_cons(cons->cdr); cdr = ao_lisp_move_memory(cdr, sizeof (struct ao_lisp_cons)); if (!cdr) break; + DBG(" moved cdr %d -> %d\n", OFFSET(ao_lisp_poly_cons(cons->cdr)), OFFSET(cdr)); cons->cdr = ao_lisp_cons_poly(cdr); cons = cdr; } + DBG("move cons end\n"); + DBG_OUT(); } const struct ao_lisp_type ao_lisp_cons_type = { diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 2374fdb2..6eef1f23 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -91,7 +91,7 @@ ao_lisp_eval(ao_poly v) case AO_LISP_STRING: break; case AO_LISP_ATOM: - v = ao_lisp_poly_atom(v)->val; + v = ao_lisp_atom_get(v); break; } @@ -187,6 +187,9 @@ ao_lisp_eval(ao_poly v) DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); } else { + actuals = 0; + formals = 0; + formals_tail = 0; DBG("done func\n"); break; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c new file mode 100644 index 00000000..5aa50f6b --- /dev/null +++ b/src/lisp/ao_lisp_frame.c @@ -0,0 +1,191 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 + * General Public License for more details. + */ + +#include "ao_lisp.h" + +#if 0 +#define DBG(...) printf(__VA_ARGS__) +#else +#define DBG(...) +#endif + +static inline int +frame_num_size(int num) +{ + return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); +} + +static int +frame_size(void *addr) +{ + struct ao_lisp_frame *frame = addr; + return frame_num_size(frame->num); +} + +#define OFFSET(a) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const) + +static void +frame_mark(void *addr) +{ + struct ao_lisp_frame *frame = addr; + int f; + + for (;;) { + if (frame->readonly) + break; + for (f = 0; f < frame->num; f++) { + struct ao_lisp_val *v = &frame->vals[f]; + + ao_lisp_poly_mark(v->atom); + ao_lisp_poly_mark(v->val); + DBG ("\tframe mark atom %s %d val %d at %d\n", ao_lisp_poly_atom(v->atom)->name, OFFSET(v->atom), OFFSET(v->val), f); + } + frame = ao_lisp_poly_frame(frame->next); + if (!frame) + break; + if (ao_lisp_mark_memory(frame, frame_size(frame))) + break; + } +} + +static void +frame_move(void *addr) +{ + struct ao_lisp_frame *frame = addr; + int f; + + for (;;) { + struct ao_lisp_frame *next; + if (frame->readonly) + break; + for (f = 0; f < frame->num; f++) { + struct ao_lisp_val *v = &frame->vals[f]; + ao_poly t; + + t = ao_lisp_poly_move(v->atom); + DBG("\t\tatom %s %d -> %d\n", ao_lisp_poly_atom(t)->name, OFFSET(v->atom), OFFSET(t)); + v->atom = t; + t = ao_lisp_poly_move(v->val); + DBG("\t\tval %d -> %d\n", OFFSET(v->val), OFFSET(t)); + v->val = t; + } + next = ao_lisp_poly_frame(frame->next); + if (!next) + break; + next = ao_lisp_move_memory(next, frame_size(next)); + frame->next = ao_lisp_frame_poly(next); + frame = next; + } +} + +const struct ao_lisp_type ao_lisp_frame_type = { + .mark = frame_mark, + .size = frame_size, + .move = frame_move +}; + +static ao_poly * +ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ + int f; + for (f = 0; f < frame->num; f++) + if (frame->vals[f].atom == atom) + return &frame->vals[f].val; + return NULL; +} + +int +ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +{ + while (frame) { + if (!frame->readonly) { + ao_poly *ref = ao_lisp_frame_ref(frame, atom); + if (ref) { + *ref = val; + return 1; + } + } + frame = ao_lisp_poly_frame(frame->next); + } + return 0; +} + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +{ + while (frame) { + ao_poly *ref = ao_lisp_frame_ref(frame, atom); + if (ref) + return *ref; + frame = ao_lisp_poly_frame(frame->next); + } + return AO_LISP_NIL; +} + +struct ao_lisp_frame * +ao_lisp_frame_new(int num, int readonly) +{ + struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num)); + + if (!frame) + return NULL; + frame->num = num; + frame->readonly = readonly; + frame->next = AO_LISP_NIL; + memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); + return frame; +} + +static struct ao_lisp_frame * +ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num, int readonly) +{ + struct ao_lisp_frame *new; + int copy; + + if (new_num == frame->num) + return frame; + new = ao_lisp_frame_new(new_num, readonly); + if (!new) + return NULL; + copy = new_num; + if (copy > frame->num) + copy = frame->num; + memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); + if (frame) + new->next = frame->next; + return new; +} + +struct ao_lisp_frame * +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +{ + ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; + if (!ref) { + int f; + if (frame) { + f = frame->num; + frame = ao_lisp_frame_realloc(frame, f + 1, frame->readonly); + } else { + f = 0; + frame = ao_lisp_frame_new(1, 0); + } + if (!frame) + return NULL; + DBG ("add atom %s %d, val %d at %d\n", ao_lisp_poly_atom(atom)->name, OFFSET(atom), OFFSET(val), f); + frame->vals[f].atom = atom; + ref = &frame->vals[f].val; + } + *ref = val; + return frame; +} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 8d3e03a9..6b603979 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -49,19 +49,43 @@ struct builtin_func funcs[] = { #define N_FUNC (sizeof funcs / sizeof funcs[0]) +struct ao_lisp_frame *globals; + +static int +is_atom(int offset) +{ + struct ao_lisp_atom *a; + + for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) + if (((uint8_t *) a->name - ao_lisp_const) == offset) + return strlen(a->name); + return 0; +} + int main(int argc, char **argv) { int f, o; ao_poly atom, val; struct ao_lisp_atom *a; + int in_atom; + printf("/*\n"); + printf(" * Generated file, do not edit\n"); + ao_lisp_root_add(&ao_lisp_frame_type, &globals); + globals = ao_lisp_frame_new(0, 0); for (f = 0; f < N_FUNC; f++) { struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); struct ao_lisp_atom *a = ao_lisp_atom_intern(funcs[f].name); - a->val = ao_lisp_builtin_poly(b); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } + /* boolean constants */ + a = ao_lisp_atom_intern("nil"); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); + a = ao_lisp_atom_intern("t"); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); + for (;;) { atom = ao_lisp_read(); if (!atom) @@ -73,13 +97,19 @@ main(int argc, char **argv) fprintf(stderr, "input must be atom val pairs\n"); exit(1); } - ao_lisp_poly_atom(atom)->val = val; + globals = ao_lisp_frame_add(globals, atom, val); } - printf("/* constant objects, all referenced from atoms */\n\n"); + /* Reduce to referenced values */ + ao_lisp_collect(); + printf(" */\n"); + + globals->readonly = 1; + printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); + printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(globals)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; @@ -101,10 +131,14 @@ main(int argc, char **argv) else printf(" "); c = ao_lisp_const[o]; - if (' ' < c && c <= '~' && c != '\'') + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { printf (" '%c',", c); - else + in_atom--; + } else { printf("0x%02x,", c); + } } printf("\n};\n"); printf("#endif /* AO_LISP_CONST_BITS */\n"); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 7295d150..27f5b666 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -17,11 +17,32 @@ #include "ao_lisp.h" #include -uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); - #ifdef AO_LISP_MAKE_CONST #include uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); +#define ao_lisp_pool ao_lisp_const +#undef AO_LISP_POOL +#define AO_LISP_POOL AO_LISP_POOL_CONST +#else +uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); +#endif + +#if 0 +#define DBG_DUMP +#define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) +#define DBG(...) printf(__VA_ARGS__) +static int move_dump; +static int move_depth; +#define DBG_RESET() (move_depth = 0) +#define DBG_MOVE(...) do { if(move_dump) { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define DBG_MOVE_IN() (move_depth++) +#define DBG_MOVE_OUT() (move_depth--) +#else +#define DBG(...) +#define DBG_RESET() +#define DBG_MOVE(...) +#define DBG_MOVE_IN() +#define DBG_MOVE_OUT() #endif uint8_t ao_lisp_exception; @@ -112,6 +133,23 @@ clear_object(uint8_t *tag, void *addr, int size) { return 0; } +static int +busy_object(uint8_t *tag, void *addr) { + int base; + + if (!addr) + return 1; + + if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) + return 1; + + base = (uint8_t *) addr - ao_lisp_pool; + base = limit(base); + if (busy(tag, base)) + return 1; + return 0; +} + static void *move_old, *move_new; static int move_size; @@ -120,53 +158,96 @@ move_object(void) { int i; + DBG_RESET(); + DBG_MOVE("move %d -> %d\n", DBG_OFFSET(move_old), DBG_OFFSET(move_new)); + DBG_MOVE_IN(); memset(ao_lisp_moving, '\0', sizeof (ao_lisp_moving)); for (i = 0; i < AO_LISP_ROOT; i++) - if (ao_lisp_root[i].addr) { + if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) { void *new; + DBG_MOVE("root %d\n", DBG_OFFSET(*ao_lisp_root[i].addr)); new = ao_lisp_move(ao_lisp_root[i].type, *ao_lisp_root[i].addr); if (new) *ao_lisp_root[i].addr = new; } + DBG_MOVE_OUT(); + DBG_MOVE("move done\n"); } +#ifdef DBG_DUMP static void -collect(void) +dump_busy(void) +{ + int i; + printf("busy:"); + for (i = 0; i < ao_lisp_top; i += 4) { + if ((i & 0xff) == 0) + printf("\n"); + else if ((i & 0x1f) == 0) + printf(" "); + if (busy(ao_lisp_busy, i)) + putchar('*'); + else + putchar('-'); + } + printf ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +void +ao_lisp_collect(void) { int i; + int top; /* Mark */ memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); + DBG("mark\n"); for (i = 0; i < AO_LISP_ROOT; i++) - if (ao_lisp_root[i].addr) + if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) { + DBG("root %p\n", *ao_lisp_root[i].addr); ao_lisp_mark(ao_lisp_root[i].type, *ao_lisp_root[i].addr); + } + DUMP_BUSY(); /* Compact */ - ao_lisp_top = 0; - for (i = 0; i < AO_LISP_POOL; i += 4) { + DBG("find first busy\n"); + for (i = 0; i < ao_lisp_top; i += 4) { if (!busy(ao_lisp_busy, i)) break; } - ao_lisp_top = i; - while(i < AO_LISP_POOL) { + top = i; + while(i < ao_lisp_top) { if (busy(ao_lisp_busy, i)) { + DBG("busy %d -> %d\n", i, top); move_old = &ao_lisp_pool[i]; - move_new = &ao_lisp_pool[ao_lisp_top]; + move_new = &ao_lisp_pool[top]; move_size = 0; move_object(); + DBG("\tbusy size %d\n", move_size); + if (move_size == 0) + abort(); clear_object(ao_lisp_busy, move_old, move_size); + mark_object(ao_lisp_busy, move_new, move_size); i += move_size; - ao_lisp_top += move_size; + top += move_size; + DUMP_BUSY(); } else { i += 4; } } + ao_lisp_top = top; } void ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { + if (!addr) + return; if (mark_object(ao_lisp_busy, addr, type->size(addr))) return; type->mark(addr); @@ -178,12 +259,32 @@ ao_lisp_mark_memory(void *addr, int size) return mark_object(ao_lisp_busy, addr, size); } +/* + * After the object has been moved, we have to reference it + * in the new location. This is only relevant for ao_lisp_poly_move + * as it needs to fetch the type byte from the object, which + * may have been overwritten by the copy + */ +void * +ao_lisp_move_map(void *addr) +{ + if (addr == move_old) { + if (busy_object(ao_lisp_moving, addr)) + return move_new; + } + return addr; +} + static void * check_move(void *addr, int size) { if (addr == move_old) { - memmove(move_new, move_old, size); - move_size = (size + 3) & ~3; + DBG_MOVE("mapping %d -> %d\n", DBG_OFFSET(addr), DBG_OFFSET(move_new)); + if (!busy_object(ao_lisp_moving, addr)) { + DBG_MOVE(" copy %d\n", size); + memmove(move_new, move_old, size); + move_size = (size + 3) & ~3; + } addr = move_new; } return addr; @@ -192,15 +293,32 @@ check_move(void *addr, int size) void * ao_lisp_move(const struct ao_lisp_type *type, void *addr) { + uint8_t *a = addr; int size = type->size(addr); if (!addr) return NULL; +#ifndef AO_LISP_MAKE_CONST + if (AO_LISP_IS_CONST(addr)) + return addr; +#endif + DBG_MOVE("object %d\n", DBG_OFFSET(addr)); + if (a < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= a) + abort(); + DBG_MOVE_IN(); addr = check_move(addr, size); - if (mark_object(ao_lisp_moving, addr, size)) + if (mark_object(ao_lisp_moving, addr, size)) { + DBG_MOVE("already moved\n"); + DBG_MOVE_OUT(); return addr; + } + DBG_MOVE_OUT(); + DBG_MOVE("recursing...\n"); + DBG_MOVE_IN(); type->move(addr); + DBG_MOVE_OUT(); + DBG_MOVE("done %d\n", DBG_OFFSET(addr)); return addr; } @@ -210,9 +328,15 @@ ao_lisp_move_memory(void *addr, int size) if (!addr) return NULL; + DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); + DBG_MOVE_IN(); addr = check_move(addr, size); - if (mark_object(ao_lisp_moving, addr, size)) - return NULL; + if (mark_object(ao_lisp_moving, addr, size)) { + DBG_MOVE("already moved\n"); + DBG_MOVE_OUT(); + return addr; + } + DBG_MOVE_OUT(); return addr; } @@ -222,22 +346,14 @@ ao_lisp_alloc(int size) void *addr; size = ao_lisp_mem_round(size); -#ifdef AO_LISP_MAKE_CONST - if (ao_lisp_top + size > AO_LISP_POOL_CONST) { - fprintf(stderr, "Too much constant data, increase AO_LISP_POOL_CONST\n"); - exit(1); - } - addr = ao_lisp_const + ao_lisp_top; -#else if (ao_lisp_top + size > AO_LISP_POOL) { - collect(); + ao_lisp_collect(); if (ao_lisp_top + size > AO_LISP_POOL) { ao_lisp_exception |= AO_LISP_OOM; return NULL; } } addr = ao_lisp_pool + ao_lisp_top; -#endif ao_lisp_top += size; return addr; } @@ -246,6 +362,7 @@ int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) { int i; + DBG("add root type %p addr %p\n", type, addr); for (i = 0; i < AO_LISP_ROOT; i++) { if (!ao_lisp_root[i].addr) { ao_lisp_root[i].addr = addr; @@ -253,6 +370,7 @@ ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) return 1; } } + abort(); return 0; } diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 38dcb961..e9367553 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -31,35 +31,32 @@ ao_lisp_poly_print(ao_poly p) return p; } +static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = &ao_lisp_cons_type, + [AO_LISP_STRING] = &ao_lisp_string_type, + [AO_LISP_ATOM] = &ao_lisp_atom_type, + [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, +}; + void ao_lisp_poly_mark(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - ao_lisp_mark(&ao_lisp_cons_type, ao_lisp_poly_cons(p)); - break; - case AO_LISP_STRING: - ao_lisp_mark(&ao_lisp_string_type, ao_lisp_poly_string(p)); - break; - case AO_LISP_ATOM: - ao_lisp_mark(&ao_lisp_atom_type, ao_lisp_poly_atom(p)); - break; - } + const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; + if (lisp_type) + ao_lisp_mark(lisp_type, ao_lisp_ref(p)); } ao_poly ao_lisp_poly_move(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - p = ao_lisp_cons_poly(ao_lisp_move(&ao_lisp_cons_type, ao_lisp_poly_cons(p))); - break; - case AO_LISP_STRING: - p = ao_lisp_string_poly(ao_lisp_move(&ao_lisp_string_type, ao_lisp_poly_string(p))); - break; - case AO_LISP_ATOM: - p = ao_lisp_atom_poly(ao_lisp_move(&ao_lisp_atom_type, ao_lisp_poly_atom(p))); - break; - } + uint8_t type = p & AO_LISP_TYPE_MASK; + const struct ao_lisp_type *lisp_type; + + if (type == AO_LISP_OTHER) + type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); + + lisp_type = ao_lisp_types[type]; + if (lisp_type) + p = ao_lisp_poly(ao_lisp_move(lisp_type, ao_lisp_ref(p)), p & AO_LISP_TYPE_MASK); return p; } diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 8fc134e5..bc1eb36b 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -188,8 +188,6 @@ lex_quoted (void) int count; c = lex_get(); -// if (jumping) -// return nil; if (c == EOF) return EOF; c &= 0x7f; @@ -218,8 +216,6 @@ lex_quoted (void) count = 1; while (count <= 3) { c = lex_get(); -// if (jumping) -// return nil; if (c == EOF) return EOF; c &= 0x7f; @@ -288,11 +284,17 @@ lex(void) if (lex_class & ENDOFFILE) return AO_LISP_NIL; -// if (jumping) -// return nil; if (lex_class & WHITE) continue; + if (lex_class & COMMENT) { + while ((c = lexc()) != '\n') { + if (lex_class & ENDOFFILE) + return AO_LISP_NIL; + } + continue; + } + if (lex_class & (BRA|KET|QUOTEC)) { add_token(c); end_token(); @@ -312,8 +314,6 @@ lex(void) if (lex_class & STRINGC) { for (;;) { c = lexc(); -// if (jumping) -// return nil; if (lex_class & (STRINGC|ENDOFFILE)) { end_token(); return STRING; @@ -349,8 +349,6 @@ lex(void) } add_token (c); c = lexc (); -// if (jumping) -// return nil; if (lex_class & (NOTNAME)) { // if (lex_class & ENDOFFILE) // clearerr (f); @@ -403,6 +401,10 @@ pop_read_stack(int cons) read_cons_tail && read_cons_tail->cdr; read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) ; + } else { + read_cons = 0; + read_cons_tail = 0; + read_stack = 0; } return in_quote; } @@ -420,6 +422,7 @@ ao_lisp_read(void) ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); + been_here = 1; } parse_token = lex(); diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 0df44317..1b7e0bb0 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -13,6 +13,8 @@ INC = \ ao_pins.h \ ao_product.h \ ao_task.h \ + ao_lisp.h \ + ao_lisp_const.h \ stm32f0.h \ Makefile @@ -43,6 +45,7 @@ ALTOS_SRC = \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_rep.c \ + ao_lisp_frame.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/test/Makefile b/src/test/Makefile index 6c51c421..bd195161 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -91,7 +91,9 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h #AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o -AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o +AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ + ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \ + ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 810a1528..e303869f 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -36,7 +36,6 @@ main (int argc, char **argv) list = ao_lisp_cons_cons(ao_lisp_string_poly(string), list); list = ao_lisp_cons_cons(ao_lisp_int_poly(i), list); atom = ao_lisp_atom_intern("ant"); - atom->val = ao_lisp_cons_poly(list); list = ao_lisp_cons_cons(ao_lisp_atom_poly(atom), list); } ao_lisp_poly_print(ao_lisp_cons_poly(list)); @@ -45,7 +44,7 @@ main (int argc, char **argv) for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { printf("%s = ", atom->name); - ao_lisp_poly_print(atom->val); + ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom))); printf("\n"); } #if 1 -- 2.30.2