From e2f4d25cd6f6f3787d4ee99264732d5b2ce23d4c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 31 Oct 2016 18:53:09 -0700 Subject: altos: Add lisp reader --- src/lisp/ao_lisp.h | 242 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 242 insertions(+) create mode 100644 src/lisp/ao_lisp.h (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h new file mode 100644 index 00000000..6667dcc2 --- /dev/null +++ b/src/lisp/ao_lisp.h @@ -0,0 +1,242 @@ +/* + * 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. + */ + +#ifndef _AO_LISP_H_ +#define _AO_LISP_H_ + +#include +#include +#include + + +# define AO_LISP_CONS 0 +# define AO_LISP_INT 1 +# define AO_LISP_STRING 2 +# define AO_LISP_OTHER 3 + +# define AO_LISP_ATOM 4 +# define AO_LISP_BUILTIN 5 + +# define AO_LISP_NIL 0 + +#define AO_LISP_POOL 1024 +#define AO_LISP_ROOT 16 + +static inline void *ao_lisp_set_ref(void *addr) { + return (void *) ((intptr_t)addr | 1); +} + +static inline void *ao_lisp_clear_ref(void *addr) { + return (void *) ((intptr_t)addr & ~1); +} + +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; + +struct ao_lisp_mem_type { + void (*mark)(void *addr); + int (*size)(void *addr); + void (*move)(void *addr); +}; + +typedef intptr_t ao_lisp_poly; + +struct ao_lisp_cons { + ao_lisp_poly car; + struct ao_lisp_cons *cdr; +}; + +struct ao_lisp_atom { + uint8_t type; + ao_lisp_poly val; + struct ao_lisp_atom *next; + char name[]; +}; + +#define AO_LISP_ATOM_CONST ((struct ao_lisp_atom *) (intptr_t) 1) + +extern const struct ao_lisp_atom *ao_lisp_builtins[]; + +struct ao_lisp_builtin { + uint8_t type; + ao_lisp_poly (*func)(struct ao_lisp_cons *cons); + char name[]; +}; + +static inline void * +ao_lisp_poly_other(ao_lisp_poly poly) { + return (void *) (poly - AO_LISP_OTHER); +} + +static const inline ao_lisp_poly +ao_lisp_other_poly(const void *other) +{ + return (ao_lisp_poly) other + AO_LISP_OTHER; +} + +#define AO_LISP_OTHER_POLY(other) ((ao_lisp_poly)(other) + AO_LISP_OTHER) + +static inline int ao_lisp_poly_type(ao_lisp_poly poly) { + int type = poly & 3; + if (type == AO_LISP_OTHER) + return *((uint8_t *) ao_lisp_poly_other(poly)); + return type; +} + +static inline struct ao_lisp_cons * +ao_lisp_poly_cons(ao_lisp_poly poly) +{ + return (struct ao_lisp_cons *) (poly - AO_LISP_CONS); +} + +static inline ao_lisp_poly +ao_lisp_cons_poly(struct ao_lisp_cons *cons) +{ + return (ao_lisp_poly) cons + AO_LISP_CONS; +} + +static inline int +ao_lisp_poly_int(ao_lisp_poly poly) +{ + return (int) (poly >> 2); +} + +static inline ao_lisp_poly +ao_lisp_int_poly(int i) +{ + return ((ao_lisp_poly) i << 2) + AO_LISP_INT; +} + +static inline char * +ao_lisp_poly_string(ao_lisp_poly poly) +{ + return (char *) (poly - AO_LISP_STRING); +} + +static inline ao_lisp_poly +ao_lisp_string_poly(char *s) { + return (ao_lisp_poly) s + AO_LISP_STRING; +} + +static inline struct ao_lisp_atom * +ao_lisp_poly_atom(ao_lisp_poly poly) +{ + return (struct ao_lisp_atom *) (poly - AO_LISP_OTHER); +} + +static inline ao_lisp_poly +ao_lisp_atom_poly(struct ao_lisp_atom *a) +{ + return (ao_lisp_poly) a + AO_LISP_OTHER; +} + +static inline struct ao_lisp_builtin * +ao_lisp_poly_builtin(ao_lisp_poly poly) +{ + return (struct ao_lisp_builtin *) (poly - AO_LISP_OTHER); +} + +static inline ao_lisp_poly +ao_lisp_builtin_poly(struct ao_lisp_builtin *b) +{ + return (ao_lisp_poly) b + AO_LISP_OTHER; +} + +/* memory functions */ + +void +ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_lisp_mark_memory(void *addr, int size); + +void * +ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr); + +/* returns NULL if the object was already moved */ +void * +ao_lisp_move_memory(void *addr, int size); + +void * +ao_lisp_alloc(int size); + +int +ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr); + +void +ao_lisp_root_clear(void *addr); + +/* cons */ +extern const struct ao_lisp_mem_type ao_lisp_cons_type; + +struct ao_lisp_cons * +ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr); + +void +ao_lisp_cons_print(struct ao_lisp_cons *cons); + +/* string */ +extern const struct ao_lisp_mem_type ao_lisp_string_type; + +char * +ao_lisp_string_new(int len); + +char * +ao_lisp_string_copy(char *a); + +char * +ao_lisp_string_cat(char *a, char *b); + +void +ao_lisp_string_print(char *s); + +/* atom */ +extern const struct ao_lisp_mem_type ao_lisp_atom_type; + +void +ao_lisp_atom_init(void); + +void +ao_lisp_atom_print(struct ao_lisp_atom *atom); + +struct ao_lisp_atom * +ao_lisp_atom_intern(char *name); + +/* int */ +void +ao_lisp_int_print(int i); + +/* prim */ +ao_lisp_poly +ao_lisp_poly_print(ao_lisp_poly p); + +void +ao_lisp_poly_mark(ao_lisp_poly p); + +ao_lisp_poly +ao_lisp_poly_move(ao_lisp_poly p); + +/* eval */ +ao_lisp_poly +ao_lisp_eval(ao_lisp_poly p); + +/* builtin */ +void +ao_lisp_builtin_print(struct ao_lisp_builtin *b); + +/* read */ +ao_lisp_poly +ao_lisp_read(void); + +#endif /* _AO_LISP_H_ */ -- cgit v1.2.3 From d2408e72d1e0d3459918601712b09860ab17e200 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 1 Nov 2016 21:14:45 -0700 Subject: altos/lisp: Change lisp objects to use ao_poly everywhere. Add const This makes all lisp objects use 16-bit ints for references so we can hold more stuff in small amounts of memory. Also adds a separate constant pool of lisp objects for builtins, initial atoms and constant lisp code. Now builds (and runs!) on the nucleo-32 boards. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 2 + src/lisp/Makefile | 32 +++++ src/lisp/ao_lisp.h | 238 ++++++++++++++++++++++----------- src/lisp/ao_lisp_atom.c | 43 +++--- src/lisp/ao_lisp_builtin.c | 189 +++++++++++++++++++++++++- src/lisp/ao_lisp_cons.c | 19 +-- src/lisp/ao_lisp_const.lisp | 1 + src/lisp/ao_lisp_eval.c | 57 ++++++-- src/lisp/ao_lisp_int.c | 3 +- src/lisp/ao_lisp_make_const.c | 90 +++++++++++++ src/lisp/ao_lisp_mem.c | 41 ++++-- src/lisp/ao_lisp_poly.c | 89 +----------- src/lisp/ao_lisp_prim.c | 40 +++--- src/lisp/ao_lisp_read.c | 31 +++-- src/lisp/ao_lisp_rep.c | 40 ++++++ src/lisp/ao_lisp_string.c | 6 +- src/nucleao-32/.gitignore | 2 + src/nucleao-32/Makefile | 11 ++ src/nucleao-32/ao_nucleo.c | 7 + src/nucleao-32/flash-loader/.gitignore | 2 + src/test/Makefile | 8 +- src/test/ao_lisp_test.c | 40 +++--- 22 files changed, 714 insertions(+), 277 deletions(-) create mode 100644 src/lisp/.gitignore create mode 100644 src/lisp/Makefile create mode 100644 src/lisp/ao_lisp_const.lisp create mode 100644 src/lisp/ao_lisp_make_const.c create mode 100644 src/lisp/ao_lisp_rep.c create mode 100644 src/nucleao-32/.gitignore create mode 100644 src/nucleao-32/flash-loader/.gitignore (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore new file mode 100644 index 00000000..76a555ea --- /dev/null +++ b/src/lisp/.gitignore @@ -0,0 +1,2 @@ +ao_lisp_make_const +ao_lisp_const.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile new file mode 100644 index 00000000..e8c3c02c --- /dev/null +++ b/src/lisp/Makefile @@ -0,0 +1,32 @@ +all: ao_lisp_const.h + +clean: + rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const + +ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const + ./ao_lisp_make_const < ao_lisp_const.lisp > $@ + +SRCS=\ + ao_lisp_make_const.c\ + ao_lisp_mem.c \ + ao_lisp_cons.c \ + ao_lisp_string.c \ + ao_lisp_atom.c \ + ao_lisp_int.c \ + ao_lisp_poly.c \ + ao_lisp_prim.c \ + ao_lisp_builtin.c \ + ao_lisp_read.c + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g + +HDRS=\ + ao_lisp.h \ + ao_lisp_read.h + +ao_lisp_make_const: $(OBJS) + $(CC) $(CFLAGS) -o $@ $(OBJS) + +$(OBJS): $(HDRS) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 6667dcc2..4fac861b 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,78 +15,158 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ +#if !defined(AO_LISP_TEST) && !defined(AO_LISP_MAKE_CONST) +#include +#define AO_LISP_ALTOS 1 +#endif + #include #include #include +#ifdef AO_LISP_MAKE_CONST +#define AO_LISP_POOL_CONST 16384 +extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#else +#include "ao_lisp_const.h" +#endif + +/* Primitive types */ +#define AO_LISP_CONS 0 +#define AO_LISP_INT 1 +#define AO_LISP_STRING 2 +#define AO_LISP_OTHER 3 -# define AO_LISP_CONS 0 -# define AO_LISP_INT 1 -# define AO_LISP_STRING 2 -# define AO_LISP_OTHER 3 +#define AO_LISP_TYPE_MASK 0x0003 +#define AO_LISP_TYPE_SHIFT 2 +#define AO_LISP_REF_MASK 0x7ffc +#define AO_LISP_CONST 0x8000 -# define AO_LISP_ATOM 4 -# define AO_LISP_BUILTIN 5 +/* 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_NIL 0 +#define AO_LISP_NIL 0 #define AO_LISP_POOL 1024 -#define AO_LISP_ROOT 16 -static inline void *ao_lisp_set_ref(void *addr) { - return (void *) ((intptr_t)addr | 1); +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; +extern uint16_t ao_lisp_top; + +#define AO_LISP_OOM 0x01 +#define AO_LISP_DIVIDE_BY_ZERO 0x02 +#define AO_LISP_INVALID 0x04 + +extern uint8_t ao_lisp_exception; + +typedef uint16_t ao_poly; + +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)); } -static inline void *ao_lisp_clear_ref(void *addr) { - return (void *) ((intptr_t)addr & ~1); +static inline ao_poly +ao_lisp_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (addr == 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; + } } -extern uint8_t ao_lisp_pool[AO_LISP_POOL]; +#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_mem_type { +struct ao_lisp_type { void (*mark)(void *addr); int (*size)(void *addr); void (*move)(void *addr); }; -typedef intptr_t ao_lisp_poly; - struct ao_lisp_cons { - ao_lisp_poly car; - struct ao_lisp_cons *cdr; + ao_poly car; + ao_poly cdr; }; struct ao_lisp_atom { - uint8_t type; - ao_lisp_poly val; - struct ao_lisp_atom *next; - char name[]; + uint8_t type; + uint8_t pad[1]; + ao_poly val; + ao_poly next; + char name[]; }; -#define AO_LISP_ATOM_CONST ((struct ao_lisp_atom *) (intptr_t) 1) - -extern const struct ao_lisp_atom *ao_lisp_builtins[]; +#define AO_LISP_LAMBDA 0 +#define AO_LISP_NLAMBDA 1 +#define AO_LISP_MACRO 2 +#define AO_LISP_LEXPR 3 struct ao_lisp_builtin { - uint8_t type; - ao_lisp_poly (*func)(struct ao_lisp_cons *cons); - char name[]; + uint8_t type; + uint8_t args; + uint16_t func; }; +enum ao_lisp_builtin_id { + builtin_car, + builtin_cdr, + builtin_cons, + builtin_quote, + builtin_print, + builtin_plus, + builtin_minus, + builtin_times, + builtin_divide, + builtin_mod, + builtin_last +}; + +typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); + +extern ao_lisp_func_t ao_lisp_builtins[]; + +static inline ao_lisp_func_t +ao_lisp_func(struct ao_lisp_builtin *b) +{ + return ao_lisp_builtins[b->func]; +} + static inline void * -ao_lisp_poly_other(ao_lisp_poly poly) { - return (void *) (poly - AO_LISP_OTHER); +ao_lisp_poly_other(ao_poly poly) { + return ao_lisp_ref(poly); } -static const inline ao_lisp_poly +static inline ao_poly ao_lisp_other_poly(const void *other) { - return (ao_lisp_poly) other + AO_LISP_OTHER; + return ao_lisp_poly(other, AO_LISP_OTHER); +} + +static inline int +ao_lisp_mem_round(int size) +{ + return (size + 3) & ~3; } -#define AO_LISP_OTHER_POLY(other) ((ao_lisp_poly)(other) + AO_LISP_OTHER) +#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) -static inline int ao_lisp_poly_type(ao_lisp_poly poly) { +static inline int ao_lisp_poly_type(ao_poly poly) { int type = poly & 3; if (type == AO_LISP_OTHER) return *((uint8_t *) ao_lisp_poly_other(poly)); @@ -94,75 +174,75 @@ static inline int ao_lisp_poly_type(ao_lisp_poly poly) { } static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_lisp_poly poly) +ao_lisp_poly_cons(ao_poly poly) { - return (struct ao_lisp_cons *) (poly - AO_LISP_CONS); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_cons_poly(struct ao_lisp_cons *cons) { - return (ao_lisp_poly) cons + AO_LISP_CONS; + return ao_lisp_poly(cons, AO_LISP_CONS); } static inline int -ao_lisp_poly_int(ao_lisp_poly poly) +ao_lisp_poly_int(ao_poly poly) { - return (int) (poly >> 2); + return (int) poly >> AO_LISP_TYPE_SHIFT; } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_int_poly(int i) { - return ((ao_lisp_poly) i << 2) + AO_LISP_INT; + return ((ao_poly) i << 2) + AO_LISP_INT; } static inline char * -ao_lisp_poly_string(ao_lisp_poly poly) +ao_lisp_poly_string(ao_poly poly) { - return (char *) (poly - AO_LISP_STRING); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly -ao_lisp_string_poly(char *s) { - return (ao_lisp_poly) s + AO_LISP_STRING; +static inline ao_poly +ao_lisp_string_poly(char *s) +{ + return ao_lisp_poly(s, AO_LISP_STRING); } static inline struct ao_lisp_atom * -ao_lisp_poly_atom(ao_lisp_poly poly) +ao_lisp_poly_atom(ao_poly poly) { - return (struct ao_lisp_atom *) (poly - AO_LISP_OTHER); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_atom_poly(struct ao_lisp_atom *a) { - return (ao_lisp_poly) a + AO_LISP_OTHER; + return ao_lisp_poly(a, AO_LISP_OTHER); } static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_lisp_poly poly) +ao_lisp_poly_builtin(ao_poly poly) { - return (struct ao_lisp_builtin *) (poly - AO_LISP_OTHER); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_builtin_poly(struct ao_lisp_builtin *b) { - return (ao_lisp_poly) b + AO_LISP_OTHER; + return ao_lisp_poly(b, AO_LISP_OTHER); } /* memory functions */ - void -ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_mark(const struct ao_lisp_type *type, void *addr); /* returns 1 if the object was already marked */ int ao_lisp_mark_memory(void *addr, int size); void * -ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_move(const struct ao_lisp_type *type, void *addr); /* returns NULL if the object was already moved */ void * @@ -172,22 +252,22 @@ void * ao_lisp_alloc(int size); int -ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); void ao_lisp_root_clear(void *addr); /* cons */ -extern const struct ao_lisp_mem_type ao_lisp_cons_type; +extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * -ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr); +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); void -ao_lisp_cons_print(struct ao_lisp_cons *cons); +ao_lisp_cons_print(ao_poly); /* string */ -extern const struct ao_lisp_mem_type ao_lisp_string_type; +extern const struct ao_lisp_type ao_lisp_string_type; char * ao_lisp_string_new(int len); @@ -199,44 +279,50 @@ char * ao_lisp_string_cat(char *a, char *b); void -ao_lisp_string_print(char *s); +ao_lisp_string_print(ao_poly s); /* atom */ -extern const struct ao_lisp_mem_type ao_lisp_atom_type; +extern const struct ao_lisp_type ao_lisp_atom_type; + +extern struct ao_lisp_atom *ao_lisp_atoms; void ao_lisp_atom_init(void); void -ao_lisp_atom_print(struct ao_lisp_atom *atom); +ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); /* int */ void -ao_lisp_int_print(int i); +ao_lisp_int_print(ao_poly i); /* prim */ -ao_lisp_poly -ao_lisp_poly_print(ao_lisp_poly p); +ao_poly +ao_lisp_poly_print(ao_poly p); void -ao_lisp_poly_mark(ao_lisp_poly p); +ao_lisp_poly_mark(ao_poly p); -ao_lisp_poly -ao_lisp_poly_move(ao_lisp_poly p); +ao_poly +ao_lisp_poly_move(ao_poly p); /* eval */ -ao_lisp_poly -ao_lisp_eval(ao_lisp_poly p); +ao_poly +ao_lisp_eval(ao_poly p); /* builtin */ void -ao_lisp_builtin_print(struct ao_lisp_builtin *b); +ao_lisp_builtin_print(ao_poly b); /* read */ -ao_lisp_poly +ao_poly ao_lisp_read(void); +/* rep */ +ao_poly +ao_lisp_read_eval_print(void); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 65282142..aaa84b8d 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -34,12 +34,9 @@ static void atom_mark(void *addr) { struct ao_lisp_atom *atom = addr; - if (atom->next == AO_LISP_ATOM_CONST) - return; - for (;;) { ao_lisp_poly_mark(atom->val); - atom = atom->next; + atom = ao_lisp_poly_atom(atom->next); if (!atom) break; if (ao_lisp_mark_memory(atom, atom_size(atom))) @@ -51,49 +48,50 @@ static void atom_move(void *addr) { struct ao_lisp_atom *atom = addr; - if (atom->next == AO_LISP_ATOM_CONST) - return; - for (;;) { struct ao_lisp_atom *next; atom->val = ao_lisp_poly_move(atom->val); - next = ao_lisp_move_memory(atom->next, atom_size(atom->next)); + next = ao_lisp_poly_atom(atom->next); + next = ao_lisp_move_memory(next, atom_size(next)); if (!next) break; - atom->next = next; + atom->next = ao_lisp_atom_poly(next); atom = next; } } -const struct ao_lisp_mem_type ao_lisp_atom_type = { +const struct ao_lisp_type ao_lisp_atom_type = { .mark = atom_mark, .size = atom_size, .move = atom_move, }; -struct ao_lisp_atom *atoms; +struct ao_lisp_atom *ao_lisp_atoms; struct ao_lisp_atom * ao_lisp_atom_intern(char *name) { struct ao_lisp_atom *atom; - int b; +// int b; - for (atom = atoms; atom; atom = atom->next) { + for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#ifdef ao_builtin_atoms + for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { if (!strcmp(atom->name, name)) return atom; } - for (b = 0; ao_lisp_builtins[b]; b++) - if (!strcmp(ao_lisp_builtins[b]->name, name)) - return (struct ao_lisp_atom *) ao_lisp_builtins[b]; - if (!atoms) - ao_lisp_root_add(&ao_lisp_atom_type, (void **) &atoms); +#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 = atoms; - atoms = atom; + atom->next = ao_lisp_atom_poly(ao_lisp_atoms); + ao_lisp_atoms = atom; strcpy(atom->name, name); atom->val = AO_LISP_NIL; } @@ -101,7 +99,8 @@ ao_lisp_atom_intern(char *name) } void -ao_lisp_atom_print(struct ao_lisp_atom *a) +ao_lisp_atom_print(ao_poly a) { - fputs(a->name, stdout); + struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); + printf("%s", atom->name); } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 3752a2c8..e6d55797 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -15,7 +15,192 @@ #include "ao_lisp.h" void -ao_lisp_builtin_print(struct ao_lisp_builtin *b) +ao_lisp_builtin_print(ao_poly b) { - printf("[builtin %s]", b->name); + (void) b; + printf("[builtin]"); } + +enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; + +ao_poly +ao_lisp_car(struct ao_lisp_cons *cons) +{ + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (!cons->car) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return ao_lisp_poly_cons(cons->car)->car; +} + +ao_poly +ao_lisp_cdr(struct ao_lisp_cons *cons) +{ + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (!cons->car) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return ao_lisp_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_lisp_cons(struct ao_lisp_cons *cons) +{ + ao_poly car, cdr; + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + car = cons->car; + cdr = cons->cdr; + if (!car || !cdr) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + cdr = ao_lisp_poly_cons(cdr)->car; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); +} + +ao_poly +ao_lisp_quote(struct ao_lisp_cons *cons) +{ + if (!cons) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + return cons->car; +} + +ao_poly +ao_lisp_print(struct ao_lisp_cons *cons) +{ + ao_poly val = AO_LISP_NIL; + while (cons) { + val = cons->car; + ao_lisp_poly_print(val); + cons = ao_lisp_poly_cons(cons->cdr); + } + return val; +} + +ao_poly +ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) +{ + ao_poly ret = AO_LISP_NIL; + + while (cons) { + ao_poly car = cons->car; + uint8_t rt = ao_lisp_poly_type(ret); + uint8_t ct = ao_lisp_poly_type(car); + + cons = ao_lisp_poly_cons(cons->cdr); + + if (rt == AO_LISP_NIL) + ret = car; + + else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + int r = ao_lisp_poly_int(ret); + int c = ao_lisp_poly_int(car); + + switch(op) { + case math_plus: + r += c; + break; + case math_minus: + r -= c; + break; + case math_times: + r *= c; + break; + case math_divide: + if (c == 0) { + ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; + return AO_LISP_NIL; + } + r /= c; + break; + case math_mod: + if (c == 0) { + ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; + return AO_LISP_NIL; + } + r %= c; + break; + } + ret = ao_lisp_int_poly(r); + } + + else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) + ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), + ao_lisp_poly_string(car))); + else { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + } + return ret; +} + +ao_poly +ao_lisp_plus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_plus); +} + +ao_poly +ao_lisp_minus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_minus); +} + +ao_poly +ao_lisp_times(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_times); +} + +ao_poly +ao_lisp_divide(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_divide); +} + +ao_poly +ao_lisp_mod(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_mod); +} + +ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_car] = ao_lisp_car, + [builtin_cdr] = ao_lisp_cdr, + [builtin_cons] = ao_lisp_cons, + [builtin_quote] = ao_lisp_quote, + [builtin_print] = ao_lisp_print, + [builtin_plus] = ao_lisp_plus, + [builtin_minus] = ao_lisp_minus, + [builtin_times] = ao_lisp_times, + [builtin_divide] = ao_lisp_divide, + [builtin_mod] = ao_lisp_mod +}; + diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 60cbb2f3..65908e30 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -20,7 +20,7 @@ static void cons_mark(void *addr) for (;;) { ao_lisp_poly_mark(cons->car); - cons = cons->cdr; + cons = ao_lisp_poly_cons(cons->cdr); if (!cons) break; if (ao_lisp_mark_memory(cons, sizeof (struct ao_lisp_cons))) @@ -42,42 +42,43 @@ static void cons_move(void *addr) struct ao_lisp_cons *cdr; cons->car = ao_lisp_poly_move(cons->car); - cdr = ao_lisp_move_memory(cons->cdr, sizeof (struct ao_lisp_cons)); + cdr = ao_lisp_poly_cons(cons->cdr); + cdr = ao_lisp_move_memory(cdr, sizeof (struct ao_lisp_cons)); if (!cdr) break; - cons->cdr = cdr; + cons->cdr = ao_lisp_cons_poly(cdr); cons = cdr; } } -const struct ao_lisp_mem_type ao_lisp_cons_type = { +const struct ao_lisp_type ao_lisp_cons_type = { .mark = cons_mark, .size = cons_size, .move = cons_move, }; struct ao_lisp_cons * -ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr) +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { struct ao_lisp_cons *cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); if (!cons) return NULL; cons->car = car; - cons->cdr = cdr; + cons->cdr = ao_lisp_cons_poly(cdr); return cons; } void -ao_lisp_cons_print(struct ao_lisp_cons *cons) +ao_lisp_cons_print(ao_poly c) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); int first = 1; printf("("); while (cons) { if (!first) printf(" "); - fflush(stdout); ao_lisp_poly_print(cons->car); - cons = cons->cdr; + cons = ao_lisp_poly_cons(cons->cdr); first = 0; } printf(")"); diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp new file mode 100644 index 00000000..aa356d45 --- /dev/null +++ b/src/lisp/ao_lisp_const.lisp @@ -0,0 +1 @@ +cadr (lambda (l) (car (cdr l))) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 23908e64..b13d4681 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -40,8 +40,8 @@ static uint8_t been_here; #define DBG_POLY(a) #endif -ao_lisp_poly -ao_lisp_eval(ao_lisp_poly v) +ao_poly +ao_lisp_eval(ao_poly v) { struct ao_lisp_cons *formal; int cons = 0; @@ -59,6 +59,7 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = 0; for (;;) { + restart: /* Build stack frames for each list */ while (ao_lisp_poly_type(v) == AO_LISP_CONS) { if (v == AO_LISP_NIL) @@ -68,8 +69,8 @@ ao_lisp_eval(ao_lisp_poly v) if (cons++) { struct ao_lisp_cons *frame; - frame = ao_lisp_cons(ao_lisp_cons_poly(actuals), formals); - stack = ao_lisp_cons(ao_lisp_cons_poly(frame), stack); + frame = ao_lisp_cons_cons(ao_lisp_cons_poly(actuals), formals); + stack = ao_lisp_cons_cons(ao_lisp_cons_poly(frame), stack); } actuals = ao_lisp_poly_cons(v); formals = NULL; @@ -83,6 +84,8 @@ ao_lisp_eval(ao_lisp_poly v) /* Evaluate primitive types */ + DBG ("actual: "); DBG_POLY(v); DBG("\n"); + switch (ao_lisp_poly_type(v)) { case AO_LISP_INT: case AO_LISP_STRING: @@ -92,16 +95,42 @@ ao_lisp_eval(ao_lisp_poly v) break; } + if (!cons) + break; + for (;;) { DBG("add formal: "); DBG_POLY(v); DBG("\n"); - formal = ao_lisp_cons(v, NULL); + if (formals == NULL) { + if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); + switch (b->args) { + case AO_LISP_NLAMBDA: + v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + goto done_eval; + + case AO_LISP_MACRO: + v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + if (ao_lisp_poly_type(v) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + + /* Reset frame to the new list */ + actuals = ao_lisp_poly_cons(v); + v = actuals->car; + goto restart; + } + } + } + + formal = ao_lisp_cons_cons(v, NULL); if (formals_tail) - formals_tail->cdr = formal; + formals_tail->cdr = ao_lisp_cons_poly(formal); else formals = formal; formals_tail = formal; - actuals = actuals->cdr; + actuals = ao_lisp_poly_cons(actuals->cdr); DBG("formals: "); DBG_CONS(formals); @@ -113,7 +142,6 @@ ao_lisp_eval(ao_lisp_poly v) /* Process all of the arguments */ if (actuals) { v = actuals->car; - DBG ("actual: "); DBG_POLY(v); DBG("\n"); break; } @@ -123,7 +151,7 @@ ao_lisp_eval(ao_lisp_poly v) if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - v = b->func(formals->cdr); + v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr)); DBG ("eval: "); DBG_CONS(formals); @@ -131,22 +159,23 @@ ao_lisp_eval(ao_lisp_poly v) DBG_POLY(v); DBG ("\n"); } else { - DBG ("invalid eval\n"); + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; } - + done_eval: if (--cons) { struct ao_lisp_cons *frame; /* Pop the previous frame off the stack */ frame = ao_lisp_poly_cons(stack->car); actuals = ao_lisp_poly_cons(frame->car); - formals = frame->cdr; + formals = ao_lisp_poly_cons(frame->cdr); /* Recompute the tail of the formals list */ - for (formal = formals; formal->cdr != NULL; formal = formal->cdr); + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); formals_tail = formal; - stack = stack->cdr; + stack = ao_lisp_poly_cons(stack->cdr); DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 6ee3096d..77f65e95 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -15,7 +15,8 @@ #include "ao_lisp.h" void -ao_lisp_int_print(int i) +ao_lisp_int_print(ao_poly p) { + int i = ao_lisp_poly_int(p); printf("%d", i); } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c new file mode 100644 index 00000000..21e000bf --- /dev/null +++ b/src/lisp/ao_lisp_make_const.c @@ -0,0 +1,90 @@ +/* + * 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" +#include + +static struct ao_lisp_builtin * +ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { + struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); + + b->type = AO_LISP_BUILTIN; + b->func = func; + b->args = args; + return b; +} + +struct builtin_func { + char *name; + int args; + int func; +}; + +struct builtin_func funcs[] = { + "car", AO_LISP_LEXPR, builtin_car, + "cdr", AO_LISP_LEXPR, builtin_cdr, + "cons", AO_LISP_LEXPR, builtin_cons, + "quote", AO_LISP_NLAMBDA,builtin_quote, + "print", AO_LISP_LEXPR, builtin_print, + "+", AO_LISP_LEXPR, builtin_plus, + "-", AO_LISP_LEXPR, builtin_minus, + "*", AO_LISP_LEXPR, builtin_times, + "/", AO_LISP_LEXPR, builtin_divide, + "%", AO_LISP_LEXPR, builtin_mod +}; + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly atom, val; + + 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); + } + + for (;;) { + atom = ao_lisp_read(); + if (!atom) + break; + val = ao_lisp_read(); + if (!val) + break; + if (ao_lisp_poly_type(atom) != AO_LISP_ATOM) { + fprintf(stderr, "input must be atom val pairs\n"); + exit(1); + } + ao_lisp_poly_atom(atom)->val = val; + } + + printf("/* constant objects, all referenced from atoms */\n\n"); + 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("#ifdef AO_LISP_CONST_BITS\n"); + printf("const uint8_t ao_lisp_const[] = {"); + for (o = 0; o < ao_lisp_top; o++) { + if ((o & 0xf) == 0) + printf("\n\t"); + else + printf(" "); + printf("0x%02x,", ao_lisp_const[o]); + } + 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 d008519b..7295d150 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -12,23 +12,34 @@ * General Public License for more details. */ +#define AO_LISP_CONST_BITS + #include "ao_lisp.h" #include -uint8_t ao_lisp_pool[AO_LISP_POOL]; +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))); +#endif + +uint8_t ao_lisp_exception; struct ao_lisp_root { void **addr; - const struct ao_lisp_mem_type *type; + const struct ao_lisp_type *type; }; +#define AO_LISP_ROOT 16 + static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; static uint8_t ao_lisp_busy[AO_LISP_POOL / 32]; static uint8_t ao_lisp_moving[AO_LISP_POOL / 32]; -static uint16_t ao_lisp_top; +uint16_t ao_lisp_top; static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; @@ -59,9 +70,13 @@ static int mark_object(uint8_t *tag, void *addr, int size) { int base; int bound; + 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; bound = base + size; @@ -150,7 +165,7 @@ collect(void) void -ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { if (mark_object(ao_lisp_busy, addr, type->size(addr))) return; @@ -175,7 +190,7 @@ check_move(void *addr, int size) } void * -ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_move(const struct ao_lisp_type *type, void *addr) { int size = type->size(addr); @@ -206,19 +221,29 @@ ao_lisp_alloc(int size) { void *addr; - size = (size + 3) & ~3; + 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(); - if (ao_lisp_top + size > AO_LISP_POOL) + 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; } int -ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) { int i; for (i = 0; i < AO_LISP_ROOT; i++) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 1855d945..c6ca0a97 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -14,91 +14,7 @@ #include "ao_lisp.h" -enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; - -ao_lisp_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) -{ - ao_lisp_poly ret = AO_LISP_NIL; - - while (cons) { - ao_lisp_poly car = cons->car; - uint8_t rt = ao_lisp_poly_type(ret); - uint8_t ct = ao_lisp_poly_type(car); - - cons = cons->cdr; - - if (rt == AO_LISP_NIL) - ret = car; - - else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { - int r = ao_lisp_poly_int(ret); - int c = ao_lisp_poly_int(car); - - switch(op) { - case math_plus: - r += c; - break; - case math_minus: - r -= c; - break; - case math_times: - r *= c; - break; - case math_divide: - if (c == 0) - return AO_LISP_NIL; - r /= c; - break; - case math_mod: - if (c == 0) - return AO_LISP_NIL; - r %= c; - break; - } - ret = ao_lisp_int_poly(r); - } - - else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) - ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), - ao_lisp_poly_string(car))); - else { - /* XXX exception */ - return AO_LISP_NIL; - } - } - return ret; -} - -ao_lisp_poly -ao_lisp_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_plus); -} - -ao_lisp_poly -ao_lisp_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_minus); -} - -ao_lisp_poly -ao_lisp_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_times); -} - -ao_lisp_poly -ao_lisp_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_divide); -} - -ao_lisp_poly -ao_lisp_mod(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_mod); -} +/* static const struct ao_lisp_builtin builtin_plus = { .type = AO_LISP_BUILTIN, @@ -113,7 +29,6 @@ static const struct ao_lisp_atom atom_plus = { .name = "plus" }; -/* static const struct ao_lisp_builtin builtin_minus = { .type = AO_LISP_BUILTIN, .func = ao_lisp_minus @@ -124,9 +39,9 @@ static const struct ao_lisp_builtin builtin_times = { .func = ao_lisp_times }; -*/ const struct ao_lisp_atom const *ao_lisp_builtins[] = { &atom_plus, 0 }; +*/ diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index ccfd2be4..38dcb961 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -14,31 +14,25 @@ #include "ao_lisp.h" -ao_lisp_poly -ao_lisp_poly_print(ao_lisp_poly p) +static void (*const ao_lisp_print_funcs[AO_LISP_NUM_TYPE])(ao_poly) = { + [AO_LISP_CONS] = ao_lisp_cons_print, + [AO_LISP_STRING] = ao_lisp_string_print, + [AO_LISP_INT] = ao_lisp_int_print, + [AO_LISP_ATOM] = ao_lisp_atom_print, + [AO_LISP_BUILTIN] = ao_lisp_builtin_print +}; + +ao_poly +ao_lisp_poly_print(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - ao_lisp_cons_print(ao_lisp_poly_cons(p)); - break; - case AO_LISP_STRING: - ao_lisp_string_print(ao_lisp_poly_string(p)); - break; - case AO_LISP_INT: - ao_lisp_int_print(ao_lisp_poly_int(p)); - break; - case AO_LISP_ATOM: - ao_lisp_atom_print(ao_lisp_poly_atom(p)); - break; - case AO_LISP_BUILTIN: - ao_lisp_builtin_print(ao_lisp_poly_builtin(p)); - break; - } - return AO_LISP_NIL; + void (*print)(ao_poly) = ao_lisp_print_funcs[ao_lisp_poly_type(p)]; + if (print) + print(p); + return p; } void -ao_lisp_poly_mark(ao_lisp_poly p) +ao_lisp_poly_mark(ao_poly p) { switch (ao_lisp_poly_type(p)) { case AO_LISP_CONS: @@ -53,8 +47,8 @@ ao_lisp_poly_mark(ao_lisp_poly p) } } -ao_lisp_poly -ao_lisp_poly_move(ao_lisp_poly p) +ao_poly +ao_lisp_poly_move(ao_poly p) { switch (ao_lisp_poly_type(p)) { case AO_LISP_CONS: diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index ccb4ba3a..ea98b976 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -155,8 +155,21 @@ lex_get() if (lex_unget_c) { c = lex_unget_c; lex_unget_c = 0; - } else + } else { +#if AO_LISP_ALTOS + static uint8_t at_eol; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; +#else c = getchar(); +#endif + } return c; } @@ -362,13 +375,13 @@ static struct ao_lisp_cons *read_cons; static struct ao_lisp_cons *read_cons_tail; static struct ao_lisp_cons *read_stack; -static ao_lisp_poly +static ao_poly read_item(void) { struct ao_lisp_atom *atom; char *string; int cons; - ao_lisp_poly v; + ao_poly v; if (!been_here) { ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); @@ -381,7 +394,7 @@ read_item(void) for (;;) { while (parse_token == OPEN) { if (cons++) - read_stack = ao_lisp_cons(ao_lisp_cons_poly(read_cons), read_stack); + read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), read_stack); read_cons = NULL; read_cons_tail = NULL; parse_token = lex(); @@ -416,10 +429,10 @@ read_item(void) v = AO_LISP_NIL; if (--cons) { read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = read_stack->cdr; + read_stack = ao_lisp_poly_cons(read_stack->cdr); for (read_cons_tail = read_cons; read_cons_tail && read_cons_tail->cdr; - read_cons_tail = read_cons_tail->cdr) + read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) ; } break; @@ -428,9 +441,9 @@ read_item(void) if (!cons) break; - struct ao_lisp_cons *read = ao_lisp_cons(v, NULL); + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); if (read_cons_tail) - read_cons_tail->cdr = read; + read_cons_tail->cdr = ao_lisp_cons_poly(read); else read_cons = read; read_cons_tail = read; @@ -440,7 +453,7 @@ read_item(void) return v; } -ao_lisp_poly +ao_poly ao_lisp_read(void) { parse_token = lex(); diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c new file mode 100644 index 00000000..d26d270c --- /dev/null +++ b/src/lisp/ao_lisp_rep.c @@ -0,0 +1,40 @@ +/* + * 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" + +ao_poly +ao_lisp_read_eval_print(void) +{ + ao_poly in, out = AO_LISP_NIL; + for(;;) { + in = ao_lisp_read(); + if (!in) + break; + out = ao_lisp_eval(in); + if (ao_lisp_exception) { + if (ao_lisp_exception & AO_LISP_OOM) + printf("out of memory\n"); + if (ao_lisp_exception & AO_LISP_DIVIDE_BY_ZERO) + printf("divide by zero\n"); + if (ao_lisp_exception & AO_LISP_INVALID) + printf("invalid operation\n"); + ao_lisp_exception = 0; + } else { + ao_lisp_poly_print(out); + putchar ('\n'); + } + } + return out; +} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 1ab56933..39c3dc81 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -68,16 +68,18 @@ ao_lisp_string_cat(char *a, char *b) return r; } -const struct ao_lisp_mem_type ao_lisp_string_type = { +const struct ao_lisp_type ao_lisp_string_type = { .mark = string_mark, .size = string_size, .move = string_move, }; void -ao_lisp_string_print(char *s) +ao_lisp_string_print(ao_poly p) { + char *s = ao_lisp_poly_string(p); char c; + putchar('"'); while ((c = *s++)) { switch (c) { diff --git a/src/nucleao-32/.gitignore b/src/nucleao-32/.gitignore new file mode 100644 index 00000000..cb8f78e5 --- /dev/null +++ b/src/nucleao-32/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +nucleo-32* diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index a160fd2f..0df44317 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -32,6 +32,17 @@ ALTOS_SRC = \ ao_mutex.c \ ao_usb_stm.c \ ao_serial_stm.c \ + ao_lisp_lex.c \ + ao_lisp_mem.c \ + ao_lisp_cons.c \ + ao_lisp_eval.c \ + ao_lisp_string.c \ + ao_lisp_atom.c \ + ao_lisp_int.c \ + ao_lisp_prim.c \ + ao_lisp_builtin.c \ + ao_lisp_read.c \ + ao_lisp_rep.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/nucleao-32/ao_nucleo.c b/src/nucleao-32/ao_nucleo.c index cda889c6..113e2399 100644 --- a/src/nucleao-32/ao_nucleo.c +++ b/src/nucleao-32/ao_nucleo.c @@ -13,6 +13,7 @@ */ #include +#include static uint16_t blink_delay, blink_running; @@ -41,11 +42,17 @@ static void blink_cmd() { ao_sleep(&blink_running); } +static void lisp_cmd() { + ao_lisp_read_eval_print(); +} + static const struct ao_cmds blink_cmds[] = { { blink_cmd, "b \0Blink the green LED" }, + { lisp_cmd, "l\0Run lisp interpreter" }, { 0, 0 } }; + void main(void) { ao_led_init(LEDS_AVAILABLE); diff --git a/src/nucleao-32/flash-loader/.gitignore b/src/nucleao-32/flash-loader/.gitignore new file mode 100644 index 00000000..cb8f78e5 --- /dev/null +++ b/src/nucleao-32/flash-loader/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +nucleo-32* diff --git a/src/test/Makefile b/src/test/Makefile index e841bfde..6c51c421 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -10,7 +10,7 @@ INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quat KALMAN=make-kalman -CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall +CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall -DAO_LISP_TEST all: $(PROGS) ao_aprs_data.wav @@ -89,9 +89,11 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm -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_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_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -$(AO_LISP_OBJS): ao_lisp.h +$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 96f1fd72..810a1528 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -21,9 +21,9 @@ static char *string; int main (int argc, char **argv) { - int i, j; + int i, j; struct ao_lisp_atom *atom; - ao_lisp_poly poly; + ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list); ao_lisp_root_add(&ao_lisp_string_type, (void **) &string); @@ -31,37 +31,35 @@ main (int argc, char **argv) for (j = 0; j < 10; j++) { list = 0; string = ao_lisp_string_new(0); - for (i = 0; i < 7; i++) { + for (i = 0; i < 2; i++) { string = ao_lisp_string_cat(string, "a"); - list = ao_lisp_cons(ao_lisp_string_poly(string), list); - list = ao_lisp_cons(ao_lisp_int_poly(i), list); + 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(ao_lisp_atom_poly(atom), list); + list = ao_lisp_cons_cons(ao_lisp_atom_poly(atom), list); } ao_lisp_poly_print(ao_lisp_cons_poly(list)); printf("\n"); } - atom = ao_lisp_atom_intern("ant"); - atom->val = ao_lisp_string_poly(ao_lisp_string_cat("hello world", "")); - - list = ao_lisp_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("plus")), - ao_lisp_cons(ao_lisp_cons_poly(ao_lisp_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("plus")), - ao_lisp_cons(ao_lisp_int_poly(3), - ao_lisp_cons(ao_lisp_int_poly(4), NULL)))), - ao_lisp_cons(ao_lisp_int_poly(2), NULL))); + 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); + printf("\n"); + } +#if 1 + list = ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), + ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), + ao_lisp_cons_cons(ao_lisp_int_poly(3), + ao_lisp_cons_cons(ao_lisp_int_poly(4), NULL)))), + ao_lisp_cons_cons(ao_lisp_int_poly(2), NULL))); printf("list: "); ao_lisp_poly_print(ao_lisp_cons_poly(list)); printf ("\n"); ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list))); printf ("\n"); - while ((poly = ao_lisp_read())) { - poly = ao_lisp_eval(poly); - ao_lisp_poly_print(poly); - putchar ('\n'); - fflush(stdout); - } - + ao_lisp_read_eval_print(); +#endif } -- cgit v1.2.3 From 9e1a787f8828fb7b750ad3310c89a89536ea5286 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 2 Nov 2016 14:18:54 -0700 Subject: altos/lisp: add set/setq and ' in reader Along with other small fixes Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 8 ++++ src/lisp/ao_lisp_builtin.c | 76 ++++++++++++++++++++++++++---- src/lisp/ao_lisp_eval.c | 13 ++++-- src/lisp/ao_lisp_make_const.c | 23 ++++++++- src/lisp/ao_lisp_read.c | 105 +++++++++++++++++++++++++++++------------- src/lisp/ao_lisp_rep.c | 1 + 6 files changed, 183 insertions(+), 43 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 4fac861b..d4108662 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -27,6 +27,7 @@ #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) #else #include "ao_lisp_const.h" #endif @@ -62,6 +63,11 @@ extern uint8_t ao_lisp_exception; typedef uint16_t ao_poly; +static inline int +ao_lisp_is_const(ao_poly poly) { + return poly & AO_LISP_CONST; +} + static inline void * ao_lisp_ref(ao_poly poly) { if (poly == AO_LISP_NIL) @@ -128,6 +134,8 @@ enum ao_lisp_builtin_id { builtin_cdr, builtin_cons, builtin_quote, + builtin_set, + builtin_setq, builtin_print, builtin_plus, builtin_minus, diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e6d55797..63fb69fd 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -21,20 +21,46 @@ ao_lisp_builtin_print(ao_poly b) printf("[builtin]"); } +static int check_argc(struct ao_lisp_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_lisp_poly_cons(cons->cdr); + } + if (argc < min || argc > max) { + ao_lisp_exception |= AO_LISP_INVALID; + return 0; + } + return 1; +} + +static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car; + + /* find the desired arg */ + while (argc--) + cons = ao_lisp_poly_cons(cons->cdr); + car = cons->car; + if ((!car && !nil_ok) || + ao_lisp_poly_type(car) != type) + { + ao_lisp_exception |= AO_LISP_INVALID; + return 0; + } + return 1; +} + enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; ao_poly ao_lisp_car(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - if (!cons->car) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!check_argc(cons, 1, 1)) return AO_LISP_NIL; - } - if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + if (!check_argt(cons, 0, AO_LISP_CONS, 0)) { ao_lisp_exception |= AO_LISP_INVALID; return AO_LISP_NIL; } @@ -91,6 +117,38 @@ ao_lisp_quote(struct ao_lisp_cons *cons) return cons->car; } +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; +} + +ao_poly +ao_lisp_setq(struct ao_lisp_cons *cons) +{ + struct ao_lisp_cons *expand = 0; + if (!check_argc(cons, 2, 2)) + return AO_LISP_NIL; + expand = ao_lisp_cons_cons(_ao_lisp_atom_set, + ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, + ao_lisp_cons_cons(cons->car, NULL))), + ao_lisp_poly_cons(cons->cdr))); + return ao_lisp_cons_poly(expand); +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -196,6 +254,8 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, [builtin_quote] = ao_lisp_quote, + [builtin_set] = ao_lisp_set, + [builtin_setq] = ao_lisp_setq, [builtin_print] = ao_lisp_print, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index b13d4681..2374fdb2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -111,6 +111,9 @@ ao_lisp_eval(ao_poly v) case AO_LISP_MACRO: v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals)); + DBG(" -> "); DBG_POLY(v); + DBG("\n"); if (ao_lisp_poly_type(v) != AO_LISP_CONS) { ao_lisp_exception |= AO_LISP_INVALID; return AO_LISP_NIL; @@ -160,8 +163,9 @@ ao_lisp_eval(ao_poly v) DBG ("\n"); } else { ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; } + if (ao_lisp_exception) + return AO_LISP_NIL; done_eval: if (--cons) { struct ao_lisp_cons *frame; @@ -170,10 +174,13 @@ ao_lisp_eval(ao_poly v) frame = ao_lisp_poly_cons(stack->car); actuals = ao_lisp_poly_cons(frame->car); formals = ao_lisp_poly_cons(frame->cdr); + formals_tail = NULL; /* Recompute the tail of the formals list */ - for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); - formals_tail = formal; + if (formals) { + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); + formals_tail = formal; + } stack = ao_lisp_poly_cons(stack->cdr); DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 21e000bf..8d3e03a9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include +#include static struct ao_lisp_builtin * ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { @@ -36,6 +37,8 @@ struct builtin_func funcs[] = { "cdr", AO_LISP_LEXPR, builtin_cdr, "cons", AO_LISP_LEXPR, builtin_cons, "quote", AO_LISP_NLAMBDA,builtin_quote, + "set", AO_LISP_LEXPR, builtin_set, + "setq", AO_LISP_MACRO, builtin_setq, "print", AO_LISP_LEXPR, builtin_print, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, @@ -51,6 +54,7 @@ main(int argc, char **argv) { int f, o; ao_poly atom, val; + struct ao_lisp_atom *a; for (f = 0; f < N_FUNC; f++) { struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); @@ -76,14 +80,31 @@ main(int argc, char **argv) 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)); + + for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { + char *n = a->name, c; + printf ("#define _ao_lisp_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + printf("%c", c); + else + printf("%02x", c); + } + printf(" 0x%04x\n", ao_lisp_atom_poly(a)); + } printf("#ifdef AO_LISP_CONST_BITS\n"); printf("const uint8_t ao_lisp_const[] = {"); for (o = 0; o < ao_lisp_top; o++) { + uint8_t c; if ((o & 0xf) == 0) printf("\n\t"); else printf(" "); - printf("0x%02x,", ao_lisp_const[o]); + c = ao_lisp_const[o]; + if (' ' < c && c <= '~' && c != '\'') + printf (" '%c',", c); + else + printf("0x%02x,", c); } printf("\n};\n"); printf("#endif /* AO_LISP_CONST_BITS */\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index ea98b976..8fc134e5 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -375,12 +375,45 @@ static struct ao_lisp_cons *read_cons; static struct ao_lisp_cons *read_cons_tail; static struct ao_lisp_cons *read_stack; -static ao_poly -read_item(void) +static int +push_read_stack(int cons, int in_quote) +{ + if (cons) { + read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), + ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), + read_stack)); + if (!read_stack) + return 0; + } + read_cons = NULL; + read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(int cons) +{ + int in_quote = 0; + if (cons) { + read_cons = ao_lisp_poly_cons(read_stack->car); + read_stack = ao_lisp_poly_cons(read_stack->cdr); + in_quote = ao_lisp_poly_int(read_stack->car); + read_stack = ao_lisp_poly_cons(read_stack->cdr); + for (read_cons_tail = read_cons; + read_cons_tail && read_cons_tail->cdr; + read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) + ; + } + return in_quote; +} + +ao_poly +ao_lisp_read(void) { struct ao_lisp_atom *atom; char *string; int cons; + int in_quote; ao_poly v; if (!been_here) { @@ -388,15 +421,17 @@ read_item(void) ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); } + parse_token = lex(); cons = 0; + in_quote = 0; read_cons = read_cons_tail = read_stack = 0; for (;;) { while (parse_token == OPEN) { - if (cons++) - read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), read_stack); - read_cons = NULL; - read_cons_tail = NULL; + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 0; parse_token = lex(); } @@ -422,40 +457,48 @@ read_item(void) else v = AO_LISP_NIL; break; + case QUOTE: + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 1; + v = _ao_lisp_atom_quote; + break; case CLOSE: - if (cons) - v = ao_lisp_cons_poly(read_cons); - else + if (!cons) { v = AO_LISP_NIL; - if (--cons) { - read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = ao_lisp_poly_cons(read_stack->cdr); - for (read_cons_tail = read_cons; - read_cons_tail && read_cons_tail->cdr; - read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) - ; + break; } + v = ao_lisp_cons_poly(read_cons); + --cons; + in_quote = pop_read_stack(cons); break; } - if (!cons) - break; + /* loop over QUOTE ends */ + for (;;) { + if (!cons) + return v; + + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); + if (!read) + return AO_LISP_NIL; + + if (read_cons_tail) + read_cons_tail->cdr = ao_lisp_cons_poly(read); + else + read_cons = read; + read_cons_tail = read; + + if (!in_quote || !read_cons->cdr) + break; - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); - if (read_cons_tail) - read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - read_cons = read; - read_cons_tail = read; + v = ao_lisp_cons_poly(read_cons); + --cons; + in_quote = pop_read_stack(cons); + } parse_token = lex(); } return v; } - -ao_poly -ao_lisp_read(void) -{ - parse_token = lex(); - return read_item(); -} diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index d26d270c..a1f9fa1f 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -22,6 +22,7 @@ ao_lisp_read_eval_print(void) in = ao_lisp_read(); if (!in) break; +// printf ("in: "); ao_lisp_poly_print(in); printf("\n"); out = ao_lisp_eval(in); if (ao_lisp_exception) { if (ao_lisp_exception & AO_LISP_OOM) -- cgit v1.2.3 From 11cb03b1d336ee90c422be27588f57be573a9546 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 2 Nov 2016 22:56:01 -0700 Subject: 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 (limited to 'src/lisp/ao_lisp.h') 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 -- cgit v1.2.3 From 77db0e8162cd01c2b42737b3d71b38cea942484f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 3 Nov 2016 21:49:50 -0700 Subject: altos: Add lambda support to lisp Signed-off-by: Keith Packard --- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 51 ++++-- src/lisp/ao_lisp_atom.c | 62 +++++-- src/lisp/ao_lisp_builtin.c | 123 +++++++------- src/lisp/ao_lisp_const.lisp | 3 + src/lisp/ao_lisp_error.c | 29 ++++ src/lisp/ao_lisp_eval.c | 368 +++++++++++++++++++++++++++++++++++------- src/lisp/ao_lisp_frame.c | 2 +- src/lisp/ao_lisp_make_const.c | 29 +++- src/lisp/ao_lisp_rep.c | 6 - src/nucleao-32/Makefile | 1 + src/nucleao-32/ao_pins.h | 2 + src/test/Makefile | 3 +- src/test/ao_lisp_test.c | 11 +- 14 files changed, 528 insertions(+), 165 deletions(-) create mode 100644 src/lisp/ao_lisp_error.c (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 9e2fb58c..be19b432 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -17,7 +17,8 @@ SRCS=\ ao_lisp_prim.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ - ao_lisp_frame.c + ao_lisp_frame.c \ + ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 98e99acb..9a5cc63e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -32,11 +32,22 @@ 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")) + +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) + +#define _ao_lisp_atom_quote _atom("quote") +#define _ao_lisp_atom_set _atom("set") +#define _ao_lisp_atom_setq _atom("setq") +#define _ao_lisp_atom_t _atom("t") +#define _ao_lisp_atom_car _atom("car") +#define _ao_lisp_atom_cdr _atom("cdr") +#define _ao_lisp_atom_cons _atom("cons") +#define _ao_lisp_atom_cond _atom("cond") #else #include "ao_lisp_const.h" +#ifndef AO_LISP_POOL #define AO_LISP_POOL 1024 +#endif extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #endif @@ -68,6 +79,7 @@ extern uint16_t ao_lisp_top; extern uint8_t ao_lisp_exception; typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; static inline int ao_lisp_is_const(ao_poly poly) { @@ -157,6 +169,7 @@ enum ao_lisp_builtin_id { builtin_quote, builtin_set, builtin_setq, + builtin_cond, builtin_print, builtin_plus, builtin_minus, @@ -222,13 +235,13 @@ ao_lisp_cons_poly(struct ao_lisp_cons *cons) static inline int ao_lisp_poly_int(ao_poly poly) { - return (int) poly >> AO_LISP_TYPE_SHIFT; + return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); } static inline ao_poly ao_lisp_int_poly(int i) { - return ((ao_poly) i << 2) + AO_LISP_INT; + return ((ao_poly) i << 2) | AO_LISP_INT; } static inline char * @@ -326,8 +339,7 @@ extern const struct ao_lisp_type ao_lisp_atom_type; extern struct ao_lisp_atom *ao_lisp_atoms; -void -ao_lisp_atom_init(void); +extern struct ao_lisp_frame *ao_lisp_frame_current; void ao_lisp_atom_print(ao_poly a); @@ -359,12 +371,27 @@ ao_lisp_poly_move(ao_poly p); ao_poly ao_lisp_eval(ao_poly p); +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *cons); + /* builtin */ void ao_lisp_builtin_print(ao_poly b); extern const struct ao_lisp_type ao_lisp_builtin_type; +/* Check argument count */ +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc); + /* read */ ao_poly ao_lisp_read(void); @@ -376,11 +403,8 @@ 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); +ao_poly * +ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num, int readonly); @@ -388,4 +412,9 @@ 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); +/* error */ + +ao_poly +ao_lisp_error(int error, char *format, ...); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index e5d28c3b..ea04741e 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -109,31 +109,65 @@ ao_lisp_atom_intern(char *name) return atom; } -static struct ao_lisp_frame *globals; +static struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; + +static void +ao_lisp_atom_init(void) +{ + if (!ao_lisp_frame_global) { + ao_lisp_frame_global = ao_lisp_frame_new(0, 0); + ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global); + ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current); + } +} + +static ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ + ao_poly *ref; + ao_lisp_atom_init(); + while (frame) { + ref = ao_lisp_frame_ref(frame, atom); + if (ref) + return ref; + frame = ao_lisp_poly_frame(frame->next); + } + if (ao_lisp_frame_global) { + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + return ref; + } + return NULL; +} ao_poly ao_lisp_atom_get(ao_poly atom) { - struct ao_lisp_frame *frame = globals; + ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); #ifdef ao_builtin_frame - if (!frame) - frame = ao_lisp_poly_frame(ao_builtin_frame); + if (!ref) + ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); #endif - return ao_lisp_frame_get(frame, atom); + if (ref) + return *ref; + return AO_LISP_NIL; } 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 - } - } + ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + *ref = val; + else + ao_lisp_frame_global = ao_lisp_frame_add(ao_lisp_frame_global, atom, val); return val; } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 8c481793..2976bc95 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -46,7 +46,8 @@ ao_lisp_builtin_print(ao_poly b) printf("[builtin]"); } -static int check_argc(struct ao_lisp_cons *cons, int min, int max) +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) { int argc = 0; @@ -54,28 +55,30 @@ static int check_argc(struct ao_lisp_cons *cons, int min, int max) argc++; cons = ao_lisp_poly_cons(cons->cdr); } - if (argc < min || argc > max) { - ao_lisp_exception |= AO_LISP_INVALID; - return 0; - } - return 1; + if (argc < min || argc > max) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); + return _ao_lisp_atom_t; } -static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc) { - ao_poly car; - - /* find the desired arg */ - while (argc--) + while (argc--) { + if (!cons) + return AO_LISP_NIL; cons = ao_lisp_poly_cons(cons->cdr); - car = cons->car; - if ((!car && !nil_ok) || - ao_lisp_poly_type(car) != type) - { - ao_lisp_exception |= AO_LISP_INVALID; - return 0; } - return 1; + return cons->car; +} + +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_lisp_arg(cons, argc); + + if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); + return _ao_lisp_atom_t; } enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; @@ -83,30 +86,20 @@ enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; ao_poly ao_lisp_car(struct ao_lisp_cons *cons) { - if (!check_argc(cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) return AO_LISP_NIL; - if (!check_argt(cons, 0, AO_LISP_CONS, 0)) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) return AO_LISP_NIL; - } return ao_lisp_poly_cons(cons->car)->car; } ao_poly ao_lisp_cdr(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) return AO_LISP_NIL; - } - if (!cons->car) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) return AO_LISP_NIL; - } return ao_lisp_poly_cons(cons->car)->cdr; } @@ -114,50 +107,39 @@ ao_poly ao_lisp_cons(struct ao_lisp_cons *cons) { ao_poly car, cdr; - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - car = cons->car; - cdr = cons->cdr; - if (!car || !cdr) { - ao_lisp_exception |= AO_LISP_INVALID; + if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) return AO_LISP_NIL; - } - cdr = ao_lisp_poly_cons(cdr)->car; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) return AO_LISP_NIL; - } + car = ao_lisp_arg(cons, 0); + cdr = ao_lisp_arg(cons, 1); return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); } ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) return AO_LISP_NIL; - } - return cons->car; + return ao_lisp_arg(cons, 0); } ao_poly ao_lisp_set(struct ao_lisp_cons *cons) { - if (!check_argc(cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) return AO_LISP_NIL; - if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) + if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) return AO_LISP_NIL; - return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car); + return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_poly_cons(ao_lisp_arg(cons, 1))->car); } ao_poly ao_lisp_setq(struct ao_lisp_cons *cons) { struct ao_lisp_cons *expand = 0; - if (!check_argc(cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; expand = ao_lisp_cons_cons(_ao_lisp_atom_set, ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, @@ -166,6 +148,22 @@ ao_lisp_setq(struct ao_lisp_cons *cons) return ao_lisp_cons_poly(expand); } +ao_poly +ao_lisp_cond(struct ao_lisp_cons *cons) +{ + int argc; + struct ao_lisp_cons *arg; + + argc = 0; + for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) { + if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", + ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc); + } + ao_lisp_set_cond(cons); + return AO_LISP_NIL; +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -210,17 +208,13 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) r *= c; break; case math_divide: - if (c == 0) { - ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; - return AO_LISP_NIL; - } + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); r /= c; break; case math_mod: - if (c == 0) { - ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; - return AO_LISP_NIL; - } + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); r %= c; break; } @@ -230,10 +224,8 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), ao_lisp_poly_string(car))); - else { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } + else + return ao_lisp_error(AO_LISP_INVALID, "invalid args"); } return ret; } @@ -275,6 +267,7 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, + [builtin_cond] = ao_lisp_cond, [builtin_print] = ao_lisp_print, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index aa356d45..5ee15899 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1 +1,4 @@ cadr (lambda (l) (car (cdr l))) +list (lexpr (l) l) +1+ (lambda (x) (+ x 1)) +1- (lambda (x) (- x 1)) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c new file mode 100644 index 00000000..ea8111d9 --- /dev/null +++ b/src/lisp/ao_lisp_error.c @@ -0,0 +1,29 @@ +/* + * 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" +#include + +ao_poly +ao_lisp_error(int error, char *format, ...) +{ + va_list args; + + ao_lisp_exception |= error; + va_start(args, format); + vprintf(format, args); + va_end(args); + printf("\n"); + return AO_LISP_NIL; +} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 6eef1f23..803f1e2e 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -14,32 +14,238 @@ #include "ao_lisp.h" -/* - * Non-recursive eval - * - * Plan: walk actuals, construct formals - * - * stack > save > actuals > actual_1 - * v v - * formals . > actual_2 - */ - -static struct ao_lisp_cons *stack; -static struct ao_lisp_cons *actuals; -static struct ao_lisp_cons *formals; -static struct ao_lisp_cons *formals_tail; -static uint8_t been_here; - #if 0 #define DBG(...) printf(__VA_ARGS__) -#define DBG_CONS(a) ao_lisp_cons_print(a) +#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_print(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) #else #define DBG(...) #define DBG_CONS(a) #define DBG_POLY(a) #endif +struct ao_lisp_stack { + ao_poly next; + ao_poly actuals; + ao_poly formals; + ao_poly frame; + ao_poly cond; +}; + +static struct ao_lisp_stack * +ao_lisp_poly_stack(ao_poly p) +{ + return ao_lisp_ref(p); +} + +static ao_poly +ao_lisp_stack_poly(struct ao_lisp_stack *stack) +{ + return ao_lisp_poly(stack, AO_LISP_OTHER); +} + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_lisp_stack *stack = addr; + for (;;) { + ao_lisp_poly_mark(stack->actuals); + ao_lisp_poly_mark(stack->formals); + ao_lisp_poly_mark(stack->frame); + ao_lisp_poly_mark(stack->cond); + stack = ao_lisp_poly_stack(stack->next); + if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + for (;;) { + struct ao_lisp_stack *next; + stack->actuals = ao_lisp_poly_move(stack->actuals); + stack->formals = ao_lisp_poly_move(stack->formals); + stack->frame = ao_lisp_poly_move(stack->frame); + stack->cond = ao_lisp_poly_move(stack->cond); + next = ao_lisp_ref(stack->next); + next = ao_lisp_move_memory(next, sizeof (struct ao_lisp_stack)); + stack->next = ao_lisp_stack_poly(next); + stack = next; + } +} + +static const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move +}; + + +static struct ao_lisp_stack *stack; +static struct ao_lisp_cons *actuals; +static struct ao_lisp_cons *formals; +static struct ao_lisp_cons *formals_tail; +static struct ao_lisp_cons *cond; +struct ao_lisp_frame *next_frame; +static uint8_t been_here; + +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *c) +{ + cond = c; + return AO_LISP_NIL; +} + +static int +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *n = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!n) + return 0; + n->next = ao_lisp_stack_poly(stack); + n->actuals = ao_lisp_cons_poly(actuals); + n->formals = ao_lisp_cons_poly(formals); + n->cond = ao_lisp_cons_poly(cond); + n->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBG("push frame %d\n", OFFSET(ao_lisp_frame_current)); + stack = n; + return 1; +} + +static void +ao_lisp_stack_pop(void) +{ + actuals = ao_lisp_poly_cons(stack->actuals); + formals = ao_lisp_poly_cons(stack->formals); + cond = ao_lisp_poly_cons(stack->cond); + ao_lisp_frame_current = ao_lisp_poly_frame(stack->frame); + DBG("pop frame %d\n", OFFSET(ao_lisp_frame_current)); + formals_tail = 0; + + /* Recompute the tail of the formals list */ + if (formals) { + struct ao_lisp_cons *formal; + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); + formals_tail = formal; + } + stack = ao_lisp_poly_stack(stack->next); +} + +static void +ao_lisp_stack_clear(void) +{ + stack = 0; + actuals = formals = formals_tail = 0; + cond = 0; + ao_lisp_frame_current = 0; +} + + +static ao_poly +func_type(ao_poly func) +{ + struct ao_lisp_cons *cons; + struct ao_lisp_cons *args; + int f; + + DBG("func type "); DBG_POLY(func); DBG("\n"); + if (func == AO_LISP_NIL) + return ao_lisp_error(AO_LISP_INVALID, "func is nil"); + if (ao_lisp_poly_type(func) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "func is not list"); + cons = ao_lisp_poly_cons(func); + if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1)); + f = 0; + while (args) { + if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) { + return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f); + } + args = ao_lisp_poly_cons(args->cdr); + f++; + } + return ao_lisp_arg(cons, 0); +} + +static int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} + +static ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ + ao_poly type; + struct ao_lisp_cons *lambda; + struct ao_lisp_cons *args; + int args_wanted; + int args_provided; + + lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + DBG("lambda "); DBG_CONS(lambda); DBG("\n"); + type = ao_lisp_arg(lambda, 0); + args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1)); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + if (type == _ao_lisp_atom_lambda) + args_provided = ao_lisp_cons_length(cons) - 1; + else + args_provided = 1; + if (args_wanted != args_provided) + return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + next_frame = ao_lisp_frame_new(args_wanted, 0); + DBG("new frame %d\n", OFFSET(next_frame)); + switch (type) { + case _ao_lisp_atom_lambda: { + int f; + struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); + + for (f = 0; f < args_wanted; f++) { + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = vals->car; + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + break; + } + case _ao_lisp_atom_lexpr: + case _ao_lisp_atom_nlambda: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = cons->cdr; + break; + case _ao_lisp_atom_macro: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = ao_lisp_cons_poly(cons); + break; + } + return ao_lisp_arg(lambda, 2); +} + ao_poly ao_lisp_eval(ao_poly v) { @@ -48,7 +254,7 @@ ao_lisp_eval(ao_poly v) if (!been_here) { been_here = 1; - ao_lisp_root_add(&ao_lisp_cons_type, &stack); + ao_lisp_root_add(&ao_lisp_stack_type, &stack); ao_lisp_root_add(&ao_lisp_cons_type, &actuals); ao_lisp_root_add(&ao_lisp_cons_type, &formals); ao_lisp_root_add(&ao_lisp_cons_type, &formals_tail); @@ -57,29 +263,43 @@ ao_lisp_eval(ao_poly v) actuals = 0; formals = 0; formals_tail = 0; + cond = 0; for (;;) { restart: + if (cond) { + if (cond->car == AO_LISP_NIL) { + cond = AO_LISP_NIL; + v = AO_LISP_NIL; + } else { + if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "malformed cond"); + goto bail; + } + v = ao_lisp_poly_cons(cond->car)->car; + } + } + /* Build stack frames for each list */ while (ao_lisp_poly_type(v) == AO_LISP_CONS) { if (v == AO_LISP_NIL) break; - /* Push existing frame on the stack */ - if (cons++) { - struct ao_lisp_cons *frame; + /* Push existing bits on the stack */ + if (cons++) + if (!ao_lisp_stack_push()) + goto bail; - frame = ao_lisp_cons_cons(ao_lisp_cons_poly(actuals), formals); - stack = ao_lisp_cons_cons(ao_lisp_cons_poly(frame), stack); - } actuals = ao_lisp_poly_cons(v); formals = NULL; formals_tail = NULL; + cond = NULL; + v = actuals->car; - DBG("start: stack"); DBG_CONS(stack); DBG("\n"); - DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); - DBG("start: formals"); DBG_CONS(formals); DBG("\n"); +// DBG("start: stack"); DBG_CONS(stack); DBG("\n"); +// DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); +// DBG("start: formals"); DBG_CONS(formals); DBG("\n"); } /* Evaluate primitive types */ @@ -95,19 +315,19 @@ ao_lisp_eval(ao_poly v) break; } - if (!cons) - break; - - for (;;) { + while (cons) { DBG("add formal: "); DBG_POLY(v); DBG("\n"); + /* We've processed the first element of the list, go check + * what kind of function we've got + */ if (formals == NULL) { if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); switch (b->args) { case AO_LISP_NLAMBDA: - v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); - goto done_eval; + formals = actuals; + goto eval; case AO_LISP_MACRO: v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); @@ -115,15 +335,28 @@ ao_lisp_eval(ao_poly v) DBG(" -> "); DBG_POLY(v); DBG("\n"); if (ao_lisp_poly_type(v) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; + ao_lisp_error(AO_LISP_INVALID, "macro didn't return list"); + goto bail; } - /* Reset frame to the new list */ actuals = ao_lisp_poly_cons(v); v = actuals->car; goto restart; } + } else { + switch (func_type(v)) { + case _ao_lisp_atom_lambda: + case _ao_lisp_atom_lexpr: + break; + case _ao_lisp_atom_nlambda: + formals = actuals; + goto eval; + case _ao_lisp_atom_macro: + break; + default: + ao_lisp_error(AO_LISP_INVALID, "operator is not a function"); + goto bail; + } } } @@ -150,6 +383,8 @@ ao_lisp_eval(ao_poly v) v = formals->car; + eval: + /* Evaluate the resulting list */ if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); @@ -161,41 +396,54 @@ ao_lisp_eval(ao_poly v) DBG(" -> "); DBG_POLY(v); DBG ("\n"); + if (ao_lisp_exception) + goto bail; + + if (cond) + goto restart; } else { - ao_lisp_exception |= AO_LISP_INVALID; + v = ao_lisp_lambda(formals); + if (ao_lisp_exception) + goto bail; } - if (ao_lisp_exception) - return AO_LISP_NIL; - done_eval: - if (--cons) { - struct ao_lisp_cons *frame; - - /* Pop the previous frame off the stack */ - frame = ao_lisp_poly_cons(stack->car); - actuals = ao_lisp_poly_cons(frame->car); - formals = ao_lisp_poly_cons(frame->cdr); - formals_tail = NULL; - - /* Recompute the tail of the formals list */ - if (formals) { - for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); - formals_tail = formal; - } - stack = ao_lisp_poly_cons(stack->cdr); - DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); - DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); - DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); + --cons; + if (cons) { + ao_lisp_stack_pop(); +// DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); +// 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; + ao_lisp_frame_current = 0; + } + if (next_frame) { + ao_lisp_frame_current = next_frame; + DBG("next frame %d\n", OFFSET(next_frame)); + next_frame = 0; + goto restart; + } + if (cond) { + if (v) { + v = ao_lisp_poly_cons(cond->car)->cdr; + if (v != AO_LISP_NIL) { + v = ao_lisp_poly_cons(v)->car; + goto restart; + } + } else { + cond = ao_lisp_poly_cons(cond->cdr); + goto restart; + } } } if (!cons) break; } + DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current)); return v; +bail: + ao_lisp_stack_clear(); + return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 5aa50f6b..1853f6d7 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -95,7 +95,7 @@ const struct ao_lisp_type ao_lisp_frame_type = { .move = frame_move }; -static ao_poly * +ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6b603979..9c2ea74c 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -39,6 +39,7 @@ struct builtin_func funcs[] = { "quote", AO_LISP_NLAMBDA,builtin_quote, "set", AO_LISP_LEXPR, builtin_set, "setq", AO_LISP_MACRO, builtin_setq, + "cond", AO_LISP_NLAMBDA,builtin_cond, "print", AO_LISP_LEXPR, builtin_print, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, @@ -47,8 +48,25 @@ struct builtin_func funcs[] = { "%", AO_LISP_LEXPR, builtin_mod }; +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *c) +{ + (void) c; + return AO_LISP_NIL; +} + #define N_FUNC (sizeof funcs / sizeof funcs[0]) +/* Syntactic atoms */ +char *atoms[] = { + "lambda", + "nlambda", + "lexpr", + "macro" +}; + +#define N_ATOM (sizeof atoms / sizeof atoms[0]) + struct ao_lisp_frame *globals; static int @@ -65,9 +83,10 @@ is_atom(int offset) int main(int argc, char **argv) { - int f, o; + int f, o, i; ao_poly atom, val; struct ao_lisp_atom *a; + struct ao_lisp_builtin *b; int in_atom; printf("/*\n"); @@ -75,11 +94,15 @@ main(int argc, char **argv) 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); + b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); + a = ao_lisp_atom_intern(funcs[f].name); globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } + /* atoms for syntax */ + for (i = 0; i < N_ATOM; i++) + (void) ao_lisp_atom_intern(atoms[i]); + /* boolean constants */ a = ao_lisp_atom_intern("nil"); globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index a1f9fa1f..d780186a 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -25,12 +25,6 @@ ao_lisp_read_eval_print(void) // printf ("in: "); ao_lisp_poly_print(in); printf("\n"); out = ao_lisp_eval(in); if (ao_lisp_exception) { - if (ao_lisp_exception & AO_LISP_OOM) - printf("out of memory\n"); - if (ao_lisp_exception & AO_LISP_DIVIDE_BY_ZERO) - printf("divide by zero\n"); - if (ao_lisp_exception & AO_LISP_INVALID) - printf("invalid operation\n"); ao_lisp_exception = 0; } else { ao_lisp_poly_print(out); diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 1b7e0bb0..388e581c 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -46,6 +46,7 @@ ALTOS_SRC = \ ao_lisp_read.c \ ao_lisp_rep.c \ ao_lisp_frame.c \ + ao_lisp_error.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index 76200176..65de89ed 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -24,6 +24,8 @@ #define LED_PIN_GREEN 3 #define AO_LED_GREEN (1 << LED_PIN_GREEN) #define AO_LED_PANIC AO_LED_GREEN +#define AO_CMD_LEN 128 +#define AO_LISP_POOL 2048 #define LEDS_AVAILABLE (AO_LED_GREEN) diff --git a/src/test/Makefile b/src/test/Makefile index bd195161..8d617eea 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -93,7 +93,8 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h 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_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \ + ao_lisp_error.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 e303869f..8bc677da 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -15,15 +15,18 @@ #include "ao_lisp.h" #include +#if 0 static struct ao_lisp_cons *list; static char *string; +#endif int main (int argc, char **argv) { +#if 0 int i, j; - struct ao_lisp_atom *atom; + struct ao_lisp_atom *atom; ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list); ao_lisp_root_add(&ao_lisp_string_type, (void **) &string); @@ -47,7 +50,8 @@ main (int argc, char **argv) ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom))); printf("\n"); } -#if 1 +#endif +#if 0 list = ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), ao_lisp_cons_cons(ao_lisp_int_poly(3), @@ -58,7 +62,8 @@ main (int argc, char **argv) printf ("\n"); ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list))); printf ("\n"); - +#endif +#if 1 ao_lisp_read_eval_print(); #endif } -- cgit v1.2.3 From 3366efb139653939f053c1fe4aba352ba3b66c94 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 5 Nov 2016 14:51:58 -0700 Subject: altos/lisp: Change GC move API Pass reference to move API so it can change the values in-place, then let it return '1' when the underlying object has already been moved to shorten GC times. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 38 +++-- src/lisp/ao_lisp_atom.c | 26 +--- src/lisp/ao_lisp_builtin.c | 142 +++++++++++++++-- src/lisp/ao_lisp_cons.c | 37 +---- src/lisp/ao_lisp_const.lisp | 3 + src/lisp/ao_lisp_eval.c | 349 ++++++++++++------------------------------ src/lisp/ao_lisp_frame.c | 48 +++--- src/lisp/ao_lisp_make_const.c | 11 +- src/lisp/ao_lisp_mem.c | 169 ++++++++++++++++---- src/lisp/ao_lisp_prim.c | 44 +++++- 10 files changed, 464 insertions(+), 403 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 9a5cc63e..27174e13 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -46,7 +46,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL -#define AO_LISP_POOL 1024 +#define AO_LISP_POOL 16384 #endif extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #endif @@ -94,6 +94,8 @@ ao_lisp_is_const(ao_poly poly) { static inline void * ao_lisp_ref(ao_poly poly) { + if (poly == 0xBEEF) + abort(); if (poly == AO_LISP_NIL) return NULL; if (poly & AO_LISP_CONST) @@ -135,8 +137,8 @@ struct ao_lisp_val { }; struct ao_lisp_frame { + uint8_t type; uint8_t num; - uint8_t readonly; ao_poly next; struct ao_lisp_val vals[]; }; @@ -176,6 +178,11 @@ enum ao_lisp_builtin_id { builtin_times, builtin_divide, builtin_mod, + builtin_equal, + builtin_less, + builtin_greater, + builtin_less_equal, + builtin_greater_equal, builtin_last }; @@ -281,7 +288,8 @@ ao_lisp_builtin_poly(struct ao_lisp_builtin *b) } /* memory functions */ -void +/* returns 1 if the object was already marked */ +int ao_lisp_mark(const struct ao_lisp_type *type, void *addr); /* returns 1 if the object was already marked */ @@ -291,12 +299,13 @@ 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); +/* returns 1 if the object was already moved */ +int +ao_lisp_move(const struct ao_lisp_type *type, void **ref); -/* returns NULL if the object was already moved */ -void * -ao_lisp_move_memory(void *addr, int size); +/* returns 1 if the object was already moved */ +int +ao_lisp_move_memory(void **ref, int size); void * ao_lisp_alloc(int size); @@ -307,6 +316,9 @@ ao_lisp_collect(void); int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); +int +ao_lisp_root_poly_add(ao_poly *p); + void ao_lisp_root_clear(void *addr); @@ -361,13 +373,15 @@ ao_lisp_int_print(ao_poly i); ao_poly ao_lisp_poly_print(ao_poly p); -void +int ao_lisp_poly_mark(ao_poly p); -ao_poly -ao_lisp_poly_move(ao_poly p); +/* returns 1 if the object has already been moved */ +int +ao_lisp_poly_move(ao_poly *p); /* eval */ + ao_poly ao_lisp_eval(ao_poly p); @@ -407,7 +421,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * -ao_lisp_frame_new(int num, int readonly); +ao_lisp_frame_new(int num); struct ao_lisp_frame * ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index ea04741e..5f1bcda0 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -17,12 +17,6 @@ #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; @@ -40,38 +34,24 @@ static void atom_mark(void *addr) { struct ao_lisp_atom *atom = addr; - DBG ("\tatom start %s\n", atom->name); for (;;) { 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; - - next = ao_lisp_poly_atom(atom->next); - next = ao_lisp_move_memory(next, atom_size(next)); - if (!next) + if (ao_lisp_poly_move(&atom->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; + atom = ao_lisp_poly_atom(atom->next); } - DBG("\tatom move end\n"); } const struct ao_lisp_type ao_lisp_atom_type = { @@ -116,7 +96,7 @@ static void ao_lisp_atom_init(void) { if (!ao_lisp_frame_global) { - ao_lisp_frame_global = ao_lisp_frame_new(0, 0); + ao_lisp_frame_global = ao_lisp_frame_new(0); ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global); ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current); } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index fe729f20..0ad1f464 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -63,6 +63,8 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) ao_poly ao_lisp_arg(struct ao_lisp_cons *cons, int argc) { + if (!cons) + return AO_LISP_NIL; while (argc--) { if (!cons) return AO_LISP_NIL; @@ -81,8 +83,6 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, return _ao_lisp_atom_t; } -enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; - ao_poly ao_lisp_car(struct ao_lisp_cons *cons) { @@ -175,11 +175,12 @@ ao_lisp_print(struct ao_lisp_cons *cons) if (cons) printf(" "); } + printf("\n"); return val; } ao_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) +ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) { ao_poly ret = AO_LISP_NIL; @@ -198,30 +199,32 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) int c = ao_lisp_poly_int(car); switch(op) { - case math_plus: + case builtin_plus: r += c; break; - case math_minus: + case builtin_minus: r -= c; break; - case math_times: + case builtin_times: r *= c; break; - case math_divide: + case builtin_divide: if (c == 0) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); r /= c; break; - case math_mod: + case builtin_mod: if (c == 0) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); r %= c; break; + default: + break; } ret = ao_lisp_int_poly(r); } - else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) + else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), ao_lisp_poly_string(car))); else @@ -233,31 +236,135 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) ao_poly ao_lisp_plus(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, math_plus); + return ao_lisp_math(cons, builtin_plus); } ao_poly ao_lisp_minus(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, math_minus); + return ao_lisp_math(cons, builtin_minus); } ao_poly ao_lisp_times(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, math_times); + return ao_lisp_math(cons, builtin_times); } ao_poly ao_lisp_divide(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, math_divide); + return ao_lisp_math(cons, builtin_divide); } ao_poly ao_lisp_mod(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, math_mod); + return ao_lisp_math(cons, builtin_mod); +} + +ao_poly +ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +{ + ao_poly left; + + if (!cons) + return _ao_lisp_atom_t; + + left = cons->car; + cons = ao_lisp_poly_cons(cons->cdr); + while (cons) { + ao_poly right = cons->car; + + if (op == builtin_equal) { + if (left != right) + return AO_LISP_NIL; + } else { + uint8_t lt = ao_lisp_poly_type(left); + uint8_t rt = ao_lisp_poly_type(right); + if (lt == AO_LISP_INT && rt == AO_LISP_INT) { + int l = ao_lisp_poly_int(left); + int r = ao_lisp_poly_int(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return AO_LISP_NIL; + break; + case builtin_greater: + if (!(l > r)) + return AO_LISP_NIL; + break; + case builtin_less_equal: + if (!(l <= r)) + return AO_LISP_NIL; + break; + case builtin_greater_equal: + if (!(l >= r)) + return AO_LISP_NIL; + break; + default: + break; + } + } else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) { + int c = strcmp(ao_lisp_poly_string(left), + ao_lisp_poly_string(right)); + switch (op) { + case builtin_less: + if (!(c < 0)) + return AO_LISP_NIL; + break; + case builtin_greater: + if (!(c > 0)) + return AO_LISP_NIL; + break; + case builtin_less_equal: + if (!(c <= 0)) + return AO_LISP_NIL; + break; + case builtin_greater_equal: + if (!(c >= 0)) + return AO_LISP_NIL; + break; + default: + break; + } + } + } + left = right; + cons = ao_lisp_poly_cons(cons->cdr); + } + return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_equal(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_equal); +} + +ao_poly +ao_lisp_less(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_less); +} + +ao_poly +ao_lisp_greater(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_greater); +} + +ao_poly +ao_lisp_less_equal(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_less_equal); +} + +ao_poly +ao_lisp_greater_equal(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_greater_equal); } ao_lisp_func_t ao_lisp_builtins[] = { @@ -273,6 +380,11 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_minus] = ao_lisp_minus, [builtin_times] = ao_lisp_times, [builtin_divide] = ao_lisp_divide, - [builtin_mod] = ao_lisp_mod + [builtin_mod] = ao_lisp_mod, + [builtin_equal] = ao_lisp_equal, + [builtin_less] = ao_lisp_less, + [builtin_greater] = ao_lisp_greater, + [builtin_less_equal] = ao_lisp_less_equal, + [builtin_greater_equal] = ao_lisp_greater_equal }; diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index f8a34ed4..4929b91c 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -16,21 +16,6 @@ #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; @@ -55,25 +40,15 @@ 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; + if (!cons) + return; - 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) + for (;;) { + (void) ao_lisp_poly_move(&cons->car); + if (ao_lisp_poly_move(&cons->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; + cons = ao_lisp_poly_cons(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_const.lisp b/src/lisp/ao_lisp_const.lisp index 5ee15899..5ca89bd4 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1,4 +1,7 @@ cadr (lambda (l) (car (cdr l))) +caddr (lambda (l) (car (cdr (cdr l)))) list (lexpr (l) l) 1+ (lambda (x) (+ x 1)) 1- (lambda (x) (- x 1)) +last (lambda (x) (cond ((cdr x) (last (cdr x))) ((car x)))) +prog* (lexpr (l) (last l)) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 2b2cfee7..b7e7b972 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -37,8 +37,11 @@ static int stack_depth; enum eval_state { eval_sexpr, eval_val, + eval_formal, eval_exec, - eval_exec_direct + eval_exec_direct, + eval_cond, + eval_cond_test }; struct ao_lisp_stack { @@ -84,20 +87,26 @@ stack_mark(void *addr) } } +static const struct ao_lisp_type ao_lisp_stack_type; + static void stack_move(void *addr) { struct ao_lisp_stack *stack = addr; - for (;;) { - struct ao_lisp_stack *prev; - stack->actuals = ao_lisp_poly_move(stack->actuals); - stack->formals = ao_lisp_poly_move(stack->formals); - stack->frame = ao_lisp_poly_move(stack->frame); - prev = ao_lisp_ref(stack->prev); - prev = ao_lisp_move_memory(prev, sizeof (struct ao_lisp_stack)); - stack->prev = ao_lisp_stack_poly(prev); - stack = prev; + while (stack) { + void *prev; + int ret; + (void) ao_lisp_poly_move(&stack->actuals); + (void) ao_lisp_poly_move(&stack->formals); + (void) ao_lisp_poly_move(&stack->frame); + prev = ao_lisp_poly_stack(stack->prev); + ret = ao_lisp_move(&ao_lisp_stack_type, &prev); + if (prev != ao_lisp_poly_stack(stack->prev)) + stack->prev = ao_lisp_stack_poly(prev); + if (ret); + break; + stack = ao_lisp_poly_stack(stack->prev); } } @@ -107,17 +116,19 @@ static const struct ao_lisp_type ao_lisp_stack_type = { .move = stack_move }; - static struct ao_lisp_stack *ao_lisp_stack; +static ao_poly ao_lisp_v; static uint8_t been_here; ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { + ao_lisp_stack->state = eval_cond; + ao_lisp_stack->actuals = ao_lisp_cons_poly(c); return AO_LISP_NIL; } -static void +void ao_lisp_stack_reset(struct ao_lisp_stack *stack) { stack->state = eval_sexpr; @@ -128,21 +139,21 @@ ao_lisp_stack_reset(struct ao_lisp_stack *stack) stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); } -static struct ao_lisp_stack * +struct ao_lisp_stack * ao_lisp_stack_push(void) { struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) return NULL; stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - ao_lisp_stack_reset(stack); ao_lisp_stack = stack; + ao_lisp_stack_reset(stack); DBGI("stack push\n"); DBG_IN(); return stack; } -static struct ao_lisp_stack * +struct ao_lisp_stack * ao_lisp_stack_pop(void) { if (!ao_lisp_stack) @@ -164,7 +175,6 @@ ao_lisp_stack_clear(void) ao_lisp_frame_current = NULL; } - static ao_poly func_type(ao_poly func) { @@ -196,8 +206,11 @@ func_type(ao_poly func) f++; } return ao_lisp_arg(cons, 0); - } else - return ao_lisp_error(AO_LISP_INVALID, "not a func"); + } else { + ao_lisp_error(AO_LISP_INVALID, "not a func"); + abort(); + return AO_LISP_NIL; + } } static int @@ -236,7 +249,7 @@ ao_lisp_lambda(struct ao_lisp_cons *cons) args_provided = 1; if (args_wanted != args_provided) return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); - next_frame = ao_lisp_frame_new(args_wanted, 0); + next_frame = ao_lisp_frame_new(args_wanted); DBGI("new frame %d\n", OFFSET(next_frame)); switch (type) { case _ao_lisp_atom_lambda: { @@ -268,14 +281,16 @@ ao_lisp_lambda(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_eval(ao_poly v) +ao_lisp_eval(ao_poly _v) { struct ao_lisp_stack *stack; ao_poly formal; + ao_lisp_v = _v; if (!been_here) { been_here = 1; - ao_lisp_root_add(&ao_lisp_stack_type, &stack); + ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack); + ao_lisp_root_poly_add(&ao_lisp_v); } stack = ao_lisp_stack_push(); @@ -285,19 +300,20 @@ ao_lisp_eval(ao_poly v) return AO_LISP_NIL; switch (stack->state) { case eval_sexpr: - DBGI("sexpr: "); DBG_POLY(v); DBG("\n"); - switch (ao_lisp_poly_type(v)) { + DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); + switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_CONS: - if (v == AO_LISP_NIL) { + if (ao_lisp_v == AO_LISP_NIL) { stack->state = eval_exec; break; } - stack->actuals = v; + stack->actuals = ao_lisp_v; + stack->state = eval_formal; stack = ao_lisp_stack_push(); - v = ao_lisp_poly_cons(v)->car; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; break; case AO_LISP_ATOM: - v = ao_lisp_atom_get(v); + ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); /* fall through */ case AO_LISP_INT: case AO_LISP_STRING: @@ -306,15 +322,17 @@ ao_lisp_eval(ao_poly v) } break; case eval_val: - DBGI("val: "); DBG_POLY(v); DBG("\n"); + DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); stack = ao_lisp_stack_pop(); if (!stack) - return v; + return ao_lisp_v; + DBGI("..state %d\n", stack->state); + break; - stack->state = eval_sexpr; + case eval_formal: /* Check what kind of function we've got */ if (!stack->formals) { - switch (func_type(v)) { + switch (func_type(ao_lisp_v)) { case AO_LISP_LAMBDA: case _ao_lisp_atom_lambda: case AO_LISP_LEXPR: @@ -335,7 +353,7 @@ ao_lisp_eval(ao_poly v) break; } - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(v, NULL)); + formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); if (!formal) { ao_lisp_stack_clear(); return AO_LISP_NIL; @@ -349,257 +367,78 @@ ao_lisp_eval(ao_poly v) DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n"); - v = ao_lisp_poly_cons(stack->actuals)->cdr; + ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->cdr; + + stack->state = eval_sexpr; break; case eval_exec: - v = ao_lisp_poly_cons(stack->formals)->car; + if (!stack->formals) { + ao_lisp_v = AO_LISP_NIL; + stack->state = eval_val; + break; + } + ao_lisp_v = ao_lisp_poly_cons(stack->formals)->car; case eval_exec_direct: - DBGI("exec: macro %d ", stack->macro); DBG_POLY(v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n"); - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); + DBGI("exec: macro %d ", stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n"); + if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) { + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr); DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n"); - v = ao_lisp_func(b) (f); - DBGI("builtin result:"); DBG_POLY(v); DBG ("\n"); - if (ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } if (stack->macro) stack->state = eval_sexpr; else stack->state = eval_val; stack->macro = 0; + ao_lisp_v = ao_lisp_func(b) (f); + DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n"); + if (ao_lisp_exception) { + ao_lisp_stack_clear(); + return AO_LISP_NIL; + } break; } else { - v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals)); + ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals)); ao_lisp_stack_reset(stack); } break; - } - } -} -#if 0 - - - restart: - if (cond) { - DBGI("cond is now "); DBG_CONS(cond); DBG("\n"); - if (cond->car == AO_LISP_NIL) { - cond = AO_LISP_NIL; - v = AO_LISP_NIL; + case eval_cond: + DBGI("cond: "); DBG_POLY(stack->actuals); DBG("\n"); + if (!stack->actuals) { + ao_lisp_v = AO_LISP_NIL; + stack->state = eval_val; } else { - if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "malformed cond"); + ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->car; + if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); goto bail; } - v = ao_lisp_poly_cons(cond->car)->car; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + stack->state = eval_cond_test; + stack = ao_lisp_stack_push(); + stack->state = eval_sexpr; } - } - - /* Build stack frames for each list */ - while (ao_lisp_poly_type(v) == AO_LISP_CONS) { - if (v == AO_LISP_NIL) - break; - - /* Push existing bits on the stack */ - if (cons++) - if (!ao_lisp_stack_push()) - goto bail; - - actuals = ao_lisp_poly_cons(v); - formals = NULL; - formals_tail = NULL; - save_cond = cond; - cond = NULL; - - v = actuals->car; - -// DBG("start: stack"); DBG_CONS(stack); DBG("\n"); -// DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); -// DBG("start: formals"); DBG_CONS(formals); DBG("\n"); - } - - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - switch (b->args) { - case AO_LISP_NLAMBDA: - formals = actuals; - goto eval; - - case AO_LISP_MACRO: - v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); - DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals)); - DBG(" -> "); DBG_POLY(v); - DBG("\n"); - if (ao_lisp_poly_type(v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "macro didn't return list"); - goto bail; - } - /* Reset frame to the new list */ - actuals = ao_lisp_poly_cons(v); - v = actuals->car; - goto restart; - } - /* Evaluate primitive types */ - - DBG ("actual: "); DBG_POLY(v); DBG("\n"); - - switch (ao_lisp_poly_type(v)) { - case AO_LISP_INT: - case AO_LISP_STRING: break; - case AO_LISP_ATOM: - v = ao_lisp_atom_get(v); - break; - } - - while (cons) { - DBG("add formal: "); DBG_POLY(v); DBG("\n"); - - /* We've processed the first element of the list, go check - * what kind of function we've got - */ - if (formals == NULL) { - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - switch (b->args) { - case AO_LISP_NLAMBDA: - formals = actuals; - goto eval; - - case AO_LISP_MACRO: - v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); - DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals)); - DBG(" -> "); DBG_POLY(v); - DBG("\n"); - if (ao_lisp_poly_type(v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "macro didn't return list"); - goto bail; - } - /* Reset frame to the new list */ - actuals = ao_lisp_poly_cons(v); - v = actuals->car; - goto restart; - } + case eval_cond_test: + DBGI("cond_test "); DBG_POLY(ao_lisp_v); DBG("\n"); + if (ao_lisp_v) { + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->actuals)->car); + struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); + if (c) { + ao_lisp_v = c->car; + stack->state = eval_sexpr; } else { - switch (func_type(v)) { - case _ao_lisp_atom_lambda: - case _ao_lisp_atom_lexpr: - break; - case _ao_lisp_atom_nlambda: - formals = actuals; - goto eval; - case _ao_lisp_atom_macro: - break; - default: - ao_lisp_error(AO_LISP_INVALID, "operator is not a function"); - goto bail; - } - } - } - - formal = ao_lisp_cons_cons(v, NULL); - if (formals_tail) - formals_tail->cdr = ao_lisp_cons_poly(formal); - else - formals = formal; - formals_tail = formal; - actuals = ao_lisp_poly_cons(actuals->cdr); - - DBG("formals: "); - DBG_CONS(formals); - DBG("\n"); - DBG("actuals: "); - DBG_CONS(actuals); - DBG("\n"); - - /* Process all of the arguments */ - if (actuals) { - v = actuals->car; - break; - } - - v = formals->car; - - eval: - - /* Evaluate the resulting list */ - if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { - struct ao_lisp_cons *old_cond = cond; - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - - v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr)); - - DBG ("eval: "); - DBG_CONS(formals); - DBG(" -> "); - DBG_POLY(v); - DBG ("\n"); - if (ao_lisp_exception) - goto bail; - - if (cond != old_cond) { - DBG("cond changed from "); DBG_CONS(old_cond); DBG(" to "); DBG_CONS(cond); DBG("\n"); - actuals = NULL; - formals = 0; - formals_tail = 0; - save_cons = cons; - cons = 0; - goto restart; - } - } else { - v = ao_lisp_lambda(formals); - if (ao_lisp_exception) - goto bail; - } - - cond_done: - --cons; - if (cons) { - ao_lisp_stack_pop(); -// DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); -// 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; - ao_lisp_frame_current = 0; - } - if (next_frame) { - ao_lisp_frame_current = next_frame; - DBG("next frame %d\n", OFFSET(next_frame)); - next_frame = 0; - goto restart; - } - } - if (cond) { - DBG("next cond cons is %d\n", cons); - if (v) { - v = ao_lisp_poly_cons(cond->car)->cdr; - cond = 0; - cons = save_cons; - if (v != AO_LISP_NIL) { - v = ao_lisp_poly_cons(v)->car; - DBG("cond complete, sexpr is "); DBG_POLY(v); DBG("\n"); + stack->state = eval_val; } - goto cond_done; } else { - cond = ao_lisp_poly_cons(cond->cdr); - DBG("next cond is "); DBG_CONS(cond); DBG("\n"); - goto restart; + stack->actuals = ao_lisp_poly_cons(stack->actuals)->cdr; + stack->state = eval_cond; } - } - if (!cons) break; + } } - DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current)); - return v; bail: ao_lisp_stack_clear(); return AO_LISP_NIL; -#endif - +} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 1853f6d7..8bf98571 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -33,7 +33,7 @@ frame_size(void *addr) return frame_num_size(frame->num); } -#define OFFSET(a) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const) +#define OFFSET(a) ((int) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const)) static void frame_mark(void *addr) @@ -42,16 +42,19 @@ frame_mark(void *addr) int f; for (;;) { - if (frame->readonly) + DBG("frame mark %p\n", frame); + if (!AO_LISP_IS_POOL(frame)) 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); + 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); + DBG("frame next %p\n", frame); if (!frame) break; if (ao_lisp_mark_memory(frame, frame_size(frame))) @@ -66,26 +69,19 @@ frame_move(void *addr) int f; for (;;) { - struct ao_lisp_frame *next; - if (frame->readonly) + DBG("frame move %p\n", frame); + if (!AO_LISP_IS_POOL(frame)) 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; + + ao_lisp_poly_move(&v->atom); + DBG("moved atom %s\n", ao_lisp_poly_atom(v->atom)->name); + ao_lisp_poly_move(&v->val); } - next = ao_lisp_poly_frame(frame->next); - if (!next) + if (ao_lisp_poly_move(&frame->next)) break; - next = ao_lisp_move_memory(next, frame_size(next)); - frame->next = ao_lisp_frame_poly(next); - frame = next; + frame = ao_lisp_poly_frame(frame->next); } } @@ -109,7 +105,7 @@ int ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) { while (frame) { - if (!frame->readonly) { + if (!AO_LISP_IS_CONST(frame)) { ao_poly *ref = ao_lisp_frame_ref(frame, atom); if (ref) { *ref = val; @@ -134,28 +130,28 @@ ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) } struct ao_lisp_frame * -ao_lisp_frame_new(int num, int readonly) +ao_lisp_frame_new(int num) { struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num)); if (!frame) return NULL; + frame->type = AO_LISP_FRAME; 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) +ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) { struct ao_lisp_frame *new; int copy; if (new_num == frame->num) return frame; - new = ao_lisp_frame_new(new_num, readonly); + new = ao_lisp_frame_new(new_num); if (!new) return NULL; copy = new_num; @@ -175,10 +171,10 @@ ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) int f; if (frame) { f = frame->num; - frame = ao_lisp_frame_realloc(frame, f + 1, frame->readonly); + frame = ao_lisp_frame_realloc(frame, f + 1); } else { f = 0; - frame = ao_lisp_frame_new(1, 0); + frame = ao_lisp_frame_new(1); } if (!frame) return NULL; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 9c2ea74c..9768dc22 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -45,7 +45,12 @@ struct builtin_func funcs[] = { "-", AO_LISP_LEXPR, builtin_minus, "*", AO_LISP_LEXPR, builtin_times, "/", AO_LISP_LEXPR, builtin_divide, - "%", AO_LISP_LEXPR, builtin_mod + "%", AO_LISP_LEXPR, builtin_mod, + "=", AO_LISP_LEXPR, builtin_equal, + "<", AO_LISP_LEXPR, builtin_less, + ">", AO_LISP_LEXPR, builtin_greater, + "<=", AO_LISP_LEXPR, builtin_less_equal, + ">=", AO_LISP_LEXPR, builtin_greater_equal, }; ao_poly @@ -92,7 +97,7 @@ main(int argc, char **argv) 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); + globals = ao_lisp_frame_new(0); for (f = 0; f < N_FUNC; f++) { b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); @@ -127,8 +132,6 @@ main(int argc, char **argv) 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)); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 27f5b666..29d8dbf4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -28,9 +28,18 @@ uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); #endif #if 0 +#define DBG_COLLECT_ALWAYS +#endif + +#if 0 +#define DBG_POOL +#endif + +#if 1 #define DBG_DUMP #define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) #define DBG(...) printf(__VA_ARGS__) +#define DBG_DO(a) a static int move_dump; static int move_depth; #define DBG_RESET() (move_depth = 0) @@ -39,6 +48,7 @@ static int move_depth; #define DBG_MOVE_OUT() (move_depth--) #else #define DBG(...) +#define DBG_DO(a) #define DBG_RESET() #define DBG_MOVE(...) #define DBG_MOVE_IN() @@ -162,14 +172,24 @@ move_object(void) 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 && *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; + for (i = 0; i < AO_LISP_ROOT; i++) { + if (!ao_lisp_root[i].addr) + continue; + if (ao_lisp_root[i].type) { + DBG_DO(void *addr = *ao_lisp_root[i].addr); + DBG_MOVE("root %d\n", DBG_OFFSET(addr)); + if (!ao_lisp_move(ao_lisp_root[i].type, + ao_lisp_root[i].addr)) + DBG_MOVE("root moves from %p to %p\n", + addr, + *ao_lisp_root[i].addr); + } else { + DBG_DO(ao_poly p = *(ao_poly *) ao_lisp_root[i].addr); + if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr)) + DBG_MOVE("root poly move from %04x to %04x\n", + p, *(ao_poly *) ao_lisp_root[i].addr); } + } DBG_MOVE_OUT(); DBG_MOVE("move done\n"); } @@ -197,20 +217,39 @@ dump_busy(void) #define DUMP_BUSY() #endif +static void +ao_lisp_mark_busy(void) +{ + int i; + + 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].type) { + void **a = ao_lisp_root[i].addr, *v; + if (a && (v = *a)) { + DBG("root %p\n", v); + ao_lisp_mark(ao_lisp_root[i].type, v); + } + } else { + ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; + if (a && (p = *a)) { + DBG("root %04x\n", p); + ao_lisp_poly_mark(p); + } + } + } +} + void ao_lisp_collect(void) { int i; int top; + DBG("collect\n"); /* 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 && *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); - } + ao_lisp_mark_busy(); DUMP_BUSY(); /* Compact */ @@ -243,14 +282,15 @@ ao_lisp_collect(void) } -void +int ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { if (!addr) - return; + return 1; if (mark_object(ao_lisp_busy, addr, type->size(addr))) - return; + return 1; type->mark(addr); + return 0; } int @@ -290,28 +330,31 @@ check_move(void *addr, int size) return addr; } -void * -ao_lisp_move(const struct ao_lisp_type *type, void *addr) +int +ao_lisp_move(const struct ao_lisp_type *type, void **ref) { - uint8_t *a = addr; - int size = type->size(addr); + void *addr = *ref; + 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; + return 1; #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 (addr != *ref) + *ref = addr; if (mark_object(ao_lisp_moving, addr, size)) { DBG_MOVE("already moved\n"); DBG_MOVE_OUT(); - return addr; + return 1; } DBG_MOVE_OUT(); DBG_MOVE("recursing...\n"); @@ -319,35 +362,97 @@ ao_lisp_move(const struct ao_lisp_type *type, void *addr) type->move(addr); DBG_MOVE_OUT(); DBG_MOVE("done %d\n", DBG_OFFSET(addr)); - return addr; + return 0; } -void * -ao_lisp_move_memory(void *addr, int size) +int +ao_lisp_move_memory(void **ref, int size) { + void *addr = *ref; if (!addr) return NULL; DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); DBG_MOVE_IN(); addr = check_move(addr, size); + if (addr != *ref) + *ref = addr; if (mark_object(ao_lisp_moving, addr, size)) { DBG_MOVE("already moved\n"); DBG_MOVE_OUT(); - return addr; + return 1; } DBG_MOVE_OUT(); - return addr; + return 0; +} + +#ifdef DBG_POOL +static int AO_LISP_POOL_CUR = AO_LISP_POOL / 8; + +static void +ao_lisp_poison(void) +{ + int i; + + printf("poison\n"); + ao_lisp_mark_busy(); + for (i = 0; i < AO_LISP_POOL_CUR; i += 4) { + uint32_t *a = (uint32_t *) &ao_lisp_pool[i]; + if (!busy_object(ao_lisp_busy, a)) + *a = 0xBEEFBEEF; + } + for (i = 0; i < AO_LISP_POOL_CUR; i += 2) { + ao_poly *a = (uint16_t *) &ao_lisp_pool[i]; + ao_poly p = *a; + + if (!ao_lisp_is_const(p)) { + void *r = ao_lisp_ref(p); + + if (ao_lisp_pool <= (uint8_t *) r && + (uint8_t *) r <= ao_lisp_pool + AO_LISP_POOL_CUR) + { + if (!busy_object(ao_lisp_busy, r)) { + printf("missing reference from %d to %d\n", + (int) ((uint8_t *) a - ao_lisp_pool), + (int) ((uint8_t *) r - ao_lisp_pool)); + } + } + } + } } +#else +#define AO_LISP_POOL_CUR AO_LISP_POOL +#endif + void * ao_lisp_alloc(int size) { void *addr; size = ao_lisp_mem_round(size); - if (ao_lisp_top + size > AO_LISP_POOL) { +#ifdef DBG_COLLECT_ALWAYS + ao_lisp_collect(); +#endif + if (ao_lisp_top + size > AO_LISP_POOL_CUR) { +#ifdef DBG_POOL + if (AO_LISP_POOL_CUR < AO_LISP_POOL) { + AO_LISP_POOL_CUR += AO_LISP_POOL / 8; + ao_lisp_poison(); + } else +#endif ao_lisp_collect(); +#ifdef DBG_POOL + { + int i; + + for (i = ao_lisp_top; i < AO_LISP_POOL; i += 4) { + uint32_t *p = (uint32_t *) &ao_lisp_pool[i]; + *p = 0xbeefbeef; + } + } +#endif + if (ao_lisp_top + size > AO_LISP_POOL) { ao_lisp_exception |= AO_LISP_OOM; return NULL; @@ -374,6 +479,12 @@ ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) return 0; } +int +ao_lisp_root_poly_add(ao_poly *p) +{ + return ao_lisp_root_add(NULL, p); +} + void ao_lisp_root_clear(void *addr) { diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index e9367553..7f02505d 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -14,6 +14,12 @@ #include "ao_lisp.h" +#if 0 +#define DBG(...) printf (__VA_ARGS__) +#else +#define DBG(...) +#endif + static void (*const ao_lisp_print_funcs[AO_LISP_NUM_TYPE])(ao_poly) = { [AO_LISP_CONS] = ao_lisp_cons_print, [AO_LISP_STRING] = ao_lisp_string_print, @@ -33,30 +39,52 @@ ao_lisp_poly_print(ao_poly p) static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_CONS] = &ao_lisp_cons_type, + [AO_LISP_INT] = NULL, [AO_LISP_STRING] = &ao_lisp_string_type, + [AO_LISP_OTHER] = (void *) 0x1, [AO_LISP_ATOM] = &ao_lisp_atom_type, [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, + [AO_LISP_FRAME] = &ao_lisp_frame_type, }; -void +int ao_lisp_poly_mark(ao_poly p) { 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)); + return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); + return 1; } -ao_poly -ao_lisp_poly_move(ao_poly p) +int +ao_lisp_poly_move(ao_poly *ref) { - uint8_t type = p & AO_LISP_TYPE_MASK; + uint8_t type; + ao_poly p = *ref; const struct ao_lisp_type *lisp_type; + int ret; + void *addr; + + if (!p) + return 1; + type = p & AO_LISP_TYPE_MASK; if (type == AO_LISP_OTHER) type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); + if (type >= AO_LISP_NUM_TYPE) + abort(); + 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; + if (!lisp_type) + return 1; + addr = ao_lisp_ref(p); + ret = ao_lisp_move(lisp_type, &addr); + if (addr != ao_lisp_ref(p)) { + ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); + DBG("poly %d moved %04x -> %04x\n", + type, p, np); + *ref = np; + } + return ret; } -- cgit v1.2.3 From d8cf97fe22acefab40d7bb321138e46d4483fef7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 5 Nov 2016 17:53:15 -0700 Subject: altos/lisp: more GC issues. add patom Use global ao_lisp_stack instead of local stack so that gc moves of that item work. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lambdakey.c | 28 ------ src/lambdakey-v1.0/ao_pins.h | 3 +- src/lisp/ao_lisp.h | 12 ++- src/lisp/ao_lisp_builtin.c | 13 +++ src/lisp/ao_lisp_cons.c | 11 +++ src/lisp/ao_lisp_eval.c | 197 +++++++++++++++++++++++++------------- src/lisp/ao_lisp_make_const.c | 1 + src/lisp/ao_lisp_mem.c | 11 ++- src/lisp/ao_lisp_prim.c | 61 +++++++++--- src/lisp/ao_lisp_string.c | 10 ++ src/nucleao-32/ao_pins.h | 3 +- 11 files changed, 237 insertions(+), 113 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 6ac78717..8353d811 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -15,39 +15,11 @@ #include #include -static uint16_t blink_delay, blink_running; - -static void blink(void) { - blink_running = 1; - while (blink_delay) { - ao_led_on(AO_LED_RED); - ao_delay(blink_delay); - ao_led_off(AO_LED_RED); - ao_delay(blink_delay); - } - blink_running = 0; - ao_wakeup(&blink_running); - ao_exit(); -} - -struct ao_task blink_task; - -static void blink_cmd() { - ao_cmd_decimal(); - blink_delay = ao_cmd_lex_i; - if (blink_delay && !blink_running) - ao_add_task(&blink_task, blink, "blink"); - if (!blink_delay) - while (blink_running) - ao_sleep(&blink_running); -} - static void lisp_cmd() { ao_lisp_read_eval_print(); } static const struct ao_cmds blink_cmds[] = { - { blink_cmd, "b \0Blink the green LED" }, { lisp_cmd, "l\0Run lisp interpreter" }, { 0, 0 } }; diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index e379ed12..4da638b9 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -25,7 +25,8 @@ #define AO_LED_RED (1 << LED_PIN_RED) #define AO_LED_PANIC AO_LED_RED #define AO_CMD_LEN 128 -#define AO_LISP_POOL 2048 +#define AO_LISP_POOL 1536 +#define AO_STACK_SIZE 2048 #define LEDS_AVAILABLE (AO_LED_RED) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 27174e13..0d179942 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -173,6 +173,7 @@ enum ao_lisp_builtin_id { builtin_setq, builtin_cond, builtin_print, + builtin_patom, builtin_plus, builtin_minus, builtin_times, @@ -331,6 +332,9 @@ ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); void ao_lisp_cons_print(ao_poly); +void +ao_lisp_cons_patom(ao_poly); + /* string */ extern const struct ao_lisp_type ao_lisp_string_type; @@ -346,6 +350,9 @@ ao_lisp_string_cat(char *a, char *b); void ao_lisp_string_print(ao_poly s); +void +ao_lisp_string_patom(ao_poly s); + /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; @@ -370,9 +377,12 @@ void ao_lisp_int_print(ao_poly i); /* prim */ -ao_poly +void ao_lisp_poly_print(ao_poly p); +void +ao_lisp_poly_patom(ao_poly p); + int ao_lisp_poly_mark(ao_poly p); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 0ad1f464..49b6c37d 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -179,6 +179,18 @@ ao_lisp_print(struct ao_lisp_cons *cons) return val; } +ao_poly +ao_lisp_patom(struct ao_lisp_cons *cons) +{ + ao_poly val = AO_LISP_NIL; + while (cons) { + val = cons->car; + ao_lisp_poly_patom(val); + cons = ao_lisp_poly_cons(cons->cdr); + } + return val; +} + ao_poly ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) { @@ -376,6 +388,7 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_setq] = ao_lisp_setq, [builtin_cond] = ao_lisp_cond, [builtin_print] = ao_lisp_print, + [builtin_patom] = ao_lisp_patom, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, [builtin_times] = ao_lisp_times, diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 4929b91c..7d3ca68d 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -83,3 +83,14 @@ ao_lisp_cons_print(ao_poly c) } printf(")"); } + +void +ao_lisp_cons_patom(ao_poly c) +{ + struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); + + while (cons) { + ao_lisp_poly_patom(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } +} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 0de3f190..e3d653b9 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -15,12 +15,13 @@ #include "ao_lisp.h" #if 0 +#define DBG_CODE 1 static int stack_depth; #define DBG_INDENT() do { int _s; for(_s = 0; _s < stack_depth; _s++) printf(" "); } while(0) #define DBG_IN() (++stack_depth) #define DBG_OUT() (--stack_depth) #define DBG(...) printf(__VA_ARGS__) -#define DBGI(...) do { DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBGI(...) do { DBG_INDENT(); DBG("%4d: ", __LINE__); DBG(__VA_ARGS__); } while (0) #define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_print(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) @@ -90,6 +91,29 @@ stack_mark(void *addr) static const struct ao_lisp_type ao_lisp_stack_type; +#if DBG_CODE +static void +stack_validate_tail(struct ao_lisp_stack *stack) +{ + struct ao_lisp_cons *head = ao_lisp_poly_cons(stack->formals); + struct ao_lisp_cons *tail = ao_lisp_poly_cons(stack->formals_tail); + struct ao_lisp_cons *cons; + for (cons = head; cons && cons->cdr && cons != tail; cons = ao_lisp_poly_cons(cons->cdr)) + ; + if (cons != tail || (tail && tail->cdr)) { + if (!tail) { + printf("tail null\n"); + } else { + printf("tail validate fail head %d actual %d recorded %d\n", + OFFSET(head), OFFSET(cons), OFFSET(tail)); + abort(); + } + } +} +#else +#define stack_validate_tail(s) +#endif + static void stack_move(void *addr) { @@ -106,7 +130,8 @@ stack_move(void *addr) ret = ao_lisp_move(&ao_lisp_stack_type, &prev); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); - if (ret); + stack_validate_tail(stack); + if (ret) break; stack = ao_lisp_poly_stack(stack->prev); } @@ -122,6 +147,19 @@ static struct ao_lisp_stack *ao_lisp_stack; static ao_poly ao_lisp_v; static uint8_t been_here; +#if DBG_CODE +static void +stack_validate_tails(void) +{ + struct ao_lisp_stack *stack; + + for (stack = ao_lisp_stack; stack; stack = ao_lisp_poly_stack(stack->prev)) + stack_validate_tail(stack); +} +#else +#define stack_validate_tails(s) +#endif + ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -139,27 +177,35 @@ ao_lisp_stack_reset(struct ao_lisp_stack *stack) stack->formals = AO_LISP_NIL; stack->formals_tail = AO_LISP_NIL; stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack_validate_tails(); } -struct ao_lisp_stack * +int ao_lisp_stack_push(void) { + stack_validate_tails(); + if (ao_lisp_stack) { + DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); + DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + } + DBGI("stack push\n"); + DBG_IN(); struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) - return NULL; + return 0; stack->prev = ao_lisp_stack_poly(ao_lisp_stack); ao_lisp_stack = stack; ao_lisp_stack_reset(stack); - DBGI("stack push\n"); - DBG_IN(); - return stack; + stack_validate_tails(); + return 1; } -struct ao_lisp_stack * +void ao_lisp_stack_pop(void) { if (!ao_lisp_stack) - return NULL; + return; + stack_validate_tails(); DBG_OUT(); DBGI("stack pop\n"); ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); @@ -167,12 +213,16 @@ ao_lisp_stack_pop(void) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else ao_lisp_frame_current = NULL; - return ao_lisp_stack; + if (ao_lisp_stack) { + DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); + DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + } } static void ao_lisp_stack_clear(void) { + stack_validate_tails(); ao_lisp_stack = NULL; ao_lisp_frame_current = NULL; } @@ -285,7 +335,6 @@ ao_lisp_lambda(struct ao_lisp_cons *cons) ao_poly ao_lisp_eval(ao_poly _v) { - struct ao_lisp_stack *stack; ao_poly formal; ao_lisp_v = _v; @@ -295,45 +344,50 @@ ao_lisp_eval(ao_poly _v) ao_lisp_root_poly_add(&ao_lisp_v); } - stack = ao_lisp_stack_push(); + if (!ao_lisp_stack_push()) + goto bail; for (;;) { if (ao_lisp_exception) - return AO_LISP_NIL; - switch (stack->state) { + goto bail; + switch (ao_lisp_stack->state) { case eval_sexpr: DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_CONS: if (ao_lisp_v == AO_LISP_NIL) { - stack->state = eval_exec; + ao_lisp_stack->state = eval_exec; break; } - stack->actuals = ao_lisp_v; - stack->state = eval_formal; - stack = ao_lisp_stack_push(); + ao_lisp_stack->actuals = ao_lisp_v; + DBGI("actuals now "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_stack->state = eval_formal; + if (!ao_lisp_stack_push()) + goto bail; ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + stack_validate_tails(); break; case AO_LISP_ATOM: ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); /* fall through */ case AO_LISP_INT: case AO_LISP_STRING: - stack->state = eval_val; + case AO_LISP_BUILTIN: + ao_lisp_stack->state = eval_val; break; } break; case eval_val: DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - stack = ao_lisp_stack_pop(); - if (!stack) + ao_lisp_stack_pop(); + if (!ao_lisp_stack) return ao_lisp_v; - DBGI("..state %d\n", stack->state); + DBGI("..state %d\n", ao_lisp_stack->state); break; case eval_formal: /* Check what kind of function we've got */ - if (!stack->formals) { + if (!ao_lisp_stack->formals) { switch (func_type(ao_lisp_v)) { case AO_LISP_LAMBDA: case _ao_lisp_atom_lambda: @@ -343,99 +397,108 @@ ao_lisp_eval(ao_poly _v) break; case AO_LISP_MACRO: case _ao_lisp_atom_macro: - stack->macro = 1; + ao_lisp_stack->macro = 1; case AO_LISP_NLAMBDA: case _ao_lisp_atom_nlambda: DBGI(".. nlambda or macro\n"); - stack->formals = stack->actuals; - stack->state = eval_exec_direct; + ao_lisp_stack->formals = ao_lisp_stack->actuals; + ao_lisp_stack->formals_tail = AO_LISP_NIL; + ao_lisp_stack->state = eval_exec_direct; + stack_validate_tails(); break; } - if (stack->state == eval_exec_direct) + if (ao_lisp_stack->state == eval_exec_direct) break; } + DBGI("add formal "); DBG_POLY(ao_lisp_v); DBG("\n"); + stack_validate_tails(); formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); - if (!formal) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } + stack_validate_tails(); + if (!formal) + goto bail; - if (stack->formals_tail) - ao_lisp_poly_cons(stack->formals_tail)->cdr = formal; + if (ao_lisp_stack->formals_tail) + ao_lisp_poly_cons(ao_lisp_stack->formals_tail)->cdr = formal; else - stack->formals = formal; - stack->formals_tail = formal; + ao_lisp_stack->formals = formal; + ao_lisp_stack->formals_tail = formal; - DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n"); + DBGI("formals now "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->cdr; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - stack->state = eval_sexpr; + stack_validate_tails(); + ao_lisp_stack->state = eval_sexpr; break; case eval_exec: - if (!stack->formals) { + if (!ao_lisp_stack->formals) { ao_lisp_v = AO_LISP_NIL; - stack->state = eval_val; + ao_lisp_stack->state = eval_val; break; } - ao_lisp_v = ao_lisp_poly_cons(stack->formals)->car; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->formals)->car; case eval_exec_direct: - DBGI("exec: macro %d ", stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n"); + DBGI("exec: macro %d ", ao_lisp_stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(ao_lisp_stack->formals); DBG ("\n"); if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); - struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr); + stack_validate_tails(); + struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); + stack_validate_tails(); + struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->formals)->cdr); DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n"); - if (stack->macro) - stack->state = eval_sexpr; + stack_validate_tails(); + if (ao_lisp_stack->macro) + ao_lisp_stack->state = eval_sexpr; else - stack->state = eval_val; - stack->macro = 0; + ao_lisp_stack->state = eval_val; + ao_lisp_stack->macro = 0; + ao_lisp_stack->actuals = ao_lisp_stack->formals = ao_lisp_stack->formals_tail = AO_LISP_NIL; ao_lisp_v = ao_lisp_func(b) (f); DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n"); - if (ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } + if (ao_lisp_exception) + goto bail; break; } else { - ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals)); - ao_lisp_stack_reset(stack); + ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(ao_lisp_stack->formals)); + ao_lisp_stack_reset(ao_lisp_stack); } break; case eval_cond: - DBGI("cond: "); DBG_POLY(stack->actuals); DBG("\n"); - if (!stack->actuals) { + DBGI("cond: "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + if (!ao_lisp_stack->actuals) { ao_lisp_v = AO_LISP_NIL; - stack->state = eval_val; + ao_lisp_stack->state = eval_val; } else { - ao_lisp_v = ao_lisp_poly_cons(stack->actuals)->car; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->car; if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); goto bail; } ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - stack->state = eval_cond_test; - stack = ao_lisp_stack_push(); - stack->state = eval_sexpr; + ao_lisp_stack->state = eval_cond_test; + stack_validate_tails(); + ao_lisp_stack_push(); + stack_validate_tails(); + ao_lisp_stack->state = eval_sexpr; } break; case eval_cond_test: - DBGI("cond_test "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); if (ao_lisp_v) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(stack->actuals)->car); + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->actuals)->car); struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); if (c) { ao_lisp_v = c->car; - stack->state = eval_sexpr; + ao_lisp_stack->state = eval_sexpr; } else { - stack->state = eval_val; + ao_lisp_stack->state = eval_val; } } else { - stack->actuals = ao_lisp_poly_cons(stack->actuals)->cdr; - stack->state = eval_cond; + ao_lisp_stack->actuals = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; + DBGI("actuals now "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + ao_lisp_stack->state = eval_cond; } break; } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 9768dc22..f2e3cea1 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -41,6 +41,7 @@ struct builtin_func funcs[] = { "setq", AO_LISP_MACRO, builtin_setq, "cond", AO_LISP_NLAMBDA,builtin_cond, "print", AO_LISP_LEXPR, builtin_print, + "patom", AO_LISP_LEXPR, builtin_patom, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, "*", AO_LISP_LEXPR, builtin_times, diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 9e716da9..6e656454 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -36,6 +36,7 @@ uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); #endif #if 0 +#define DBG_INCLUDE #define DBG_DUMP 0 #define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) #define DBG(...) printf(__VA_ARGS__) @@ -179,15 +180,17 @@ move_object(void) DBG_DO(void *addr = *ao_lisp_root[i].addr); DBG_MOVE("root %d\n", DBG_OFFSET(addr)); if (!ao_lisp_move(ao_lisp_root[i].type, - ao_lisp_root[i].addr)) + ao_lisp_root[i].addr)) { DBG_MOVE("root moves from %p to %p\n", addr, *ao_lisp_root[i].addr); + } } else { DBG_DO(ao_poly p = *(ao_poly *) ao_lisp_root[i].addr); - if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr)) + if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr)) { DBG_MOVE("root poly move from %04x to %04x\n", p, *(ao_poly *) ao_lisp_root[i].addr); + } } } DBG_MOVE_OUT(); @@ -338,7 +341,7 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) int size = type->size(addr); if (!addr) - return NULL; + return 1; #ifndef AO_LISP_MAKE_CONST if (AO_LISP_IS_CONST(addr)) @@ -370,7 +373,7 @@ ao_lisp_move_memory(void **ref, int size) { void *addr = *ref; if (!addr) - return NULL; + return 1; DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); DBG_MOVE_IN(); diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 7f02505d..82386a83 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -20,21 +20,60 @@ #define DBG(...) #endif -static void (*const ao_lisp_print_funcs[AO_LISP_NUM_TYPE])(ao_poly) = { - [AO_LISP_CONS] = ao_lisp_cons_print, - [AO_LISP_STRING] = ao_lisp_string_print, - [AO_LISP_INT] = ao_lisp_int_print, - [AO_LISP_ATOM] = ao_lisp_atom_print, - [AO_LISP_BUILTIN] = ao_lisp_builtin_print +struct ao_lisp_funcs { + void (*print)(ao_poly); + void (*patom)(ao_poly); }; -ao_poly +static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = { + .print = ao_lisp_cons_print, + .patom = ao_lisp_cons_patom, + }, + [AO_LISP_STRING] = { + .print = ao_lisp_string_print, + .patom = ao_lisp_string_patom, + }, + [AO_LISP_INT] = { + .print = ao_lisp_int_print, + .patom = ao_lisp_int_print, + }, + [AO_LISP_ATOM] = { + .print = ao_lisp_atom_print, + .patom = ao_lisp_atom_print, + }, + [AO_LISP_BUILTIN] = { + .print = ao_lisp_builtin_print, + .patom = ao_lisp_builtin_print, + } +}; + +static const struct ao_lisp_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_lisp_poly_type(p); + + if (type < AO_LISP_NUM_TYPE) + return &ao_lisp_funcs[type]; + return NULL; +} + +void ao_lisp_poly_print(ao_poly p) { - void (*print)(ao_poly) = ao_lisp_print_funcs[ao_lisp_poly_type(p)]; - if (print) - print(p); - return p; + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->print) + f->print(p); +} + +void +ao_lisp_poly_patom(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->patom) + f->patom(p); } static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 39c3dc81..0064064c 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -99,3 +99,13 @@ ao_lisp_string_print(ao_poly p) } putchar('"'); } + +void +ao_lisp_string_patom(ao_poly p) +{ + char *s = ao_lisp_poly_string(p); + char c; + + while ((c = *s++)) + putchar(c); +} diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index 65de89ed..092d347c 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -25,7 +25,8 @@ #define AO_LED_GREEN (1 << LED_PIN_GREEN) #define AO_LED_PANIC AO_LED_GREEN #define AO_CMD_LEN 128 -#define AO_LISP_POOL 2048 +#define AO_LISP_POOL 1024 +#define AO_STACK_SIZE 1536 #define LEDS_AVAILABLE (AO_LED_GREEN) -- cgit v1.2.3 From 6e5c1308ce33a864095eae02e7db18b0e043ab6e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 6 Nov 2016 10:53:46 -0800 Subject: altos/lisp: convert GC to non-recursive Use a boolean array to note cons cells which would otherwise recurse, then loop until that array is empty. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 8 ++- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_cons.c | 15 +++-- src/lisp/ao_lisp_eval.c | 14 ++--- src/lisp/ao_lisp_frame.c | 19 +++++-- src/lisp/ao_lisp_mem.c | 140 ++++++++++++++++++++++++++++++++++++++++++++--- src/lisp/ao_lisp_prim.c | 51 ----------------- 7 files changed, 170 insertions(+), 79 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 0d179942..17f1e0f5 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -221,6 +221,10 @@ ao_lisp_mem_round(int size) #define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) +static inline int ao_lisp_poly_base_type(ao_poly poly) { + return poly & AO_LISP_TYPE_MASK; +} + static inline int ao_lisp_poly_type(ao_poly poly) { int type = poly & AO_LISP_TYPE_MASK; if (type == AO_LISP_OTHER) @@ -384,11 +388,11 @@ void ao_lisp_poly_patom(ao_poly p); int -ao_lisp_poly_mark(ao_poly p); +ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); /* returns 1 if the object has already been moved */ int -ao_lisp_poly_move(ao_poly *p); +ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); /* eval */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 5f1bcda0..41ba97f5 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -48,7 +48,7 @@ static void atom_move(void *addr) struct ao_lisp_atom *atom = addr; for (;;) { - if (ao_lisp_poly_move(&atom->next)) + if (ao_lisp_poly_move(&atom->next, 0)) break; atom = ao_lisp_poly_atom(atom->next); } diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 7d3ca68d..855079b8 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -21,7 +21,7 @@ static void cons_mark(void *addr) struct ao_lisp_cons *cons = addr; for (;;) { - ao_lisp_poly_mark(cons->car); + ao_lisp_poly_mark(cons->car, 1); cons = ao_lisp_poly_cons(cons->cdr); if (!cons) break; @@ -44,10 +44,17 @@ static void cons_move(void *addr) return; for (;;) { - (void) ao_lisp_poly_move(&cons->car); - if (ao_lisp_poly_move(&cons->cdr)) + struct ao_lisp_cons *cdr; + int ret; + + (void) ao_lisp_poly_move(&cons->car, 1); + cdr = ao_lisp_poly_cons(cons->cdr); + ret = ao_lisp_move_memory((void **) &cdr, sizeof (struct ao_lisp_cons)); + if (cdr != ao_lisp_poly_cons(cons->cdr)) + cons->cdr = ao_lisp_cons_poly(cdr); + if (ret) break; - cons = ao_lisp_poly_cons(cons->cdr); + cons = cdr; } } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index e3d653b9..a5c74250 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -79,10 +79,10 @@ stack_mark(void *addr) { struct ao_lisp_stack *stack = addr; for (;;) { - ao_lisp_poly_mark(stack->actuals); - ao_lisp_poly_mark(stack->formals); + ao_lisp_poly_mark(stack->actuals, 0); + ao_lisp_poly_mark(stack->formals, 0); /* no need to mark formals_tail */ - ao_lisp_poly_mark(stack->frame); + ao_lisp_poly_mark(stack->frame, 0); stack = ao_lisp_poly_stack(stack->prev); if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) break; @@ -122,10 +122,10 @@ stack_move(void *addr) while (stack) { void *prev; int ret; - (void) ao_lisp_poly_move(&stack->actuals); - (void) ao_lisp_poly_move(&stack->formals); - (void) ao_lisp_poly_move(&stack->formals_tail); - (void) ao_lisp_poly_move(&stack->frame); + (void) ao_lisp_poly_move(&stack->actuals, 0); + (void) ao_lisp_poly_move(&stack->formals, 0); + (void) ao_lisp_poly_move(&stack->formals_tail, 0); + (void) ao_lisp_poly_move(&stack->frame, 0); prev = ao_lisp_poly_stack(stack->prev); ret = ao_lisp_move(&ao_lisp_stack_type, &prev); if (prev != ao_lisp_poly_stack(stack->prev)) diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 8bf98571..8791c4de 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -48,7 +48,7 @@ frame_mark(void *addr) for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; - ao_lisp_poly_mark(v->val); + ao_lisp_poly_mark(v->val, 0); 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); @@ -69,19 +69,28 @@ frame_move(void *addr) int f; for (;;) { + struct ao_lisp_frame *next; + int ret; + DBG("frame move %p\n", frame); if (!AO_LISP_IS_POOL(frame)) break; for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; - ao_lisp_poly_move(&v->atom); + ao_lisp_poly_move(&v->atom, 0); DBG("moved atom %s\n", ao_lisp_poly_atom(v->atom)->name); - ao_lisp_poly_move(&v->val); + ao_lisp_poly_move(&v->val, 0); } - if (ao_lisp_poly_move(&frame->next)) + next = ao_lisp_poly_frame(frame->next); + ret = 1; + if (next) + ret = ao_lisp_move_memory((void **) &next, frame_size(next)); + if (next != ao_lisp_poly_frame(frame->next)) + frame->next = ao_lisp_frame_poly(next); + if (ret) break; - frame = ao_lisp_poly_frame(frame->next); + frame = next; } } diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 6e656454..c11ec25d 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -41,7 +41,7 @@ uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); #define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) #define DBG(...) printf(__VA_ARGS__) #define DBG_DO(a) a -static int move_dump; +static int move_dump = 1; 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) @@ -68,8 +68,10 @@ struct ao_lisp_root { static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; static uint8_t ao_lisp_busy[AO_LISP_POOL / 32]; - static uint8_t ao_lisp_moving[AO_LISP_POOL / 32]; +static uint8_t ao_lisp_cons[AO_LISP_POOL / 32]; +static uint8_t ao_lisp_cons_last[AO_LISP_POOL / 32]; +static uint8_t ao_lisp_cons_noted; uint16_t ao_lisp_top; @@ -161,6 +163,17 @@ busy_object(uint8_t *tag, void *addr) { return 0; } +static void +note_cons(void *addr) +{ + DBG_MOVE("note cons %d\n", DBG_OFFSET(addr)); + if (AO_LISP_IS_POOL(addr)) { + ao_lisp_cons_noted = 1; + mark(ao_lisp_cons, (uint8_t *) addr - ao_lisp_pool); + } +} + + static void *move_old, *move_new; static int move_size; @@ -173,11 +186,15 @@ move_object(void) 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)); + memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_ROOT; i++) { if (!ao_lisp_root[i].addr) continue; if (ao_lisp_root[i].type) { - DBG_DO(void *addr = *ao_lisp_root[i].addr); + void *addr = *ao_lisp_root[i].addr; + if (!addr) + continue; DBG_MOVE("root %d\n", DBG_OFFSET(addr)); if (!ao_lisp_move(ao_lisp_root[i].type, ao_lisp_root[i].addr)) { @@ -186,13 +203,30 @@ move_object(void) *ao_lisp_root[i].addr); } } else { - DBG_DO(ao_poly p = *(ao_poly *) ao_lisp_root[i].addr); - if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr)) { + ao_poly p = *(ao_poly *) ao_lisp_root[i].addr; + if (!p) + continue; + if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr, 0)) { DBG_MOVE("root poly move from %04x to %04x\n", p, *(ao_poly *) ao_lisp_root[i].addr); } } } + while (ao_lisp_cons_noted) { + memcpy(ao_lisp_cons_last, ao_lisp_cons, sizeof (ao_lisp_cons)); + memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + ao_lisp_cons_noted = 0; + for (i = 0; i < AO_LISP_POOL; i += 4) { + if (busy(ao_lisp_cons_last, i)) { + void *addr = ao_lisp_pool + i; + DBG_MOVE("cons %d\n", DBG_OFFSET(addr)); + if (!ao_lisp_move(&ao_lisp_cons_type, &addr)) { + DBG_MOVE("cons moves from %p to %p\n", + ao_lisp_pool + i, addr); + } + } + } + } DBG_MOVE_OUT(); DBG_MOVE("move done\n"); } @@ -220,25 +254,50 @@ dump_busy(void) #define DUMP_BUSY() #endif +static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = &ao_lisp_cons_type, + [AO_LISP_INT] = NULL, + [AO_LISP_STRING] = &ao_lisp_string_type, + [AO_LISP_OTHER] = (void *) 0x1, + [AO_LISP_ATOM] = &ao_lisp_atom_type, + [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, + [AO_LISP_FRAME] = &ao_lisp_frame_type, +}; + + static void ao_lisp_mark_busy(void) { int i; memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); + memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + ao_lisp_cons_noted = 0; DBG("mark\n"); for (i = 0; i < AO_LISP_ROOT; i++) { if (ao_lisp_root[i].type) { void **a = ao_lisp_root[i].addr, *v; if (a && (v = *a)) { - DBG("root %p\n", v); + DBG("root %d\n", DBG_OFFSET(v)); ao_lisp_mark(ao_lisp_root[i].type, v); } } else { ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; if (a && (p = *a)) { - DBG("root %04x\n", p); - ao_lisp_poly_mark(p); + DBG("root 0x%04x\n", p); + ao_lisp_poly_mark(p, 0); + } + } + } + while (ao_lisp_cons_noted) { + memcpy(ao_lisp_cons_last, ao_lisp_cons, sizeof (ao_lisp_cons)); + memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + ao_lisp_cons_noted = 0; + for (i = 0; i < AO_LISP_POOL; i += 4) { + if (busy(ao_lisp_cons_last, i)) { + void *v = ao_lisp_pool + i; + DBG("cons %d\n", DBG_OFFSET(v)); + ao_lisp_mark(&ao_lisp_cons_type, v); } } } @@ -274,6 +333,10 @@ ao_lisp_collect(void) abort(); clear_object(ao_lisp_busy, move_old, move_size); mark_object(ao_lisp_busy, move_new, move_size); + if (busy_object(ao_lisp_cons, move_old)) { + clear_object(ao_lisp_cons, move_old, move_size); + mark_object(ao_lisp_cons, move_new, move_size); + } i += move_size; top += move_size; DUMP_BUSY(); @@ -296,6 +359,24 @@ ao_lisp_mark(const struct ao_lisp_type *type, void *addr) return 0; } +int +ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) +{ + uint8_t type = ao_lisp_poly_type(p); + + if (!p) + return 1; + if (type == AO_LISP_CONS && do_note_cons) { + note_cons(ao_lisp_ref(p)); + return 0; + } else { + const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; + if (lisp_type) + return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); + return 1; + } +} + int ao_lisp_mark_memory(void *addr, int size) { @@ -348,7 +429,7 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) return 1; #endif DBG_MOVE("object %d\n", DBG_OFFSET(addr)); - if (a < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= a) + if (!AO_LISP_IS_POOL(a)) abort(); DBG_MOVE_IN(); addr = check_move(addr, size); @@ -389,6 +470,47 @@ ao_lisp_move_memory(void **ref, int size) return 0; } +int +ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ + uint8_t type; + ao_poly p = *ref; + const struct ao_lisp_type *lisp_type; + int ret; + void *addr; + + if (!p) + return 1; + + type = ao_lisp_poly_base_type(p); + addr = ao_lisp_ref(p); + if (type == AO_LISP_CONS && do_note_cons) { + note_cons(addr); + addr = check_move(addr, sizeof (struct ao_lisp_cons)); + ret = 1; + } else { + + if (type == AO_LISP_OTHER) + type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); + + if (type >= AO_LISP_NUM_TYPE) + abort(); + + lisp_type = ao_lisp_types[type]; + if (!lisp_type) + return 1; + ret = ao_lisp_move(lisp_type, &addr); + } + + if (addr != ao_lisp_ref(p)) { + ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); + DBG("poly %d moved %04x -> %04x\n", + type, p, np); + *ref = np; + } + return ret; +} + #ifdef DBG_POOL static int AO_LISP_POOL_CUR = AO_LISP_POOL / 8; diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 82386a83..3c081ee8 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -76,54 +76,3 @@ ao_lisp_poly_patom(ao_poly p) f->patom(p); } -static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = &ao_lisp_cons_type, - [AO_LISP_INT] = NULL, - [AO_LISP_STRING] = &ao_lisp_string_type, - [AO_LISP_OTHER] = (void *) 0x1, - [AO_LISP_ATOM] = &ao_lisp_atom_type, - [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, - [AO_LISP_FRAME] = &ao_lisp_frame_type, -}; - -int -ao_lisp_poly_mark(ao_poly p) -{ - const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; - if (lisp_type) - return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); - return 1; -} - -int -ao_lisp_poly_move(ao_poly *ref) -{ - uint8_t type; - ao_poly p = *ref; - const struct ao_lisp_type *lisp_type; - int ret; - void *addr; - - if (!p) - return 1; - - type = p & AO_LISP_TYPE_MASK; - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); - - if (type >= AO_LISP_NUM_TYPE) - abort(); - - lisp_type = ao_lisp_types[type]; - if (!lisp_type) - return 1; - addr = ao_lisp_ref(p); - ret = ao_lisp_move(lisp_type, &addr); - if (addr != ao_lisp_ref(p)) { - ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); - DBG("poly %d moved %04x -> %04x\n", - type, p, np); - *ref = np; - } - return ret; -} -- cgit v1.2.3 From 794718abc62f4610495fe2bd535a2b67bc46573c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 09:14:50 -0800 Subject: altos/lisp: working on lexical scoping Not working yet Signed-off-by: Keith Packard --- src/lisp/Makefile | 4 +- src/lisp/ao_lisp.h | 147 ++++++++- src/lisp/ao_lisp_atom.c | 4 +- src/lisp/ao_lisp_builtin.c | 96 +++++- src/lisp/ao_lisp_const.lisp | 136 +++++++- src/lisp/ao_lisp_error.c | 81 +++++ src/lisp/ao_lisp_eval.c | 730 +++++++++++++++++++++--------------------- src/lisp/ao_lisp_frame.c | 21 ++ src/lisp/ao_lisp_make_const.c | 85 +++-- src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_prim.c | 10 +- src/test/Makefile | 2 +- 12 files changed, 876 insertions(+), 441 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index be19b432..f7edbe41 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -18,7 +18,9 @@ SRCS=\ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ - ao_lisp_error.c + ao_lisp_lambda.c \ + ao_lisp_eval.c \ + ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 17f1e0f5..6a35d8ce 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -42,7 +42,9 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_car _atom("car") #define _ao_lisp_atom_cdr _atom("cdr") #define _ao_lisp_atom_cons _atom("cons") +#define _ao_lisp_atom_last _atom("last") #define _ao_lisp_atom_cond _atom("cond") +#define _ao_lisp_atom_lambda _atom("lambda") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -66,7 +68,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #define AO_LISP_ATOM 4 #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 -#define AO_LISP_NUM_TYPE 7 +#define AO_LISP_LAMBDA 7 +#define AO_LISP_NUM_TYPE 8 #define AO_LISP_NIL 0 @@ -114,8 +117,8 @@ ao_lisp_poly(const void *addr, ao_poly type) { } struct ao_lisp_type { - void (*mark)(void *addr); int (*size)(void *addr); + void (*mark)(void *addr); void (*move)(void *addr); }; @@ -153,10 +156,47 @@ 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 -#define AO_LISP_LEXPR 3 +struct ao_lisp_stack { + ao_poly prev; + uint8_t state; + uint8_t macro; + ao_poly sexprs; + ao_poly values; + ao_poly values_tail; + ao_poly frame; + ao_poly macro_frame; + ao_poly list; +}; + +enum eval_state { + eval_sexpr, + eval_val, + eval_formal, + eval_exec, + eval_lambda_done, + eval_cond, + eval_cond_test +}; + +static inline struct ao_lisp_stack * +ao_lisp_poly_stack(ao_poly p) +{ + return ao_lisp_ref(p); +} + +static inline ao_poly +ao_lisp_stack_poly(struct ao_lisp_stack *stack) +{ + return ao_lisp_poly(stack, AO_LISP_OTHER); +} + +extern struct ao_lisp_stack *ao_lisp_stack; +extern ao_poly ao_lisp_v; + +#define AO_LISP_FUNC_LAMBDA 0 +#define AO_LISP_FUNC_NLAMBDA 1 +#define AO_LISP_FUNC_MACRO 2 +#define AO_LISP_FUNC_LEXPR 3 struct ao_lisp_builtin { uint8_t type; @@ -165,9 +205,14 @@ struct ao_lisp_builtin { }; enum ao_lisp_builtin_id { + builtin_lambda, + builtin_lexpr, + builtin_nlambda, + builtin_macro, builtin_car, builtin_cdr, builtin_cons, + builtin_last, builtin_quote, builtin_set, builtin_setq, @@ -184,7 +229,7 @@ enum ao_lisp_builtin_id { builtin_greater, builtin_less_equal, builtin_greater_equal, - builtin_last + _builtin_last }; typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); @@ -197,6 +242,25 @@ ao_lisp_func(struct ao_lisp_builtin *b) return ao_lisp_builtins[b->func]; } +struct ao_lisp_lambda { + uint8_t type; + uint8_t args; + ao_poly code; + ao_poly frame; +}; + +static inline struct ao_lisp_lambda * +ao_lisp_poly_lambda(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) +{ + return ao_lisp_poly(lambda, AO_LISP_OTHER); +} + static inline void * ao_lisp_poly_other(ao_poly poly) { return ao_lisp_ref(poly); @@ -360,9 +424,9 @@ ao_lisp_string_patom(ao_poly s); /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; -extern struct ao_lisp_atom *ao_lisp_atoms; - -extern struct ao_lisp_frame *ao_lisp_frame_current; +extern struct ao_lisp_atom *ao_lisp_atoms; +extern struct ao_lisp_frame *ao_lisp_frame_global; +extern struct ao_lisp_frame *ao_lisp_frame_current; void ao_lisp_atom_print(ao_poly a); @@ -420,6 +484,9 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, ao_poly ao_lisp_arg(struct ao_lisp_cons *cons, int argc); +char * +ao_lisp_args_name(uint8_t args); + /* read */ ao_poly ao_lisp_read(void); @@ -440,9 +507,69 @@ ao_lisp_frame_new(int num); struct ao_lisp_frame * ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); +void +ao_lisp_frame_print(ao_poly p); + +/* lambda */ +extern const struct ao_lisp_type ao_lisp_lambda_type; + +struct ao_lisp_lambda * +ao_lisp_lambda_new(ao_poly cons); + +void +ao_lisp_lambda_print(ao_poly lambda); + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, + struct ao_lisp_cons *cons); + /* error */ +void +ao_lisp_stack_print(void); + ao_poly ao_lisp_error(int error, char *format, ...); +/* debugging macros */ + +#if DBG_EVAL +#define DBG_CODE 1 +int ao_lisp_stack_depth; +#define DBG_DO(a) a +#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf(" "); } while(0) +#define DBG_IN() (++ao_lisp_stack_depth) +#define DBG_OUT() (--ao_lisp_stack_depth) +#define DBG_RESET() (ao_lisp_stack_depth = 0) +#define DBG(...) printf(__VA_ARGS__) +#define DBGI(...) do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) +#define DBG_POLY(a) ao_lisp_poly_print(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) +#define DBG_STACK() ao_lisp_stack_print() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#endif + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 41ba97f5..d7cb1996 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -89,8 +89,8 @@ ao_lisp_atom_intern(char *name) return atom; } -static struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; +struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; static void ao_lisp_atom_init(void) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 49b6c37d..c38ba165 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -39,11 +39,71 @@ const struct ao_lisp_type ao_lisp_builtin_type = { .move = builtin_move }; +#ifdef AO_LISP_MAKE_CONST +char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + return "???"; +} +char *ao_lisp_args_name(uint8_t args) { + return "???"; +} +#else +static const ao_poly builtin_names[] = { + [builtin_lambda] = _ao_lisp_atom_lambda, + [builtin_lexpr] = _ao_lisp_atom_lexpr, + [builtin_nlambda] = _ao_lisp_atom_nlambda, + [builtin_macro] = _ao_lisp_atom_macro, + [builtin_car] = _ao_lisp_atom_car, + [builtin_cdr] = _ao_lisp_atom_cdr, + [builtin_cons] = _ao_lisp_atom_cons, + [builtin_last] = _ao_lisp_atom_last, + [builtin_quote] = _ao_lisp_atom_quote, + [builtin_set] = _ao_lisp_atom_set, + [builtin_setq] = _ao_lisp_atom_setq, + [builtin_cond] = _ao_lisp_atom_cond, + [builtin_print] = _ao_lisp_atom_print, + [builtin_patom] = _ao_lisp_atom_patom, + [builtin_plus] = _ao_lisp_atom_2b, + [builtin_minus] = _ao_lisp_atom_2d, + [builtin_times] = _ao_lisp_atom_2a, + [builtin_divide] = _ao_lisp_atom_2f, + [builtin_mod] = _ao_lisp_atom_25, + [builtin_equal] = _ao_lisp_atom_3d, + [builtin_less] = _ao_lisp_atom_3c, + [builtin_greater] = _ao_lisp_atom_3e, + [builtin_less_equal] = _ao_lisp_atom_3c3d, + [builtin_greater_equal] = _ao_lisp_atom_3e3d, +}; + +static char * +ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + if (0 <= b && b < _builtin_last) + return ao_lisp_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_lisp_args_atoms[] = { + [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, + [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr, + [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, + [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, +}; + +char * +ao_lisp_args_name(uint8_t args) +{ + if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) + return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; + return "(unknown)"; +} +#endif + void ao_lisp_builtin_print(ao_poly b) { - (void) b; - printf("[builtin]"); + struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); + printf("[builtin %s %s]", + ao_lisp_args_name(builtin->args), + ao_lisp_builtin_name(builtin->func)); } ao_poly @@ -116,6 +176,24 @@ ao_lisp_cons(struct ao_lisp_cons *cons) return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); } +ao_poly +ao_lisp_last(struct ao_lisp_cons *cons) +{ + ao_poly l; + if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + l = ao_lisp_arg(cons, 0); + while (l) { + struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + if (!list->cdr) + return list->car; + l = list->cdr; + } + return AO_LISP_NIL; +} + ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { @@ -151,15 +229,6 @@ ao_lisp_setq(struct ao_lisp_cons *cons) ao_poly ao_lisp_cond(struct ao_lisp_cons *cons) { - int argc; - struct ao_lisp_cons *arg; - - argc = 0; - for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) { - if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", - ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc); - } ao_lisp_set_cond(cons); return AO_LISP_NIL; } @@ -380,9 +449,14 @@ ao_lisp_greater_equal(struct ao_lisp_cons *cons) } ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_lambda] = ao_lisp_lambda, + [builtin_lexpr] = ao_lisp_lexpr, + [builtin_nlambda] = ao_lisp_nlambda, + [builtin_macro] = ao_lisp_macro, [builtin_car] = ao_lisp_car, [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, + [builtin_last] = ao_lisp_last, [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 5ca89bd4..621fefc4 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1,7 +1,129 @@ -cadr (lambda (l) (car (cdr l))) -caddr (lambda (l) (car (cdr (cdr l)))) -list (lexpr (l) l) -1+ (lambda (x) (+ x 1)) -1- (lambda (x) (- x 1)) -last (lambda (x) (cond ((cdr x) (last (cdr x))) ((car x)))) -prog* (lexpr (l) (last l)) + ; basic list accessors + + +(setq cadr (lambda (l) (car (cdr l)))) +(setq caddr (lambda (l) (car (cdr (cdr l))))) +(setq list (lexpr (l) l)) + + ; evaluate a list of sexprs + +(setq progn (lexpr (l) (last l))) + + ; simple math operators + +(setq 1+ (lambda (x) (+ x 1))) +(setq 1- (lambda (x) (- x 1))) + + ; define a variable without returning the value + +(set 'def (macro (def-param) + (list + 'progn + (list + 'set + (list + 'quote + (car def-param)) + (cadr def-param) + ) + (list + 'quote + (car def-param) + ) + ) + ) + ) + + ; define a set of local + ; variables and then evaluate + ; a list of sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (setq y (+ x 1)) y) + +(def let (macro (let-param) + ((lambda (vars exprs make-names make-exprs make-nils) + (progn + + ; + ; make the list of names in the let + ; + + (set 'make-names (lambda (vars) + (cond (vars + (cons (car (car vars)) + (make-names (cdr vars)))) + ) + ) + ) + ; + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + ; + (set 'make-exprs (lambda (vars exprs) + (progn + (cond (vars (cons + (list set + (list quote + (car (car vars)) + ) + (cadr (car vars)) + ) + (make-exprs (cdr vars) exprs) + ) + ) + (exprs) + ) + ) + ) + ) + (set 'exprs (make-exprs vars exprs)) + + ; + ; the parameters to the lambda is a list + ; of nils of the right length + ; + (set 'make-nils (lambda (vars) + (cond (vars (cons nil (make-nils (cdr vars)))) + ) + ) + ) + ; + ; build the lambda. + ; + (set 'last-let-value + (cons + (list + 'lambda + (make-names vars) + (cond ((cdr exprs) (cons 'progn exprs)) + ((car exprs)) + ) + ) + (make-nils vars) + ) + ) + ) + + ) + (car let-param) + (cdr let-param) + () + () + () + ) + ) + ) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index ea8111d9..cedc107c 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -15,6 +15,86 @@ #include "ao_lisp.h" #include +static void +ao_lisp_error_cons(char *name, struct ao_lisp_cons *cons) +{ + int first = 1; + printf("\t\t%s(", name); + if (cons) { + while (cons) { + if (!first) + printf("\t\t "); + else + first = 0; + ao_lisp_poly_print(cons->car); + printf("\n"); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf("\t\t )\n"); + } else + printf(")\n"); +} + +static void tabs(int indent) +{ + while (indent--) + printf("\t"); +} + +static void +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) +{ + int f; + + tabs(indent); + printf ("%s{", name); + if (frame) { + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + printf("\n"); + } + if (frame->next) + ao_lisp_error_frame(indent + 1, "next: ", ao_lisp_poly_frame(frame->next)); + } + tabs(indent); + printf(" }\n"); +} + +static const char *state_names[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", +}; + +void +ao_lisp_stack_print(void) +{ + struct ao_lisp_stack *s; + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + ao_lisp_error_frame(0, "Frame: ", ao_lisp_frame_current); + printf("Stack:\n"); + for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { + printf("\t[\n"); + printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\tstate: %s\n", state_names[s->state]); + printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); + ao_lisp_error_cons ("sexprs: ", ao_lisp_poly_cons(s->sexprs)); + ao_lisp_error_cons ("values: ", ao_lisp_poly_cons(s->values)); + ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); + ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); + printf("\t]\n"); + } +} + ao_poly ao_lisp_error(int error, char *format, ...) { @@ -25,5 +105,6 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); + ao_lisp_stack_print(); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index a5c74250..f4196219 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,60 +12,9 @@ * General Public License for more details. */ +#define DBG_EVAL 1 #include "ao_lisp.h" - -#if 0 -#define DBG_CODE 1 -static int stack_depth; -#define DBG_INDENT() do { int _s; for(_s = 0; _s < stack_depth; _s++) printf(" "); } while(0) -#define DBG_IN() (++stack_depth) -#define DBG_OUT() (--stack_depth) -#define DBG(...) printf(__VA_ARGS__) -#define DBGI(...) do { DBG_INDENT(); DBG("%4d: ", __LINE__); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_print(a) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#else -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#endif - -enum eval_state { - eval_sexpr, - eval_val, - eval_formal, - eval_exec, - eval_exec_direct, - eval_cond, - eval_cond_test -}; - -struct ao_lisp_stack { - ao_poly prev; - uint8_t state; - uint8_t macro; - ao_poly actuals; - ao_poly formals; - ao_poly formals_tail; - ao_poly frame; -}; - -static struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ - return ao_lisp_ref(p); -} - -static ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ - return ao_lisp_poly(stack, AO_LISP_OTHER); -} +#include static int stack_size(void *addr) @@ -79,10 +28,11 @@ stack_mark(void *addr) { struct ao_lisp_stack *stack = addr; for (;;) { - ao_lisp_poly_mark(stack->actuals, 0); - ao_lisp_poly_mark(stack->formals, 0); - /* no need to mark formals_tail */ + ao_lisp_poly_mark(stack->sexprs, 0); + ao_lisp_poly_mark(stack->values, 0); + /* no need to mark values_tail */ ao_lisp_poly_mark(stack->frame, 0); + ao_lisp_poly_mark(stack->macro_frame, 0); stack = ao_lisp_poly_stack(stack->prev); if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) break; @@ -91,29 +41,6 @@ stack_mark(void *addr) static const struct ao_lisp_type ao_lisp_stack_type; -#if DBG_CODE -static void -stack_validate_tail(struct ao_lisp_stack *stack) -{ - struct ao_lisp_cons *head = ao_lisp_poly_cons(stack->formals); - struct ao_lisp_cons *tail = ao_lisp_poly_cons(stack->formals_tail); - struct ao_lisp_cons *cons; - for (cons = head; cons && cons->cdr && cons != tail; cons = ao_lisp_poly_cons(cons->cdr)) - ; - if (cons != tail || (tail && tail->cdr)) { - if (!tail) { - printf("tail null\n"); - } else { - printf("tail validate fail head %d actual %d recorded %d\n", - OFFSET(head), OFFSET(cons), OFFSET(tail)); - abort(); - } - } -} -#else -#define stack_validate_tail(s) -#endif - static void stack_move(void *addr) { @@ -122,15 +49,15 @@ stack_move(void *addr) while (stack) { void *prev; int ret; - (void) ao_lisp_poly_move(&stack->actuals, 0); - (void) ao_lisp_poly_move(&stack->formals, 0); - (void) ao_lisp_poly_move(&stack->formals_tail, 0); + (void) ao_lisp_poly_move(&stack->sexprs, 0); + (void) ao_lisp_poly_move(&stack->values, 0); + (void) ao_lisp_poly_move(&stack->values_tail, 0); (void) ao_lisp_poly_move(&stack->frame, 0); + (void) ao_lisp_poly_move(&stack->macro_frame, 0); prev = ao_lisp_poly_stack(stack->prev); ret = ao_lisp_move(&ao_lisp_stack_type, &prev); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); - stack_validate_tail(stack); if (ret) break; stack = ao_lisp_poly_stack(stack->prev); @@ -143,199 +70,421 @@ static const struct ao_lisp_type ao_lisp_stack_type = { .move = stack_move }; -static struct ao_lisp_stack *ao_lisp_stack; -static ao_poly ao_lisp_v; -static uint8_t been_here; - -#if DBG_CODE -static void -stack_validate_tails(void) -{ - struct ao_lisp_stack *stack; - - for (stack = ao_lisp_stack; stack; stack = ao_lisp_poly_stack(stack->prev)) - stack_validate_tail(stack); -} -#else -#define stack_validate_tails(s) -#endif +struct ao_lisp_stack *ao_lisp_stack; +ao_poly ao_lisp_v; ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { ao_lisp_stack->state = eval_cond; - ao_lisp_stack->actuals = ao_lisp_cons_poly(c); + ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); return AO_LISP_NIL; } -void +static void ao_lisp_stack_reset(struct ao_lisp_stack *stack) { stack->state = eval_sexpr; stack->macro = 0; - stack->actuals = AO_LISP_NIL; - stack->formals = AO_LISP_NIL; - stack->formals_tail = AO_LISP_NIL; - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack_validate_tails(); + stack->sexprs = AO_LISP_NIL; + stack->values = AO_LISP_NIL; + stack->values_tail = AO_LISP_NIL; } -int -ao_lisp_stack_push(void) +static void +ao_lisp_frames_dump(void) { - stack_validate_tails(); - if (ao_lisp_stack) { - DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + struct ao_lisp_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + DBGI(".. macro frame: "); DBG_POLY(s->frame); DBG("\n"); } +} + +static int +ao_lisp_stack_push(void) +{ DBGI("stack push\n"); DBG_IN(); struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) return 0; stack->prev = ao_lisp_stack_poly(ao_lisp_stack); + stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack->list = AO_LISP_NIL; ao_lisp_stack = stack; ao_lisp_stack_reset(stack); - stack_validate_tails(); + ao_lisp_frames_dump(); return 1; } -void +static void ao_lisp_stack_pop(void) { if (!ao_lisp_stack) return; - stack_validate_tails(); + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); DBG_OUT(); DBGI("stack pop\n"); - ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_stack) { - DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - } + ao_lisp_frames_dump(); } static void ao_lisp_stack_clear(void) { - stack_validate_tails(); ao_lisp_stack = NULL; ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; } -static ao_poly +static int func_type(ao_poly func) { - struct ao_lisp_cons *cons; - struct ao_lisp_cons *args; - int f; - - DBGI("func type "); DBG_POLY(func); DBG("\n"); if (func == AO_LISP_NIL) return ao_lisp_error(AO_LISP_INVALID, "func is nil"); - if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func); - return b->args; - } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(func); - if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1)); - f = 0; - while (args) { - if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) { - return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f); - } - args = ao_lisp_poly_cons(args->cdr); - f++; - } - return ao_lisp_arg(cons, 0); - } else { + switch (ao_lisp_poly_type(func)) { + case AO_LISP_BUILTIN: + return ao_lisp_poly_builtin(func)->args; + case AO_LISP_LAMBDA: + return ao_lisp_poly_lambda(func)->args; + default: ao_lisp_error(AO_LISP_INVALID, "not a func"); - abort(); - return AO_LISP_NIL; + return -1; } } +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + static int -ao_lisp_cons_length(struct ao_lisp_cons *cons) +ao_lisp_eval_sexpr(void) { - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); + DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); + switch (ao_lisp_poly_type(ao_lisp_v)) { + case AO_LISP_CONS: + if (ao_lisp_v == AO_LISP_NIL) { + if (!ao_lisp_stack->values) { + /* + * empty list evaluates to empty list + */ + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + /* + * done with arguments, go execute it + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; + ao_lisp_stack->state = eval_exec; + } + } else { + if (!ao_lisp_stack->values) + ao_lisp_stack->list = ao_lisp_v; + /* + * Evaluate another argument and then switch + * to 'formal' to add the value to the values + * list + */ + ao_lisp_stack->sexprs = ao_lisp_v; + ao_lisp_stack->state = eval_formal; + if (!ao_lisp_stack_push()) + return 0; + /* + * push will reset the state to 'sexpr', which + * will evaluate the expression + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + } + break; + case AO_LISP_ATOM: + DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); + /* fall through */ + case AO_LISP_INT: + case AO_LISP_STRING: + case AO_LISP_BUILTIN: + case AO_LISP_LAMBDA: + ao_lisp_stack->state = eval_val; + break; } - return len; + DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); + return 1; } -static ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons) +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_lisp_eval_val(void) { - ao_poly type; - struct ao_lisp_cons *lambda; - struct ao_lisp_cons *args; - struct ao_lisp_frame *next_frame; - int args_wanted; - int args_provided; + DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); + if (ao_lisp_stack->macro) { + DBGI("..macro %d\n", ao_lisp_stack->macro); + DBGI("..current frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI("..saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + DBGI("..macro frame "); DBG_POLY(ao_lisp_stack->macro_frame); DBG("\n"); + DBGI("..sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI("..values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + /* + * Re-use the current stack to evaluate + * the value from the macro + */ + ao_lisp_stack->state = eval_sexpr; +// assert(ao_lisp_stack->frame == ao_lisp_stack->macro_frame); + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->macro_frame); + ao_lisp_stack->frame = ao_lisp_stack->macro_frame; + ao_lisp_stack->macro = 0; + ao_lisp_stack->macro_frame = AO_LISP_NIL; + ao_lisp_stack->sexprs = AO_LISP_NIL; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; + } else { + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_lisp_stack_pop(); + } + DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); + return 1; +} - lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); - DBGI("lambda "); DBG_CONS(lambda); DBG("\n"); - type = ao_lisp_arg(lambda, 0); - args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1)); +/* + * A formal has been computed. + * + * If this is the first formal, then + * check to see if we've got a lamda/lexpr or + * macro/nlambda. + * + * For lambda/lexpr, go compute another formal. + * This will terminate when the sexpr state + * sees nil. + * + * For macro/nlambda, we're done, so move the + * sexprs into the values and go execute it. + */ - args_wanted = ao_lisp_cons_length(args); +static int +ao_lisp_eval_formal(void) +{ + ao_poly formal; - /* Create a frame to hold the variables - */ - if (type == _ao_lisp_atom_lambda) - args_provided = ao_lisp_cons_length(cons) - 1; - else - args_provided = 1; - if (args_wanted != args_provided) - return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); - next_frame = ao_lisp_frame_new(args_wanted); -// DBGI("new frame %d\n", OFFSET(next_frame)); - switch (type) { - case _ao_lisp_atom_lambda: { - int f; - struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); - - for (f = 0; f < args_wanted; f++) { - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = vals->car; - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); + DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); + + /* Check what kind of function we've got */ + if (!ao_lisp_stack->values) { + switch (func_type(ao_lisp_v)) { + case AO_LISP_FUNC_LAMBDA: + case AO_LISP_FUNC_LEXPR: + DBGI(".. lambda or lexpr\n"); + break; + case AO_LISP_FUNC_MACRO: + ao_lisp_stack->macro = 1; + DBGI(".. macro %d\n", ao_lisp_stack->macro); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + ao_lisp_stack->macro_frame = ao_lisp_stack->frame; + /* fall through ... */ + case AO_LISP_FUNC_NLAMBDA: + DBGI(".. nlambda or macro\n"); + ao_lisp_stack->values = ao_lisp_stack->sexprs; + ao_lisp_stack->values_tail = AO_LISP_NIL; + ao_lisp_stack->state = eval_exec; + return 1; + case -1: + return 0; } - break; } - case _ao_lisp_atom_lexpr: - case _ao_lisp_atom_nlambda: - next_frame->vals[0].atom = args->car; - next_frame->vals[0].val = cons->cdr; + + /* Append formal to list of values */ + formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + if (!formal) + return 0; + + if (ao_lisp_stack->values_tail) + ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; + else + ao_lisp_stack->values = formal; + ao_lisp_stack->values_tail = formal; + + DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + + /* + * Step to the next argument, if this is last, then + * 'sexpr' will end up switching to 'exec' + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + + ao_lisp_stack->state = eval_sexpr; + + DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n"); + return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_lisp_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_lisp_eval_exec(void) +{ + ao_poly v; + DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); + ao_lisp_stack->sexprs = AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_v)) { + case AO_LISP_BUILTIN: + ao_lisp_stack->state = eval_val; + v = ao_lisp_func(ao_lisp_poly_builtin(ao_lisp_v)) ( + ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); + DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + ao_poly atom = ao_lisp_arg(cons, 1); + ao_poly val = ao_lisp_arg(cons, 2); + DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); + }); + ao_lisp_v = v; + DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; - case _ao_lisp_atom_macro: - next_frame->vals[0].atom = args->car; - next_frame->vals[0].val = ao_lisp_cons_poly(cons); + case AO_LISP_LAMBDA: + ao_lisp_stack->state = eval_sexpr; + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + ao_lisp_v = ao_lisp_lambda_eval(ao_lisp_poly_lambda(ao_lisp_v), + ao_lisp_poly_cons(ao_lisp_stack->values)); + DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; } - next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current); - ao_lisp_frame_current = next_frame; - ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame); - return ao_lisp_arg(lambda, 2); + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; + return 1; } +static int +ao_lisp_eval_lambda_done(void) +{ + DBGI("lambda_done: "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBG_STACK(); + return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_lisp_eval_cond(void) +{ + DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + if (!ao_lisp_stack->sexprs) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; + if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); + return 0; + } + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + ao_lisp_stack->state = eval_cond_test; + if (!ao_lisp_stack_push()) + return 0; + ao_lisp_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_lisp_eval_cond_test(void) +{ + DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + if (ao_lisp_v) { + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); + struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); + + ao_lisp_stack->state = eval_val; + if (c) { + ao_lisp_v = c->car; + if (!ao_lisp_stack_push()) + return 0; + } + } else { + ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + ao_lisp_stack->state = eval_cond; + } + return 1; +} + +static int (*const evals[])(void) = { + [eval_sexpr] = ao_lisp_eval_sexpr, + [eval_val] = ao_lisp_eval_val, + [eval_formal] = ao_lisp_eval_formal, + [eval_exec] = ao_lisp_eval_exec, + [eval_cond] = ao_lisp_eval_cond, + [eval_cond_test] = ao_lisp_eval_cond_test, +}; + ao_poly ao_lisp_eval(ao_poly _v) { - ao_poly formal; + static uint8_t been_here; ao_lisp_v = _v; if (!been_here) { @@ -345,165 +494,16 @@ ao_lisp_eval(ao_poly _v) } if (!ao_lisp_stack_push()) - goto bail; - - for (;;) { - if (ao_lisp_exception) - goto bail; - switch (ao_lisp_stack->state) { - case eval_sexpr: - DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_CONS: - if (ao_lisp_v == AO_LISP_NIL) { - ao_lisp_stack->state = eval_exec; - break; - } - ao_lisp_stack->actuals = ao_lisp_v; - DBGI("actuals now "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_stack->state = eval_formal; - if (!ao_lisp_stack_push()) - goto bail; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - stack_validate_tails(); - break; - case AO_LISP_ATOM: - ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); - /* fall through */ - case AO_LISP_INT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - ao_lisp_stack->state = eval_val; - break; - } - break; - case eval_val: - DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_stack_pop(); - if (!ao_lisp_stack) - return ao_lisp_v; - DBGI("..state %d\n", ao_lisp_stack->state); - break; - - case eval_formal: - /* Check what kind of function we've got */ - if (!ao_lisp_stack->formals) { - switch (func_type(ao_lisp_v)) { - case AO_LISP_LAMBDA: - case _ao_lisp_atom_lambda: - case AO_LISP_LEXPR: - case _ao_lisp_atom_lexpr: - DBGI(".. lambda or lexpr\n"); - break; - case AO_LISP_MACRO: - case _ao_lisp_atom_macro: - ao_lisp_stack->macro = 1; - case AO_LISP_NLAMBDA: - case _ao_lisp_atom_nlambda: - DBGI(".. nlambda or macro\n"); - ao_lisp_stack->formals = ao_lisp_stack->actuals; - ao_lisp_stack->formals_tail = AO_LISP_NIL; - ao_lisp_stack->state = eval_exec_direct; - stack_validate_tails(); - break; - } - if (ao_lisp_stack->state == eval_exec_direct) - break; - } - - DBGI("add formal "); DBG_POLY(ao_lisp_v); DBG("\n"); - stack_validate_tails(); - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); - stack_validate_tails(); - if (!formal) - goto bail; - - if (ao_lisp_stack->formals_tail) - ao_lisp_poly_cons(ao_lisp_stack->formals_tail)->cdr = formal; - else - ao_lisp_stack->formals = formal; - ao_lisp_stack->formals_tail = formal; - - DBGI("formals now "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - - stack_validate_tails(); - ao_lisp_stack->state = eval_sexpr; + return AO_LISP_NIL; - break; - case eval_exec: - if (!ao_lisp_stack->formals) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - break; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->formals)->car; - case eval_exec_direct: - DBGI("exec: macro %d ", ao_lisp_stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(ao_lisp_stack->formals); DBG ("\n"); - if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) { - stack_validate_tails(); - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); - stack_validate_tails(); - struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->formals)->cdr); - - DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n"); - stack_validate_tails(); - if (ao_lisp_stack->macro) - ao_lisp_stack->state = eval_sexpr; - else - ao_lisp_stack->state = eval_val; - ao_lisp_stack->macro = 0; - ao_lisp_stack->actuals = ao_lisp_stack->formals = ao_lisp_stack->formals_tail = AO_LISP_NIL; - ao_lisp_v = ao_lisp_func(b) (f); - DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n"); - if (ao_lisp_exception) - goto bail; - break; - } else { - ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(ao_lisp_stack->formals)); - ao_lisp_stack_reset(ao_lisp_stack); - } - break; - case eval_cond: - DBGI("cond: "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - if (!ao_lisp_stack->actuals) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->car; - if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); - goto bail; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - ao_lisp_stack->state = eval_cond_test; - stack_validate_tails(); - ao_lisp_stack_push(); - stack_validate_tails(); - ao_lisp_stack->state = eval_sexpr; - } - break; - case eval_cond_test: - DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - if (ao_lisp_v) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->actuals)->car); - struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); - if (c) { - ao_lisp_v = c->car; - ao_lisp_stack->state = eval_sexpr; - } else { - ao_lisp_stack->state = eval_val; - } - } else { - ao_lisp_stack->actuals = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - DBGI("actuals now "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - ao_lisp_stack->state = eval_cond; - } - break; + while (ao_lisp_stack) { +// DBG_STACK(); + if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { + ao_lisp_stack_clear(); + return AO_LISP_NIL; } } -bail: - ao_lisp_stack_clear(); - return AO_LISP_NIL; + DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); + ao_lisp_frame_current = NULL; + return ao_lisp_v; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 8791c4de..7978f20a 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -100,6 +100,27 @@ const struct ao_lisp_type ao_lisp_frame_type = { .move = frame_move }; +void +ao_lisp_frame_print(ao_poly p) +{ + struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); + int f; + + printf ("{"); + if (frame) { + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + } + if (frame->next) + ao_lisp_poly_print(frame->next); + } + printf("}"); +} + ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f2e3cea1..501052b9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -33,34 +33,32 @@ struct builtin_func { }; struct builtin_func funcs[] = { - "car", AO_LISP_LEXPR, builtin_car, - "cdr", AO_LISP_LEXPR, builtin_cdr, - "cons", AO_LISP_LEXPR, builtin_cons, - "quote", AO_LISP_NLAMBDA,builtin_quote, - "set", AO_LISP_LEXPR, builtin_set, - "setq", AO_LISP_MACRO, builtin_setq, - "cond", AO_LISP_NLAMBDA,builtin_cond, - "print", AO_LISP_LEXPR, builtin_print, - "patom", AO_LISP_LEXPR, builtin_patom, - "+", AO_LISP_LEXPR, builtin_plus, - "-", AO_LISP_LEXPR, builtin_minus, - "*", AO_LISP_LEXPR, builtin_times, - "/", AO_LISP_LEXPR, builtin_divide, - "%", AO_LISP_LEXPR, builtin_mod, - "=", AO_LISP_LEXPR, builtin_equal, - "<", AO_LISP_LEXPR, builtin_less, - ">", AO_LISP_LEXPR, builtin_greater, - "<=", AO_LISP_LEXPR, builtin_less_equal, - ">=", AO_LISP_LEXPR, builtin_greater_equal, + "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, + "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, + "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, + "macro", AO_LISP_FUNC_NLAMBDA, builtin_macro, + "car", AO_LISP_FUNC_LAMBDA, builtin_car, + "cdr", AO_LISP_FUNC_LAMBDA, builtin_cdr, + "cons", AO_LISP_FUNC_LAMBDA, builtin_cons, + "last", AO_LISP_FUNC_LAMBDA, builtin_last, + "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, + "set", AO_LISP_FUNC_LAMBDA, builtin_set, + "setq", AO_LISP_FUNC_MACRO, builtin_setq, + "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, + "print", AO_LISP_FUNC_LEXPR, builtin_print, + "patom", AO_LISP_FUNC_LEXPR, builtin_patom, + "+", AO_LISP_FUNC_LEXPR, builtin_plus, + "-", AO_LISP_FUNC_LEXPR, builtin_minus, + "*", AO_LISP_FUNC_LEXPR, builtin_times, + "/", AO_LISP_FUNC_LEXPR, builtin_divide, + "%", AO_LISP_FUNC_LEXPR, builtin_mod, + "=", AO_LISP_FUNC_LEXPR, builtin_equal, + "<", AO_LISP_FUNC_LEXPR, builtin_less, + ">", AO_LISP_FUNC_LEXPR, builtin_greater, + "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, + ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, }; -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ - (void) c; - return AO_LISP_NIL; -} - #define N_FUNC (sizeof funcs / sizeof funcs[0]) /* Syntactic atoms */ @@ -90,19 +88,18 @@ int main(int argc, char **argv) { int f, o, i; - ao_poly atom, val; + ao_poly sexpr, val; struct ao_lisp_atom *a; struct ao_lisp_builtin *b; 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); for (f = 0; f < N_FUNC; f++) { b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_builtin_poly(b)); } /* atoms for syntax */ @@ -110,23 +107,25 @@ main(int argc, char **argv) (void) ao_lisp_atom_intern(atoms[i]); /* boolean constants */ - a = ao_lisp_atom_intern("nil"); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); + ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), + 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)); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_poly(a)); for (;;) { - atom = ao_lisp_read(); - if (!atom) + sexpr = ao_lisp_read(); + if (!sexpr) break; - val = ao_lisp_read(); - if (!val) - break; - if (ao_lisp_poly_type(atom) != AO_LISP_ATOM) { - fprintf(stderr, "input must be atom val pairs\n"); + printf ("sexpr: "); + ao_lisp_poly_print(sexpr); + printf("\n"); + val = ao_lisp_eval(sexpr); + if (ao_lisp_exception) exit(1); - } - globals = ao_lisp_frame_add(globals, atom, val); + printf("\t"); + ao_lisp_poly_print(val); + printf("\n"); } /* Reduce to referenced values */ @@ -136,7 +135,7 @@ main(int argc, char **argv) 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)); + printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index c11ec25d..476843d8 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -262,6 +262,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_ATOM] = &ao_lisp_atom_type, [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, + [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, }; diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 3c081ee8..bfd75ae3 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -45,7 +45,15 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { [AO_LISP_BUILTIN] = { .print = ao_lisp_builtin_print, .patom = ao_lisp_builtin_print, - } + }, + [AO_LISP_FRAME] = { + .print = ao_lisp_frame_print, + .patom = ao_lisp_frame_print, + }, + [AO_LISP_LAMBDA] = { + .print = ao_lisp_lambda_print, + .patom = ao_lisp_lambda_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/test/Makefile b/src/test/Makefile index 8d617eea..7395e832 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -94,7 +94,7 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h 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_error.o + ao_lisp_lambda.o ao_lisp_error.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -- cgit v1.2.3 From 0ee44c8e4bf5dabe6a97bf76b366c8b767c387f8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 11:13:58 -0800 Subject: altos/lisp: macros appear to work now Needed an extra stack frame to stash the pre-macro state. This simplified macro processing quite a bit; a macro now just evaluates the function and then sends that result to be evaluated again. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 37 ++++++++++------- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_error.c | 5 +-- src/lisp/ao_lisp_eval.c | 105 +++++++++++++++++++++++++---------------------- 4 files changed, 81 insertions(+), 68 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 6a35d8ce..82ba5a20 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -78,6 +78,7 @@ extern uint16_t ao_lisp_top; #define AO_LISP_OOM 0x01 #define AO_LISP_DIVIDE_BY_ZERO 0x02 #define AO_LISP_INVALID 0x04 +#define AO_LISP_UNDEFINED 0x08 extern uint8_t ao_lisp_exception; @@ -156,28 +157,25 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { return ao_lisp_poly(frame, AO_LISP_OTHER); } -struct ao_lisp_stack { - ao_poly prev; - uint8_t state; - uint8_t macro; - ao_poly sexprs; - ao_poly values; - ao_poly values_tail; - ao_poly frame; - ao_poly macro_frame; - ao_poly list; -}; - enum eval_state { - eval_sexpr, + eval_sexpr, /* Evaluate an sexpr */ eval_val, eval_formal, eval_exec, - eval_lambda_done, eval_cond, eval_cond_test }; +struct ao_lisp_stack { + uint8_t state; /* enum eval_state */ + ao_poly prev; /* previous stack frame */ + ao_poly sexprs; /* expressions to evaluate */ + ao_poly values; /* values computed */ + ao_poly values_tail; /* end of the values list for easy appending */ + ao_poly frame; /* current lookup frame */ + ao_poly list; /* most recent function call */ +}; + static inline struct ao_lisp_stack * ao_lisp_poly_stack(ao_poly p) { @@ -559,6 +557,16 @@ int ao_lisp_stack_depth; #define DBG_POLY(a) ao_lisp_poly_print(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) #define DBG_STACK() ao_lisp_stack_print() +static inline void +ao_lisp_frames_dump(void) +{ + struct ao_lisp_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + } +} +#define DBG_FRAMES() ao_lisp_frames_dump() #else #define DBG_DO(a) #define DBG_INDENT() @@ -570,6 +578,7 @@ int ao_lisp_stack_depth; #define DBG_POLY(a) #define DBG_RESET() #define DBG_STACK() +#define DBG_FRAMES() #endif #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index d7cb1996..5c6d5a67 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -134,7 +134,7 @@ ao_lisp_atom_get(ao_poly atom) #endif if (ref) return *ref; - return AO_LISP_NIL; + return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); } ao_poly diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index cedc107c..8b9fe2d5 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -80,17 +80,16 @@ ao_lisp_stack_print(void) { struct ao_lisp_stack *s; printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); - ao_lisp_error_frame(0, "Frame: ", ao_lisp_frame_current); printf("Stack:\n"); for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { printf("\t[\n"); printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); printf("\t\tstate: %s\n", state_names[s->state]); - printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); +// printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); ao_lisp_error_cons ("sexprs: ", ao_lisp_poly_cons(s->sexprs)); ao_lisp_error_cons ("values: ", ao_lisp_poly_cons(s->values)); ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); - ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); +// ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); printf("\t]\n"); } } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index f4196219..f3372f2a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,7 @@ * General Public License for more details. */ -#define DBG_EVAL 1 +#define DBG_EVAL 0 #include "ao_lisp.h" #include @@ -32,7 +32,6 @@ stack_mark(void *addr) ao_lisp_poly_mark(stack->values, 0); /* no need to mark values_tail */ ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->macro_frame, 0); stack = ao_lisp_poly_stack(stack->prev); if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) break; @@ -53,7 +52,6 @@ stack_move(void *addr) (void) ao_lisp_poly_move(&stack->values, 0); (void) ao_lisp_poly_move(&stack->values_tail, 0); (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->macro_frame, 0); prev = ao_lisp_poly_stack(stack->prev); ret = ao_lisp_move(&ao_lisp_stack_type, &prev); if (prev != ao_lisp_poly_stack(stack->prev)) @@ -85,28 +83,15 @@ static void ao_lisp_stack_reset(struct ao_lisp_stack *stack) { stack->state = eval_sexpr; - stack->macro = 0; stack->sexprs = AO_LISP_NIL; stack->values = AO_LISP_NIL; stack->values_tail = AO_LISP_NIL; } -static void -ao_lisp_frames_dump(void) -{ - struct ao_lisp_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - DBGI(".. macro frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} static int ao_lisp_stack_push(void) { - DBGI("stack push\n"); - DBG_IN(); struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); if (!stack) return 0; @@ -115,7 +100,9 @@ ao_lisp_stack_push(void) stack->list = AO_LISP_NIL; ao_lisp_stack = stack; ao_lisp_stack_reset(stack); - ao_lisp_frames_dump(); + DBGI("stack push\n"); + DBG_IN(); + DBG_FRAMES(); return 1; } @@ -124,11 +111,14 @@ ao_lisp_stack_pop(void) { if (!ao_lisp_stack) return; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); + if (ao_lisp_stack) + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + else + ao_lisp_frame_current = NULL; DBG_OUT(); DBGI("stack pop\n"); - ao_lisp_frames_dump(); + DBG_FRAMES(); } static void @@ -246,19 +236,20 @@ static int ao_lisp_eval_val(void) { DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); +#if 0 if (ao_lisp_stack->macro) { - DBGI("..macro %d\n", ao_lisp_stack->macro); - DBGI("..current frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI("..saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - DBGI("..macro frame "); DBG_POLY(ao_lisp_stack->macro_frame); DBG("\n"); - DBGI("..sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI("..values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + DBGI(".. end macro %d\n", ao_lisp_stack->macro); + DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + ao_lisp_frames_dump(); + + ao_lisp_stack_pop(); +#if 0 /* * Re-use the current stack to evaluate * the value from the macro */ ao_lisp_stack->state = eval_sexpr; -// assert(ao_lisp_stack->frame == ao_lisp_stack->macro_frame); ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->macro_frame); ao_lisp_stack->frame = ao_lisp_stack->macro_frame; ao_lisp_stack->macro = 0; @@ -266,7 +257,10 @@ ao_lisp_eval_val(void) ao_lisp_stack->sexprs = AO_LISP_NIL; ao_lisp_stack->values = AO_LISP_NIL; ao_lisp_stack->values_tail = AO_LISP_NIL; - } else { +#endif + } else +#endif + { /* * Value computed, pop the stack * to figure out what to do with the value @@ -280,22 +274,25 @@ ao_lisp_eval_val(void) /* * A formal has been computed. * - * If this is the first formal, then - * check to see if we've got a lamda/lexpr or - * macro/nlambda. + * If this is the first formal, then check to see if we've got a + * lamda/lexpr or macro/nlambda. + * + * For lambda/lexpr, go compute another formal. This will terminate + * when the sexpr state sees nil. * - * For lambda/lexpr, go compute another formal. - * This will terminate when the sexpr state - * sees nil. + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. * - * For macro/nlambda, we're done, so move the - * sexprs into the values and go execute it. + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run */ static int ao_lisp_eval_formal(void) { - ao_poly formal; + ao_poly formal; + struct ao_lisp_stack *prev; DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); @@ -307,17 +304,34 @@ ao_lisp_eval_formal(void) DBGI(".. lambda or lexpr\n"); break; case AO_LISP_FUNC_MACRO: - ao_lisp_stack->macro = 1; - DBGI(".. macro %d\n", ao_lisp_stack->macro); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - ao_lisp_stack->macro_frame = ao_lisp_stack->frame; + /* Evaluate the result once more */ + prev = ao_lisp_stack; + ao_lisp_stack->state = eval_sexpr; + if (!ao_lisp_stack_push()) + return 0; + + /* After the function returns, take that + * value and re-evaluate it + */ + ao_lisp_stack->state = eval_sexpr; + ao_lisp_stack->sexprs = prev->sexprs; + prev->sexprs = AO_LISP_NIL; + + DBGI(".. start macro\n"); + DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + DBG_FRAMES(); + /* fall through ... */ case AO_LISP_FUNC_NLAMBDA: DBGI(".. nlambda or macro\n"); + + /* use the raw sexprs as values */ ao_lisp_stack->values = ao_lisp_stack->sexprs; ao_lisp_stack->values_tail = AO_LISP_NIL; ao_lisp_stack->state = eval_exec; + + /* ready to execute now */ return 1; case -1: return 0; @@ -397,14 +411,6 @@ ao_lisp_eval_exec(void) return 1; } -static int -ao_lisp_eval_lambda_done(void) -{ - DBGI("lambda_done: "); DBG_POLY(ao_lisp_v); DBG("\n"); - DBG_STACK(); - return 1; -} - /* * Start evaluating the next cond clause * @@ -497,7 +503,6 @@ ao_lisp_eval(ao_poly _v) return AO_LISP_NIL; while (ao_lisp_stack) { -// DBG_STACK(); if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { ao_lisp_stack_clear(); return AO_LISP_NIL; -- cgit v1.2.3 From 417161dbb36323b5a6572859dedad02ca92fc65c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 16:22:43 -0800 Subject: altos/lisp: Clean up OS integration bits, add defun Provide an abstraction for the OS interface so that it can build more cleanly on Linux and AltOS. Add defun macro. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 1 + src/lambdakey-v1.0/ao_lisp_os.h | 56 ++++++++++++ src/lambdakey-v1.0/ao_pins.h | 2 +- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 19 ++-- src/lisp/ao_lisp_builtin.c | 36 +++++++- src/lisp/ao_lisp_const.lisp | 35 +++++++- src/lisp/ao_lisp_lambda.c | 188 ++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_make_const.c | 16 +--- src/lisp/ao_lisp_mem.c | 8 +- src/lisp/ao_lisp_os.h | 51 +++++++++++ src/lisp/ao_lisp_poly.c | 85 +++++++++++++----- src/lisp/ao_lisp_prim.c | 86 ------------------ src/lisp/ao_lisp_read.c | 14 +-- src/test/Makefile | 5 +- 15 files changed, 442 insertions(+), 163 deletions(-) create mode 100644 src/lambdakey-v1.0/ao_lisp_os.h create mode 100644 src/lisp/ao_lisp_lambda.c create mode 100644 src/lisp/ao_lisp_os.h delete mode 100644 src/lisp/ao_lisp_prim.c (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 4db0e290..ef03527e 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -47,6 +47,7 @@ ALTOS_SRC = \ ao_lisp_rep.c \ ao_lisp_frame.c \ ao_lisp_error.c \ + ao_lisp_lambda.c \ ao_exti_stm.c PRODUCT=LambdaKey-v1.0 diff --git a/src/lambdakey-v1.0/ao_lisp_os.h b/src/lambdakey-v1.0/ao_lisp_os.h new file mode 100644 index 00000000..df158f6a --- /dev/null +++ b/src/lambdakey-v1.0/ao_lisp_os.h @@ -0,0 +1,56 @@ +/* + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include "ao.h" + +static inline int +ao_lisp_getc() { + static uint8_t at_eol; + int c; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; + return c; +} + +static inline void +ao_lisp_abort(void) +{ + ao_panic(1); +} + +static inline void +ao_lisp_os_led(int led) +{ + ao_led_set(led); +} + +static inline void +ao_lisp_os_delay(int delay) +{ + ao_delay(AO_MS_TO_TICKS(delay)); +} + +#endif diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index 5a840f13..b8429c55 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -25,7 +25,7 @@ #define AO_LED_RED (1 << LED_PIN_RED) #define AO_LED_PANIC AO_LED_RED #define AO_CMD_LEN 128 -#define AO_LISP_POOL 2560 +#define AO_LISP_POOL 3072 #define AO_STACK_SIZE 1024 #define LEDS_AVAILABLE (AO_LED_RED) diff --git a/src/lisp/Makefile b/src/lisp/Makefile index f7edbe41..9c99f05c 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -14,7 +14,6 @@ SRCS=\ ao_lisp_atom.c \ ao_lisp_int.c \ ao_lisp_poly.c \ - ao_lisp_prim.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ @@ -24,7 +23,7 @@ SRCS=\ OBJS=$(SRCS:.c=.o) -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g +CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. HDRS=\ ao_lisp.h \ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 82ba5a20..de55b307 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,17 +15,10 @@ #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 #include -#include +//#include +#include #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 @@ -45,6 +38,8 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_last _atom("last") #define _ao_lisp_atom_cond _atom("cond") #define _ao_lisp_atom_lambda _atom("lambda") +#define _ao_lisp_atom_led _atom("led") +#define _ao_lisp_atom_delay _atom("delay") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -99,7 +94,7 @@ ao_lisp_is_const(ao_poly poly) { static inline void * ao_lisp_ref(ao_poly poly) { if (poly == 0xBEEF) - abort(); + ao_lisp_abort(); if (poly == AO_LISP_NIL) return NULL; if (poly & AO_LISP_CONST) @@ -227,12 +222,14 @@ enum ao_lisp_builtin_id { builtin_greater, builtin_less_equal, builtin_greater_equal, + builtin_delay, + builtin_led, _builtin_last }; typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); -extern ao_lisp_func_t ao_lisp_builtins[]; +extern const ao_lisp_func_t ao_lisp_builtins[]; static inline ao_lisp_func_t ao_lisp_func(struct ao_lisp_builtin *b) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index c38ba165..5bd180e2 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -72,11 +72,13 @@ static const ao_poly builtin_names[] = { [builtin_greater] = _ao_lisp_atom_3e, [builtin_less_equal] = _ao_lisp_atom_3c3d, [builtin_greater_equal] = _ao_lisp_atom_3e3d, + [builtin_delay] = _ao_lisp_atom_delay, + [builtin_led] = _ao_lisp_atom_led, }; static char * ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - if (0 <= b && b < _builtin_last) + if (b < _builtin_last) return ao_lisp_poly_atom(builtin_names[b])->name; return "???"; } @@ -448,7 +450,33 @@ ao_lisp_greater_equal(struct ao_lisp_cons *cons) return ao_lisp_compare(cons, builtin_greater_equal); } -ao_lisp_func_t ao_lisp_builtins[] = { +ao_poly +ao_lisp_led(struct ao_lisp_cons *cons) +{ + ao_poly led; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) + return AO_LISP_NIL; + led = ao_lisp_arg(cons, 0); + ao_lisp_os_led(ao_lisp_poly_int(led)); + return led; +} + +ao_poly +ao_lisp_delay(struct ao_lisp_cons *cons) +{ + ao_poly delay; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) + return AO_LISP_NIL; + delay = ao_lisp_arg(cons, 0); + ao_lisp_os_delay(ao_lisp_poly_int(delay)); + return delay; +} + +const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_lambda] = ao_lisp_lambda, [builtin_lexpr] = ao_lisp_lexpr, [builtin_nlambda] = ao_lisp_nlambda, @@ -472,6 +500,8 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_less] = ao_lisp_less, [builtin_greater] = ao_lisp_greater, [builtin_less_equal] = ao_lisp_less_equal, - [builtin_greater_equal] = ao_lisp_greater_equal + [builtin_greater_equal] = ao_lisp_greater_equal, + [builtin_led] = ao_lisp_led, + [builtin_delay] = ao_lisp_delay, }; diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 621fefc4..08a511d9 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,9 +14,13 @@ (setq 1+ (lambda (x) (+ x 1))) (setq 1- (lambda (x) (- x 1))) - ; define a variable without returning the value + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated + ; -(set 'def (macro (def-param) +(setq def (macro (def-param) (list 'progn (list @@ -127,3 +131,30 @@ ) ) ) + + ; + ; A slightly more convenient form + ; for defining lambdas. + ; + ; (defun () s-exprs) + ; + +(def defun (macro (defun-param) + (let ((name (car defun-param)) + (args (cadr defun-param)) + (exprs (cdr (cdr defun-param)))) + (list + def + name + (list + 'lambda + args + (cond ((cdr exprs) + (cons progn exprs)) + ((car exprs)) + ) + ) + ) + ) + ) + ) diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c new file mode 100644 index 00000000..cc5af4bc --- /dev/null +++ b/src/lisp/ao_lisp_lambda.c @@ -0,0 +1,188 @@ +/* + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#define DBG_EVAL 0 +#include "ao_lisp.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_lambda); +} + +void +lambda_mark(void *addr) +{ + struct ao_lisp_lambda *lambda = addr; + + ao_lisp_poly_mark(lambda->code, 0); + ao_lisp_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ + struct ao_lisp_lambda *lambda = addr; + + ao_lisp_poly_move(&lambda->code, 0); + ao_lisp_poly_move(&lambda->frame, 0); +} + +const struct ao_lisp_type ao_lisp_lambda_type = { + .size = lambda_size, + .mark = lambda_mark, + .move = lambda_move, +}; + +static int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} + +void +ao_lisp_lambda_print(ao_poly poly) +{ + struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); + struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); + + printf("("); + printf("%s", ao_lisp_args_name(lambda->args)); + while (cons) { + printf(" "); + ao_lisp_poly_print(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) +{ + struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + struct ao_lisp_cons *arg; + int f; + + if (!lambda) + return AO_LISP_NIL; + + if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, code, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + f = 0; + arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + while (arg) { + if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); + arg = ao_lisp_poly_cons(arg->cdr); + f++; + } + + lambda->type = AO_LISP_LAMBDA; + lambda->args = args; + lambda->code = ao_lisp_cons_poly(code); + lambda->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); + DBG_STACK(); + return ao_lisp_lambda_poly(lambda); +} + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); +} + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); +} + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); +} + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); +} + +ao_poly +ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, + struct ao_lisp_cons *cons) +{ + struct ao_lisp_cons *code; + struct ao_lisp_cons *args; + struct ao_lisp_frame *next_frame; + int args_wanted; + int args_provided; + + code = ao_lisp_poly_cons(lambda->code); + DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); + args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + if (lambda->args == AO_LISP_FUNC_LAMBDA) + args_provided = ao_lisp_cons_length(cons) - 1; + else + args_provided = 1; + if (args_wanted != args_provided) + return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + next_frame = ao_lisp_frame_new(args_wanted); + switch (lambda->args) { + case AO_LISP_FUNC_LAMBDA: { + int f; + struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); + + for (f = 0; f < args_wanted; f++) { + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = vals->car; + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + break; + } + case AO_LISP_FUNC_LEXPR: + case AO_LISP_FUNC_NLAMBDA: + case AO_LISP_FUNC_MACRO: + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(cons->cdr); DBG("\n"); + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = cons->cdr; + break; + } + next_frame->next = lambda->frame; + DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); + ao_lisp_frame_current = next_frame; + ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBG_STACK(); + return ao_lisp_arg(code, 1); +} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 501052b9..6f852f9d 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -57,20 +57,12 @@ struct builtin_func funcs[] = { ">", AO_LISP_FUNC_LEXPR, builtin_greater, "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, + "delay", AO_LISP_FUNC_LAMBDA, builtin_delay, + "led", AO_LISP_FUNC_LEXPR, builtin_led, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) -/* Syntactic atoms */ -char *atoms[] = { - "lambda", - "nlambda", - "lexpr", - "macro" -}; - -#define N_ATOM (sizeof atoms / sizeof atoms[0]) - struct ao_lisp_frame *globals; static int @@ -102,10 +94,6 @@ main(int argc, char **argv) ao_lisp_builtin_poly(b)); } - /* atoms for syntax */ - for (i = 0; i < N_ATOM; i++) - (void) ao_lisp_atom_intern(atoms[i]); - /* boolean constants */ ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), AO_LISP_NIL); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 476843d8..66e09db0 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -331,7 +331,7 @@ ao_lisp_collect(void) move_object(); DBG("\tbusy size %d\n", move_size); if (move_size == 0) - abort(); + ao_lisp_abort(); clear_object(ao_lisp_busy, move_old, move_size); mark_object(ao_lisp_busy, move_new, move_size); if (busy_object(ao_lisp_cons, move_old)) { @@ -431,7 +431,7 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) #endif DBG_MOVE("object %d\n", DBG_OFFSET(addr)); if (!AO_LISP_IS_POOL(a)) - abort(); + ao_lisp_abort(); DBG_MOVE_IN(); addr = check_move(addr, size); if (addr != *ref) @@ -495,7 +495,7 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); if (type >= AO_LISP_NUM_TYPE) - abort(); + ao_lisp_abort(); lisp_type = ao_lisp_types[type]; if (!lisp_type) @@ -601,7 +601,7 @@ ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) return 1; } } - abort(); + ao_lisp_abort(); return 0; } diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h new file mode 100644 index 00000000..55ffed50 --- /dev/null +++ b/src/lisp/ao_lisp_os.h @@ -0,0 +1,51 @@ +/* + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include +#include +#include + +static inline int +ao_lisp_getc() { + return getchar(); +} + +static inline void +ao_lisp_abort(void) +{ + abort(); +} + +static inline void +ao_lisp_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +static inline void +ao_lisp_os_delay(int delay) +{ + struct timespec ts = { + .tv_sec = delay / 1000, + .tv_nsec = (delay % 1000) * 1000000, + }; + nanosleep(&ts, NULL); +} +#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index c6ca0a97..bfd75ae3 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -14,34 +14,73 @@ #include "ao_lisp.h" -/* +#if 0 +#define DBG(...) printf (__VA_ARGS__) +#else +#define DBG(...) +#endif -static const struct ao_lisp_builtin builtin_plus = { - .type = AO_LISP_BUILTIN, - .func = ao_lisp_plus, - .name = "+" +struct ao_lisp_funcs { + void (*print)(ao_poly); + void (*patom)(ao_poly); }; -static const struct ao_lisp_atom atom_plus = { - .type = AO_LISP_ATOM, - .val = AO_LISP_OTHER_POLY(&builtin_plus), - .next = AO_LISP_ATOM_CONST, - .name = "plus" +static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = { + .print = ao_lisp_cons_print, + .patom = ao_lisp_cons_patom, + }, + [AO_LISP_STRING] = { + .print = ao_lisp_string_print, + .patom = ao_lisp_string_patom, + }, + [AO_LISP_INT] = { + .print = ao_lisp_int_print, + .patom = ao_lisp_int_print, + }, + [AO_LISP_ATOM] = { + .print = ao_lisp_atom_print, + .patom = ao_lisp_atom_print, + }, + [AO_LISP_BUILTIN] = { + .print = ao_lisp_builtin_print, + .patom = ao_lisp_builtin_print, + }, + [AO_LISP_FRAME] = { + .print = ao_lisp_frame_print, + .patom = ao_lisp_frame_print, + }, + [AO_LISP_LAMBDA] = { + .print = ao_lisp_lambda_print, + .patom = ao_lisp_lambda_print, + }, }; -static const struct ao_lisp_builtin builtin_minus = { - .type = AO_LISP_BUILTIN, - .func = ao_lisp_minus -}; +static const struct ao_lisp_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_lisp_poly_type(p); -static const struct ao_lisp_builtin builtin_times = { - .type = AO_LISP_BUILTIN, - .func = ao_lisp_times -}; + if (type < AO_LISP_NUM_TYPE) + return &ao_lisp_funcs[type]; + return NULL; +} +void +ao_lisp_poly_print(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->print) + f->print(p); +} + +void +ao_lisp_poly_patom(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->patom) + f->patom(p); +} -const struct ao_lisp_atom const *ao_lisp_builtins[] = { - &atom_plus, - 0 -}; -*/ diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c deleted file mode 100644 index bfd75ae3..00000000 --- a/src/lisp/ao_lisp_prim.c +++ /dev/null @@ -1,86 +0,0 @@ -/* - * 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 - -struct ao_lisp_funcs { - void (*print)(ao_poly); - void (*patom)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = { - .print = ao_lisp_cons_print, - .patom = ao_lisp_cons_patom, - }, - [AO_LISP_STRING] = { - .print = ao_lisp_string_print, - .patom = ao_lisp_string_patom, - }, - [AO_LISP_INT] = { - .print = ao_lisp_int_print, - .patom = ao_lisp_int_print, - }, - [AO_LISP_ATOM] = { - .print = ao_lisp_atom_print, - .patom = ao_lisp_atom_print, - }, - [AO_LISP_BUILTIN] = { - .print = ao_lisp_builtin_print, - .patom = ao_lisp_builtin_print, - }, - [AO_LISP_FRAME] = { - .print = ao_lisp_frame_print, - .patom = ao_lisp_frame_print, - }, - [AO_LISP_LAMBDA] = { - .print = ao_lisp_lambda_print, - .patom = ao_lisp_lambda_print, - }, -}; - -static const struct ao_lisp_funcs * -funcs(ao_poly p) -{ - uint8_t type = ao_lisp_poly_type(p); - - if (type < AO_LISP_NUM_TYPE) - return &ao_lisp_funcs[type]; - return NULL; -} - -void -ao_lisp_poly_print(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->print) - f->print(p); -} - -void -ao_lisp_poly_patom(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->patom) - f->patom(p); -} - diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index bc1eb36b..3a2ef7f1 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -156,19 +156,7 @@ lex_get() c = lex_unget_c; lex_unget_c = 0; } else { -#if AO_LISP_ALTOS - static uint8_t at_eol; - - if (at_eol) { - ao_cmd_readline(); - at_eol = 0; - } - c = ao_cmd_lex(); - if (c == '\n') - at_eol = 1; -#else - c = getchar(); -#endif + c = ao_lisp_getc(); } return c; } diff --git a/src/test/Makefile b/src/test/Makefile index 7395e832..d6777090 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -88,11 +88,8 @@ ao_ms5607_convert_test: ao_ms5607_convert_test.c ao_ms5607_convert_8051.c ao_int ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm - -#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_atom.o ao_lisp_int.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_lambda.o ao_lisp_error.o -- cgit v1.2.3 From c7d7cdc2318a97534c4c1f9c6fd2b51644be729d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 10 Nov 2016 11:30:55 -0800 Subject: altos/lisp: add progn, while, read and eval Progn as a builtin will help with tail-recursion. while provides for loops until tail-recursion works :-) read and eval are kinda useful. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 11 +++++- src/lisp/ao_lisp_builtin.c | 41 +++++++++++++++++++++ src/lisp/ao_lisp_const.lisp | 2 +- src/lisp/ao_lisp_error.c | 1 + src/lisp/ao_lisp_eval.c | 84 ++++++++++++++++++++++++++++++++++++++++++- src/lisp/ao_lisp_make_const.c | 4 +++ 6 files changed, 140 insertions(+), 3 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index de55b307..d265ea7b 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -40,6 +40,8 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_lambda _atom("lambda") #define _ao_lisp_atom_led _atom("led") #define _ao_lisp_atom_delay _atom("delay") +#define _ao_lisp_atom_eval _atom("eval") +#define _ao_lisp_atom_read _atom("read") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -158,7 +160,10 @@ enum eval_state { eval_formal, eval_exec, eval_cond, - eval_cond_test + eval_cond_test, + eval_progn, + eval_while, + eval_while_test, }; struct ao_lisp_stack { @@ -198,6 +203,8 @@ struct ao_lisp_builtin { }; enum ao_lisp_builtin_id { + builtin_eval, + builtin_read, builtin_lambda, builtin_lexpr, builtin_nlambda, @@ -210,6 +217,8 @@ enum ao_lisp_builtin_id { builtin_set, builtin_setq, builtin_cond, + builtin_progn, + builtin_while, builtin_print, builtin_patom, builtin_plus, diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 5bd180e2..57d9ee10 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -48,6 +48,8 @@ char *ao_lisp_args_name(uint8_t args) { } #else static const ao_poly builtin_names[] = { + [builtin_eval] = _ao_lisp_atom_eval, + [builtin_read] = _ao_lisp_atom_read, [builtin_lambda] = _ao_lisp_atom_lambda, [builtin_lexpr] = _ao_lisp_atom_lexpr, [builtin_nlambda] = _ao_lisp_atom_nlambda, @@ -60,6 +62,8 @@ static const ao_poly builtin_names[] = { [builtin_set] = _ao_lisp_atom_set, [builtin_setq] = _ao_lisp_atom_setq, [builtin_cond] = _ao_lisp_atom_cond, + [builtin_progn] = _ao_lisp_atom_progn, + [builtin_while] = _ao_lisp_atom_while, [builtin_print] = _ao_lisp_atom_print, [builtin_patom] = _ao_lisp_atom_patom, [builtin_plus] = _ao_lisp_atom_2b, @@ -235,6 +239,22 @@ ao_lisp_cond(struct ao_lisp_cons *cons) return AO_LISP_NIL; } +ao_poly +ao_lisp_progn(struct ao_lisp_cons *cons) +{ + ao_lisp_stack->state = eval_progn; + ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); + return AO_LISP_NIL; +} + +ao_poly +ao_lisp_while(struct ao_lisp_cons *cons) +{ + ao_lisp_stack->state = eval_while; + ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); + return AO_LISP_NIL; +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -476,7 +496,26 @@ ao_lisp_delay(struct ao_lisp_cons *cons) return delay; } +ao_poly +ao_lisp_do_eval(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1)) + return AO_LISP_NIL; + ao_lisp_stack->state = eval_sexpr; + return cons->car; +} + +ao_poly +ao_lisp_do_read(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0)) + return AO_LISP_NIL; + return ao_lisp_read(); +} + const ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_eval] = ao_lisp_do_eval, + [builtin_read] = ao_lisp_do_read, [builtin_lambda] = ao_lisp_lambda, [builtin_lexpr] = ao_lisp_lexpr, [builtin_nlambda] = ao_lisp_nlambda, @@ -489,6 +528,8 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, [builtin_cond] = ao_lisp_cond, + [builtin_progn] = ao_lisp_progn, + [builtin_while] = ao_lisp_while, [builtin_print] = ao_lisp_print, [builtin_patom] = ao_lisp_patom, [builtin_plus] = ao_lisp_plus, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 08a511d9..c6f50e34 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -7,7 +7,7 @@ ; evaluate a list of sexprs -(setq progn (lexpr (l) (last l))) +;(setq progn (lexpr (l) (last l))) ; simple math operators diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 8b9fe2d5..cfa78d22 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -73,6 +73,7 @@ static const char *state_names[] = { "exec", "cond", "cond_test", + "progn", }; void diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index f3372f2a..c5addcb0 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,7 @@ * General Public License for more details. */ -#define DBG_EVAL 0 +#define DBG_EVAL 1 #include "ao_lisp.h" #include @@ -478,6 +478,85 @@ ao_lisp_eval_cond_test(void) return 1; } +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_lisp_progn records the list in stack->sexprs, so we just need to + * walk that list. Set ao_lisp_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_progn set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_lisp_eval_progn(void) +{ + DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + + if (!ao_lisp_stack->sexprs) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; + ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + if (ao_lisp_stack->sexprs) { + ao_lisp_stack->state = eval_progn; + if (!ao_lisp_stack_push()) + return 0; + } + ao_lisp_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_lisp_eval_while(void) +{ + DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + + if (!ao_lisp_stack->sexprs) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; + ao_lisp_stack->state = eval_while_test; + if (!ao_lisp_stack_push()) + return 0; + ao_lisp_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_lisp_eval_while_test(void) +{ + DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + + if (ao_lisp_v) { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + if (ao_lisp_v) + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + ao_lisp_stack->state = eval_while; + if (!ao_lisp_stack_push()) + return 0; + } + else + ao_lisp_stack->state = eval_val; + return 1; +} + static int (*const evals[])(void) = { [eval_sexpr] = ao_lisp_eval_sexpr, [eval_val] = ao_lisp_eval_val, @@ -485,6 +564,9 @@ static int (*const evals[])(void) = { [eval_exec] = ao_lisp_eval_exec, [eval_cond] = ao_lisp_eval_cond, [eval_cond_test] = ao_lisp_eval_cond_test, + [eval_progn] = ao_lisp_eval_progn, + [eval_while] = ao_lisp_eval_while, + [eval_while_test] = ao_lisp_eval_while_test, }; ao_poly diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6f852f9d..bb4afbfb 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -33,6 +33,8 @@ struct builtin_func { }; struct builtin_func funcs[] = { + "eval", AO_LISP_FUNC_LAMBDA, builtin_eval, + "read", AO_LISP_FUNC_LAMBDA, builtin_read, "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, @@ -45,6 +47,8 @@ struct builtin_func funcs[] = { "set", AO_LISP_FUNC_LAMBDA, builtin_set, "setq", AO_LISP_FUNC_MACRO, builtin_setq, "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, + "progn", AO_LISP_FUNC_NLAMBDA, builtin_progn, + "while", AO_LISP_FUNC_NLAMBDA, builtin_while, "print", AO_LISP_FUNC_LEXPR, builtin_print, "patom", AO_LISP_FUNC_LEXPR, builtin_patom, "+", AO_LISP_FUNC_LEXPR, builtin_plus, -- cgit v1.2.3 From 92cdc0cf0e80c1ff3f31cce20fc2b9bda86e3638 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 10 Nov 2016 23:25:56 -0800 Subject: altos/lisp: Make read() return eof atom on end of file Also make it an exception to hit eof in the middle of an sexpr. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 ++ src/lisp/ao_lisp_read.c | 18 ++++++++++++++---- src/lisp/ao_lisp_rep.c | 3 +-- 3 files changed, 17 insertions(+), 6 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d265ea7b..6122a2ed 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -42,6 +42,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_delay _atom("delay") #define _ao_lisp_atom_eval _atom("eval") #define _ao_lisp_atom_read _atom("read") +#define _ao_lisp_atom_eof _atom("eof") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -76,6 +77,7 @@ extern uint16_t ao_lisp_top; #define AO_LISP_DIVIDE_BY_ZERO 0x02 #define AO_LISP_INVALID 0x04 #define AO_LISP_UNDEFINED 0x08 +#define AO_LISP_EOF 0x10 extern uint8_t ao_lisp_exception; diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 3a2ef7f1..7a5751ce 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -12,6 +12,7 @@ * General Public License for more details. */ +#define DBG_EVAL 0 #include "ao_lisp.h" #include "ao_lisp_read.h" @@ -270,7 +271,7 @@ lex(void) for (;;) { c = lexc(); if (lex_class & ENDOFFILE) - return AO_LISP_NIL; + return END; if (lex_class & WHITE) continue; @@ -278,7 +279,7 @@ lex(void) if (lex_class & COMMENT) { while ((c = lexc()) != '\n') { if (lex_class & ENDOFFILE) - return AO_LISP_NIL; + return END; } continue; } @@ -364,6 +365,8 @@ static struct ao_lisp_cons *read_stack; static int push_read_stack(int cons, int in_quote) { + DBGI("push read stack %p %d\n", read_cons, in_quote); + DBG_IN(); if (cons) { read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), @@ -394,6 +397,8 @@ pop_read_stack(int cons) read_cons_tail = 0; read_stack = 0; } + DBG_OUT(); + DBGI("pop read stack %p %d\n", read_cons, in_quote); return in_quote; } @@ -413,6 +418,7 @@ ao_lisp_read(void) been_here = 1; } parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); cons = 0; in_quote = 0; @@ -424,12 +430,15 @@ ao_lisp_read(void) cons++; in_quote = 0; parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); } switch (parse_token) { - case ENDOFFILE: + case END: default: - v = AO_LISP_NIL; + if (cons) + ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); + return _ao_lisp_atom_eof; break; case NAME: atom = ao_lisp_atom_intern(token_string); @@ -490,6 +499,7 @@ ao_lisp_read(void) } parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); } return v; } diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index d780186a..ef7dbaf2 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -20,9 +20,8 @@ ao_lisp_read_eval_print(void) ao_poly in, out = AO_LISP_NIL; for(;;) { in = ao_lisp_read(); - if (!in) + if (in == _ao_lisp_atom_eof) break; -// printf ("in: "); ao_lisp_poly_print(in); printf("\n"); out = ao_lisp_eval(in); if (ao_lisp_exception) { ao_lisp_exception = 0; -- cgit v1.2.3 From 7da6bfc195fad97e3afc576c609897c131fd4d8c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 10 Nov 2016 23:29:21 -0800 Subject: altos/lisp: Deal with memory compation in the middle of operations Handle memory compaction in places where we've got pointers into the heap across an allocation operation. Either re-compute the values from managed global references or add new roots across the allocation. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 7 +-- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_cons.c | 8 ++- src/lisp/ao_lisp_eval.c | 59 +++++------------- src/lisp/ao_lisp_frame.c | 28 ++++++--- src/lisp/ao_lisp_lambda.c | 19 ++++-- src/lisp/ao_lisp_mem.c | 149 ++++++++++++++++++++++++---------------------- 7 files changed, 137 insertions(+), 135 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 6122a2ed..60a97f2c 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -510,8 +510,8 @@ ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num); -struct ao_lisp_frame * -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); +int +ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); void ao_lisp_frame_print(ao_poly p); @@ -538,8 +538,7 @@ ao_poly ao_lisp_macro(struct ao_lisp_cons *cons); ao_poly -ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, - struct ao_lisp_cons *cons); +ao_lisp_lambda_eval(void); /* error */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 5c6d5a67..efa4f621 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -147,7 +147,7 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val) if (ref) *ref = val; else - ao_lisp_frame_global = ao_lisp_frame_add(ao_lisp_frame_global, atom, val); + ao_lisp_frame_add(&ao_lisp_frame_global, atom, val); return val; } diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 855079b8..cd8a8d1d 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -67,7 +67,13 @@ const struct ao_lisp_type ao_lisp_cons_type = { struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { - struct ao_lisp_cons *cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + struct ao_lisp_cons *cons; + + ao_lisp_root_add(&ao_lisp_cons_type, &cdr); + ao_lisp_root_poly_add(&car); + cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + ao_lisp_root_clear(&car); + ao_lisp_root_clear(&cdr); if (!cons) return NULL; cons->car = car; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index c5addcb0..ae2436b8 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,7 @@ * General Public License for more details. */ -#define DBG_EVAL 1 +#define DBG_EVAL 0 #include "ao_lisp.h" #include @@ -46,19 +46,20 @@ stack_move(void *addr) struct ao_lisp_stack *stack = addr; while (stack) { - void *prev; + struct ao_lisp_stack *prev; int ret; (void) ao_lisp_poly_move(&stack->sexprs, 0); (void) ao_lisp_poly_move(&stack->values, 0); (void) ao_lisp_poly_move(&stack->values_tail, 0); (void) ao_lisp_poly_move(&stack->frame, 0); prev = ao_lisp_poly_stack(stack->prev); - ret = ao_lisp_move(&ao_lisp_stack_type, &prev); + ret = ao_lisp_move_memory((void **) &prev, + sizeof (struct ao_lisp_stack)); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); if (ret) break; - stack = ao_lisp_poly_stack(stack->prev); + stack = prev; } } @@ -101,8 +102,8 @@ ao_lisp_stack_push(void) ao_lisp_stack = stack; ao_lisp_stack_reset(stack); DBGI("stack push\n"); - DBG_IN(); DBG_FRAMES(); + DBG_IN(); return 1; } @@ -236,37 +237,11 @@ static int ao_lisp_eval_val(void) { DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); -#if 0 - if (ao_lisp_stack->macro) { - DBGI(".. end macro %d\n", ao_lisp_stack->macro); - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - ao_lisp_frames_dump(); - - ao_lisp_stack_pop(); -#if 0 - /* - * Re-use the current stack to evaluate - * the value from the macro - */ - ao_lisp_stack->state = eval_sexpr; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->macro_frame); - ao_lisp_stack->frame = ao_lisp_stack->macro_frame; - ao_lisp_stack->macro = 0; - ao_lisp_stack->macro_frame = AO_LISP_NIL; - ao_lisp_stack->sexprs = AO_LISP_NIL; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; -#endif - } else -#endif - { - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_lisp_stack_pop(); - } + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_lisp_stack_pop(); DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); return 1; } @@ -305,7 +280,6 @@ ao_lisp_eval_formal(void) break; case AO_LISP_FUNC_MACRO: /* Evaluate the result once more */ - prev = ao_lisp_stack; ao_lisp_stack->state = eval_sexpr; if (!ao_lisp_stack_push()) return 0; @@ -313,6 +287,7 @@ ao_lisp_eval_formal(void) /* After the function returns, take that * value and re-evaluate it */ + prev = ao_lisp_poly_stack(ao_lisp_stack->prev); ao_lisp_stack->state = eval_sexpr; ao_lisp_stack->sexprs = prev->sexprs; prev->sexprs = AO_LISP_NIL; @@ -400,8 +375,7 @@ ao_lisp_eval_exec(void) case AO_LISP_LAMBDA: ao_lisp_stack->state = eval_sexpr; DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_v = ao_lisp_lambda_eval(ao_lisp_poly_lambda(ao_lisp_v), - ao_lisp_poly_cons(ao_lisp_stack->values)); + ao_lisp_v = ao_lisp_lambda_eval(); DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; @@ -464,12 +438,11 @@ ao_lisp_eval_cond_test(void) struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); - ao_lisp_stack->state = eval_val; if (c) { + ao_lisp_stack->state = eval_sexpr; ao_lisp_v = c->car; - if (!ao_lisp_stack_push()) - return 0; - } + } else + ao_lisp_stack->state = eval_val; } else { ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 7978f20a..90344719 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -174,8 +174,9 @@ ao_lisp_frame_new(int num) } static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) +ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) { + struct ao_lisp_frame *frame = *frame_ref; struct ao_lisp_frame *new; int copy; @@ -184,34 +185,45 @@ ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) new = ao_lisp_frame_new(new_num); if (!new) return NULL; + /* + * Re-fetch the frame as it may have moved + * during the allocation + */ + frame = *frame_ref; 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; + 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) +int +ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) { + struct ao_lisp_frame *frame = *frame_ref; ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; + if (!ref) { int f; + ao_lisp_root_poly_add(&atom); + ao_lisp_root_poly_add(&val); if (frame) { f = frame->num; - frame = ao_lisp_frame_realloc(frame, f + 1); + frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; frame = ao_lisp_frame_new(1); } + ao_lisp_root_clear(&atom); + ao_lisp_root_clear(&val); if (!frame) - return NULL; + return 0; + *frame_ref = frame; 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; + return 1; } diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index cc5af4bc..8eafb187 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -133,18 +133,17 @@ ao_lisp_macro(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, - struct ao_lisp_cons *cons) +ao_lisp_lambda_eval(void) { - struct ao_lisp_cons *code; - struct ao_lisp_cons *args; + struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); + struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); struct ao_lisp_frame *next_frame; int args_wanted; int args_provided; - code = ao_lisp_poly_cons(lambda->code); DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); args_wanted = ao_lisp_cons_length(args); @@ -156,7 +155,15 @@ ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, args_provided = 1; if (args_wanted != args_provided) return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + next_frame = ao_lisp_frame_new(args_wanted); + + /* Re-fetch all of the values in case something moved */ + lambda = ao_lisp_poly_lambda(ao_lisp_v); + cons = ao_lisp_poly_cons(ao_lisp_stack->values); + code = ao_lisp_poly_cons(lambda->code); + args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + switch (lambda->args) { case AO_LISP_FUNC_LAMBDA: { int f; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 66e09db0..b763d78b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -28,32 +28,33 @@ uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); #endif #if 0 -#define DBG_COLLECT_ALWAYS +#define MDBG_COLLECT_ALWAYS #endif #if 0 -#define DBG_POOL +#define MDBG_POOL #endif #if 0 -#define DBG_INCLUDE -#define DBG_DUMP 0 -#define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) -#define DBG(...) printf(__VA_ARGS__) -#define DBG_DO(a) a -static int move_dump = 1; +#define MDBG_INCLUDE +#define MDBG_DUMP 1 +#define MDBG_MOVE 0 +#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) +#define MDBG(...) printf(__VA_ARGS__) +#define MDBG_DO(a) a +static int move_dump = MDBG_MOVE; 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--) +#define MDBG_RESET() (move_depth = 0) +#define MDBG_MOVE(...) do { if(move_dump) { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MOVE_IN() (move_depth++) +#define MDBG_MOVE_OUT() (move_depth--) #else -#define DBG(...) -#define DBG_DO(a) -#define DBG_RESET() -#define DBG_MOVE(...) -#define DBG_MOVE_IN() -#define DBG_MOVE_OUT() +#define MDBG(...) +#define MDBG_DO(a) +#define MDBG_RESET() +#define MDBG_MOVE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() #endif uint8_t ao_lisp_exception; @@ -69,7 +70,7 @@ static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; static uint8_t ao_lisp_busy[AO_LISP_POOL / 32]; static uint8_t ao_lisp_moving[AO_LISP_POOL / 32]; -static uint8_t ao_lisp_cons[AO_LISP_POOL / 32]; +static uint8_t ao_lisp_cons_note[AO_LISP_POOL / 32]; static uint8_t ao_lisp_cons_last[AO_LISP_POOL / 32]; static uint8_t ao_lisp_cons_noted; @@ -78,6 +79,7 @@ uint16_t ao_lisp_top; static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; + tag[byte] |= (1 << bit); } @@ -166,10 +168,11 @@ busy_object(uint8_t *tag, void *addr) { static void note_cons(void *addr) { - DBG_MOVE("note cons %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("note cons %d\n", MDBG_OFFSET(addr)); if (AO_LISP_IS_POOL(addr)) { + int offset = (uint8_t *) addr - ao_lisp_pool; ao_lisp_cons_noted = 1; - mark(ao_lisp_cons, (uint8_t *) addr - ao_lisp_pool); + mark(ao_lisp_cons_note, offset); } } @@ -182,11 +185,11 @@ move_object(void) { int i; - DBG_RESET(); - DBG_MOVE("move %d -> %d\n", DBG_OFFSET(move_old), DBG_OFFSET(move_new)); - DBG_MOVE_IN(); + MDBG_RESET(); + MDBG_MOVE("move %d -> %d\n", MDBG_OFFSET(move_old), MDBG_OFFSET(move_new)); + MDBG_MOVE_IN(); memset(ao_lisp_moving, '\0', sizeof (ao_lisp_moving)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_ROOT; i++) { if (!ao_lisp_root[i].addr) @@ -195,10 +198,10 @@ move_object(void) void *addr = *ao_lisp_root[i].addr; if (!addr) continue; - DBG_MOVE("root %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("root %d\n", MDBG_OFFSET(addr)); if (!ao_lisp_move(ao_lisp_root[i].type, ao_lisp_root[i].addr)) { - DBG_MOVE("root moves from %p to %p\n", + MDBG_MOVE("root moves from %p to %p\n", addr, *ao_lisp_root[i].addr); } @@ -207,31 +210,31 @@ move_object(void) if (!p) continue; if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr, 0)) { - DBG_MOVE("root poly move from %04x to %04x\n", + MDBG_MOVE("root poly move from %04x to %04x\n", p, *(ao_poly *) ao_lisp_root[i].addr); } } } while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons, sizeof (ao_lisp_cons)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_POOL; i += 4) { if (busy(ao_lisp_cons_last, i)) { void *addr = ao_lisp_pool + i; - DBG_MOVE("cons %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("cons %d\n", MDBG_OFFSET(addr)); if (!ao_lisp_move(&ao_lisp_cons_type, &addr)) { - DBG_MOVE("cons moves from %p to %p\n", + MDBG_MOVE("cons moves from %p to %p\n", ao_lisp_pool + i, addr); } } } } - DBG_MOVE_OUT(); - DBG_MOVE("move done\n"); + MDBG_MOVE_OUT(); + MDBG_MOVE("move done\n"); } -#if DBG_DUMP +#if MDBG_DUMP static void dump_busy(void) { @@ -272,32 +275,32 @@ ao_lisp_mark_busy(void) int i; memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; - DBG("mark\n"); + MDBG("mark\n"); for (i = 0; i < AO_LISP_ROOT; i++) { if (ao_lisp_root[i].type) { void **a = ao_lisp_root[i].addr, *v; if (a && (v = *a)) { - DBG("root %d\n", DBG_OFFSET(v)); + MDBG("root %d\n", MDBG_OFFSET(v)); ao_lisp_mark(ao_lisp_root[i].type, v); } } else { ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; if (a && (p = *a)) { - DBG("root 0x%04x\n", p); + MDBG("root 0x%04x\n", p); ao_lisp_poly_mark(p, 0); } } } while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons, sizeof (ao_lisp_cons)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_POOL; i += 4) { if (busy(ao_lisp_cons_last, i)) { void *v = ao_lisp_pool + i; - DBG("cons %d\n", DBG_OFFSET(v)); + MDBG("cons %d\n", MDBG_OFFSET(v)); ao_lisp_mark(&ao_lisp_cons_type, v); } } @@ -310,13 +313,13 @@ ao_lisp_collect(void) int i; int top; - DBG("collect\n"); + MDBG("collect\n"); /* Mark */ ao_lisp_mark_busy(); DUMP_BUSY(); /* Compact */ - DBG("find first busy\n"); + MDBG("find first busy\n"); for (i = 0; i < ao_lisp_top; i += 4) { if (!busy(ao_lisp_busy, i)) break; @@ -324,23 +327,25 @@ ao_lisp_collect(void) top = i; while(i < ao_lisp_top) { if (busy(ao_lisp_busy, i)) { - DBG("busy %d -> %d\n", i, top); + MDBG("busy %d -> %d\n", i, top); move_old = &ao_lisp_pool[i]; move_new = &ao_lisp_pool[top]; move_size = 0; move_object(); - DBG("\tbusy size %d\n", move_size); + MDBG("\tbusy size %d\n", move_size); if (move_size == 0) ao_lisp_abort(); clear_object(ao_lisp_busy, move_old, move_size); mark_object(ao_lisp_busy, move_new, move_size); - if (busy_object(ao_lisp_cons, move_old)) { - clear_object(ao_lisp_cons, move_old, move_size); - mark_object(ao_lisp_cons, move_new, move_size); + if (busy_object(ao_lisp_cons_note, move_old)) { + clear_object(ao_lisp_cons_note, move_old, move_size); + mark_object(ao_lisp_cons_note, move_new, move_size); } i += move_size; top += move_size; +#if MDBG_MOVE DUMP_BUSY(); +#endif } else { i += 4; } @@ -404,9 +409,9 @@ static void * check_move(void *addr, int size) { if (addr == move_old) { - DBG_MOVE("mapping %d -> %d\n", DBG_OFFSET(addr), DBG_OFFSET(move_new)); + MDBG_MOVE("mapping %d -> %d\n", MDBG_OFFSET(addr), MDBG_OFFSET(move_new)); if (!busy_object(ao_lisp_moving, addr)) { - DBG_MOVE(" copy %d\n", size); + MDBG_MOVE(" copy %d\n", size); memmove(move_new, move_old, size); move_size = (size + 3) & ~3; } @@ -429,24 +434,24 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) if (AO_LISP_IS_CONST(addr)) return 1; #endif - DBG_MOVE("object %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("object %d\n", MDBG_OFFSET(addr)); if (!AO_LISP_IS_POOL(a)) ao_lisp_abort(); - DBG_MOVE_IN(); + MDBG_MOVE_IN(); addr = check_move(addr, size); if (addr != *ref) *ref = addr; if (mark_object(ao_lisp_moving, addr, size)) { - DBG_MOVE("already moved\n"); - DBG_MOVE_OUT(); + MDBG_MOVE("already moved\n"); + MDBG_MOVE_OUT(); return 1; } - DBG_MOVE_OUT(); - DBG_MOVE("recursing...\n"); - DBG_MOVE_IN(); + MDBG_MOVE_OUT(); + MDBG_MOVE("recursing...\n"); + MDBG_MOVE_IN(); type->move(addr); - DBG_MOVE_OUT(); - DBG_MOVE("done %d\n", DBG_OFFSET(addr)); + MDBG_MOVE_OUT(); + MDBG_MOVE("done %d\n", MDBG_OFFSET(addr)); return 0; } @@ -457,17 +462,17 @@ ao_lisp_move_memory(void **ref, int size) if (!addr) return 1; - DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); - DBG_MOVE_IN(); + MDBG_MOVE("memory %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); addr = check_move(addr, size); if (addr != *ref) *ref = addr; if (mark_object(ao_lisp_moving, addr, size)) { - DBG_MOVE("already moved\n"); - DBG_MOVE_OUT(); + MDBG_MOVE("already moved\n"); + MDBG_MOVE_OUT(); return 1; } - DBG_MOVE_OUT(); + MDBG_MOVE_OUT(); return 0; } @@ -505,14 +510,14 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) if (addr != ao_lisp_ref(p)) { ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); - DBG("poly %d moved %04x -> %04x\n", + MDBG("poly %d moved %04x -> %04x\n", type, p, np); *ref = np; } return ret; } -#ifdef DBG_POOL +#ifdef MDBG_POOL static int AO_LISP_POOL_CUR = AO_LISP_POOL / 8; static void @@ -557,18 +562,18 @@ ao_lisp_alloc(int size) void *addr; size = ao_lisp_mem_round(size); -#ifdef DBG_COLLECT_ALWAYS +#ifdef MDBG_COLLECT_ALWAYS ao_lisp_collect(); #endif if (ao_lisp_top + size > AO_LISP_POOL_CUR) { -#ifdef DBG_POOL +#ifdef MDBG_POOL if (AO_LISP_POOL_CUR < AO_LISP_POOL) { AO_LISP_POOL_CUR += AO_LISP_POOL / 8; ao_lisp_poison(); } else #endif ao_lisp_collect(); -#ifdef DBG_POOL +#ifdef MDBG_POOL { int i; @@ -580,7 +585,7 @@ ao_lisp_alloc(int size) #endif if (ao_lisp_top + size > AO_LISP_POOL) { - ao_lisp_exception |= AO_LISP_OOM; + ao_lisp_error(AO_LISP_OOM, "out of memory"); return NULL; } } @@ -593,7 +598,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); + MDBG("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; -- cgit v1.2.3 From 7f7e2431f5d1f7c1782ed6e774ccfc70fb4c87cf Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 11 Nov 2016 00:28:31 -0800 Subject: altos/lisp: add length, pack, unpack and flush lots more builtins Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lisp_os.h | 6 +++++ src/lisp/ao_lisp.h | 17 ++++++++++++++ src/lisp/ao_lisp_builtin.c | 47 +++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_cons.c | 11 +++++++++ src/lisp/ao_lisp_lambda.c | 11 --------- src/lisp/ao_lisp_make_const.c | 4 ++++ src/lisp/ao_lisp_os.h | 5 ++++ src/lisp/ao_lisp_string.c | 52 +++++++++++++++++++++++++++++++++++++---- src/test/ao_lisp_os.h | 5 ++++ 9 files changed, 142 insertions(+), 16 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lambdakey-v1.0/ao_lisp_os.h b/src/lambdakey-v1.0/ao_lisp_os.h index df158f6a..1993ac44 100644 --- a/src/lambdakey-v1.0/ao_lisp_os.h +++ b/src/lambdakey-v1.0/ao_lisp_os.h @@ -35,6 +35,12 @@ ao_lisp_getc() { return c; } +static inline void +ao_lisp_os_flush(void) +{ + flush(); +} + static inline void ao_lisp_abort(void) { diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 60a97f2c..86a5ddcf 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -36,10 +36,14 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_cdr _atom("cdr") #define _ao_lisp_atom_cons _atom("cons") #define _ao_lisp_atom_last _atom("last") +#define _ao_lisp_atom_length _atom("length") #define _ao_lisp_atom_cond _atom("cond") #define _ao_lisp_atom_lambda _atom("lambda") #define _ao_lisp_atom_led _atom("led") #define _ao_lisp_atom_delay _atom("delay") +#define _ao_lisp_atom_pack _atom("pack") +#define _ao_lisp_atom_unpack _atom("unpack") +#define _ao_lisp_atom_flush _atom("flush") #define _ao_lisp_atom_eval _atom("eval") #define _ao_lisp_atom_read _atom("read") #define _ao_lisp_atom_eof _atom("eof") @@ -215,6 +219,7 @@ enum ao_lisp_builtin_id { builtin_cdr, builtin_cons, builtin_last, + builtin_length, builtin_quote, builtin_set, builtin_setq, @@ -233,6 +238,9 @@ enum ao_lisp_builtin_id { builtin_greater, builtin_less_equal, builtin_greater_equal, + builtin_pack, + builtin_unpack, + builtin_flush, builtin_delay, builtin_led, _builtin_last @@ -409,6 +417,9 @@ ao_lisp_cons_print(ao_poly); void ao_lisp_cons_patom(ao_poly); +int +ao_lisp_cons_length(struct ao_lisp_cons *cons); + /* string */ extern const struct ao_lisp_type ao_lisp_string_type; @@ -421,6 +432,12 @@ ao_lisp_string_copy(char *a); char * ao_lisp_string_cat(char *a, char *b); +ao_poly +ao_lisp_string_pack(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_string_unpack(char *a); + void ao_lisp_string_print(ao_poly s); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 57d9ee10..30631980 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -58,6 +58,7 @@ static const ao_poly builtin_names[] = { [builtin_cdr] = _ao_lisp_atom_cdr, [builtin_cons] = _ao_lisp_atom_cons, [builtin_last] = _ao_lisp_atom_last, + [builtin_length] = _ao_lisp_atom_length, [builtin_quote] = _ao_lisp_atom_quote, [builtin_set] = _ao_lisp_atom_set, [builtin_setq] = _ao_lisp_atom_setq, @@ -76,6 +77,9 @@ static const ao_poly builtin_names[] = { [builtin_greater] = _ao_lisp_atom_3e, [builtin_less_equal] = _ao_lisp_atom_3c3d, [builtin_greater_equal] = _ao_lisp_atom_3e3d, + [builtin_pack] = _ao_lisp_atom_pack, + [builtin_unpack] = _ao_lisp_atom_unpack, + [builtin_flush] = _ao_lisp_atom_flush, [builtin_delay] = _ao_lisp_atom_delay, [builtin_led] = _ao_lisp_atom_led, }; @@ -200,6 +204,16 @@ ao_lisp_last(struct ao_lisp_cons *cons) return AO_LISP_NIL; } +ao_poly +ao_lisp_length(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); +} + ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { @@ -470,6 +484,35 @@ ao_lisp_greater_equal(struct ao_lisp_cons *cons) return ao_lisp_compare(cons, builtin_greater_equal); } +ao_poly +ao_lisp_pack(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); +} + +ao_poly +ao_lisp_unpack(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) + return AO_LISP_NIL; + return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); +} + +ao_poly +ao_lisp_flush(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) + return AO_LISP_NIL; + ao_lisp_os_flush(); + return _ao_lisp_atom_t; +} + ao_poly ao_lisp_led(struct ao_lisp_cons *cons) { @@ -524,6 +567,7 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, [builtin_last] = ao_lisp_last, + [builtin_length] = ao_lisp_length, [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, @@ -542,6 +586,9 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_greater] = ao_lisp_greater, [builtin_less_equal] = ao_lisp_less_equal, [builtin_greater_equal] = ao_lisp_greater_equal, + [builtin_pack] = ao_lisp_pack, + [builtin_unpack] = ao_lisp_unpack, + [builtin_flush] = ao_lisp_flush, [builtin_led] = ao_lisp_led, [builtin_delay] = ao_lisp_delay, }; diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index cd8a8d1d..b75ffaa0 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -107,3 +107,14 @@ ao_lisp_cons_patom(ao_poly c) cons = ao_lisp_poly_cons(cons->cdr); } } + +int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 8eafb187..c53a38fd 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -49,17 +49,6 @@ const struct ao_lisp_type ao_lisp_lambda_type = { .move = lambda_move, }; -static int -ao_lisp_cons_length(struct ao_lisp_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); - } - return len; -} - void ao_lisp_lambda_print(ao_poly poly) { diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 4fc43e58..0b3e25a6 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -43,6 +43,7 @@ struct builtin_func funcs[] = { "cdr", AO_LISP_FUNC_LAMBDA, builtin_cdr, "cons", AO_LISP_FUNC_LAMBDA, builtin_cons, "last", AO_LISP_FUNC_LAMBDA, builtin_last, + "length", AO_LISP_FUNC_LAMBDA, builtin_length, "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, "set", AO_LISP_FUNC_LAMBDA, builtin_set, "setq", AO_LISP_FUNC_MACRO, builtin_setq, @@ -61,6 +62,9 @@ struct builtin_func funcs[] = { ">", AO_LISP_FUNC_LEXPR, builtin_greater, "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, + "pack", AO_LISP_FUNC_LAMBDA, builtin_pack, + "unpack", AO_LISP_FUNC_LAMBDA, builtin_unpack, + "flush", AO_LISP_FUNC_LAMBDA, builtin_flush, "delay", AO_LISP_FUNC_LAMBDA, builtin_delay, "led", AO_LISP_FUNC_LEXPR, builtin_led, }; diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h index 55ffed50..b7bf7a2c 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/lisp/ao_lisp_os.h @@ -27,6 +27,11 @@ ao_lisp_getc() { return getchar(); } +static inline void +ao_lisp_os_flush() { + fflush(stdout); +} + static inline void ao_lisp_abort(void) { diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 0064064c..9ee1a7dd 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -34,6 +34,12 @@ static void string_move(void *addr) (void) addr; } +const struct ao_lisp_type ao_lisp_string_type = { + .mark = string_mark, + .size = string_size, + .move = string_move, +}; + char * ao_lisp_string_new(int len) { char *a = ao_lisp_alloc(len + 1); @@ -68,11 +74,47 @@ ao_lisp_string_cat(char *a, char *b) return r; } -const struct ao_lisp_type ao_lisp_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, -}; +ao_poly +ao_lisp_string_pack(struct ao_lisp_cons *cons) +{ + int len = ao_lisp_cons_length(cons); + char *r = ao_lisp_alloc(len + 1); + char *s = r; + + while (cons) { + if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) + return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); + *s++ = ao_lisp_poly_int(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } + *s++ = 0; + return ao_lisp_string_poly(r); +} + +ao_poly +ao_lisp_string_unpack(char *a) +{ + struct ao_lisp_cons *cons = NULL, *tail = NULL; + int c; + + ao_lisp_root_add(&ao_lisp_cons_type, &cons); + ao_lisp_root_add(&ao_lisp_cons_type, &tail); + while ((c = *a++)) { + struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); + if (!n) { + cons = NULL; + break; + } + if (tail) + tail->cdr = ao_lisp_cons_poly(n); + else + cons = n; + tail = n; + } + ao_lisp_root_clear(&cons); + ao_lisp_root_clear(&tail); + return ao_lisp_cons_poly(cons); +} void ao_lisp_string_print(ao_poly p) diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h index 19bd4f64..c979697e 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_lisp_os.h @@ -24,6 +24,11 @@ extern int ao_lisp_getc(void); +static inline void +ao_lisp_os_flush() { + fflush(stdout); +} + static inline void ao_lisp_abort(void) { -- cgit v1.2.3 From d46ca67f93e9ecbc4d8c051c3fbdead85490b690 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 11 Nov 2016 21:07:09 -0800 Subject: altos/lisp: Make ao_lisp_ref and ao_lisp_poly non-inline These functions are pretty large and end up consuming quite a bit of space if inlined everywhere they are used. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 23 ++++------------------- src/lisp/ao_lisp_poly.c | 18 ++++++++++++++++++ 2 files changed, 22 insertions(+), 19 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 86a5ddcf..7a165cd8 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -99,26 +99,11 @@ ao_lisp_is_const(ao_poly poly) { #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 == 0xBEEF) - ao_lisp_abort(); - if (poly == AO_LISP_NIL) - return NULL; - if (poly & AO_LISP_CONST) - return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); - return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); -} +void * +ao_lisp_ref(ao_poly poly); -static inline ao_poly -ao_lisp_poly(const void *addr, ao_poly type) { - const uint8_t *a = addr; - if (a == NULL) - 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; -} +ao_poly +ao_lisp_poly(const void *addr, ao_poly type); struct ao_lisp_type { int (*size)(void *addr); diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index bfd75ae3..9717fd73 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -84,3 +84,21 @@ ao_lisp_poly_patom(ao_poly p) f->patom(p); } +void * +ao_lisp_ref(ao_poly poly) { + if (poly == AO_LISP_NIL) + return NULL; + if (poly & AO_LISP_CONST) + return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); + return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); +} + +ao_poly +ao_lisp_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (a == NULL) + 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; +} -- cgit v1.2.3 From dba374516ed396633659dec571b6a44b03da8ad1 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 11 Nov 2016 21:16:09 -0800 Subject: altos/lisp: Add save/restore infrastructure. Needs OS support to work. This sticks a few globals past the end of the heap and then asks the OS to save the heap. On restore, the heap is re-populated by the OS and then various global variables reset. Signed-off-by: Keith Packard --- src/lisp/Makefile | 1 + src/lisp/ao_lisp.h | 39 ++++++++++++++++++++++++++--- src/lisp/ao_lisp_builtin.c | 5 ++++ src/lisp/ao_lisp_eval.c | 18 ++++++++++++++ src/lisp/ao_lisp_make_const.c | 2 ++ src/lisp/ao_lisp_save.c | 57 +++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 119 insertions(+), 3 deletions(-) create mode 100644 src/lisp/ao_lisp_save.c (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index aa542021..dac11f66 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -20,6 +20,7 @@ SRCS=\ ao_lisp_lambda.c \ ao_lisp_eval.c \ ao_lisp_rep.c \ + ao_lisp_save.c \ ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 7a165cd8..44838a34 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -20,6 +20,26 @@ //#include #include +typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; + +#ifdef AO_LISP_SAVE + +struct ao_lisp_os_save { + ao_poly ao_lisp_atoms; + ao_poly ao_lisp_globals; +}; + +#define AO_LISP_POOL (AO_LISP_POOL_TOTAL - sizeof (struct ao_lisp_os_save)) + +int +ao_lisp_os_save(void); + +int +ao_lisp_os_restore(void); + +#endif + #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; @@ -85,9 +105,6 @@ extern uint16_t ao_lisp_top; extern uint8_t ao_lisp_exception; -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - static inline int ao_lisp_is_const(ao_poly poly) { return poly & AO_LISP_CONST; @@ -228,6 +245,8 @@ enum ao_lisp_builtin_id { builtin_flush, builtin_delay, builtin_led, + builtin_save, + builtin_restore, _builtin_last }; @@ -468,6 +487,12 @@ ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); /* eval */ +void +ao_lisp_eval_clear_globals(void); + +int +ao_lisp_eval_restart(void); + ao_poly ao_lisp_eval(ao_poly p); @@ -542,6 +567,14 @@ ao_lisp_macro(struct ao_lisp_cons *cons); ao_poly ao_lisp_lambda_eval(void); +/* save */ + +ao_poly +ao_lisp_save(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_restore(struct ao_lisp_cons *cons); + /* error */ void diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 30631980..ebc69f77 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -82,6 +82,9 @@ static const ao_poly builtin_names[] = { [builtin_flush] = _ao_lisp_atom_flush, [builtin_delay] = _ao_lisp_atom_delay, [builtin_led] = _ao_lisp_atom_led, + [builtin_save] = _ao_lisp_atom_save, + [builtin_restore] = _ao_lisp_atom_restore, + }; static char * @@ -591,5 +594,7 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_flush] = ao_lisp_flush, [builtin_led] = ao_lisp_led, [builtin_delay] = ao_lisp_delay, + [builtin_save] = ao_lisp_save, + [builtin_restore] = ao_lisp_restore, }; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 1c929869..f945bc16 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -546,6 +546,24 @@ static int (*const evals[])(void) = { [eval_while_test] = ao_lisp_eval_while_test, }; +/* + * Called at restore time to reset all execution state + */ + +void +ao_lisp_eval_clear_globals(void) +{ + ao_lisp_stack = NULL; + ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; +} + +int +ao_lisp_eval_restart(void) +{ + return ao_lisp_stack_push(); +} + ao_poly ao_lisp_eval(ao_poly _v) { diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 0b3e25a6..0a8c9d07 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -67,6 +67,8 @@ struct builtin_func funcs[] = { "flush", AO_LISP_FUNC_LAMBDA, builtin_flush, "delay", AO_LISP_FUNC_LAMBDA, builtin_delay, "led", AO_LISP_FUNC_LEXPR, builtin_led, + "save", AO_LISP_FUNC_LAMBDA, builtin_save, + "restore", AO_LISP_FUNC_LAMBDA, builtin_restore, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c new file mode 100644 index 00000000..2b19fdcb --- /dev/null +++ b/src/lisp/ao_lisp_save.c @@ -0,0 +1,57 @@ +/* + * 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_poly +ao_lisp_save(struct ao_lisp_cons *cons) +{ +#ifdef AO_LISP_SAVE + struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) &ao_lisp_pool[AO_LISP_POOL]; + + ao_lisp_collect(); + os->ao_lisp_atoms = ao_lisp_atom_poly(ao_lisp_atoms); + os->ao_lisp_globals = ao_lisp_frame_poly(ao_lisp_frame_global); + if (ao_lisp_os_save()) + return _ao_lisp_atom_t; +#endif + return AO_LISP_NIL; +} + +ao_poly +ao_lisp_restore(struct ao_lisp_cons *cons) +{ +#ifdef AO_LISP_SAVE + struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) &ao_lisp_pool[AO_LISP_POOL]; + + if (ao_lisp_os_restore()) { + + ao_lisp_atoms = ao_lisp_poly_atom(os->ao_lisp_atoms); + ao_lisp_frame_global = ao_lisp_poly_frame(os->ao_lisp_globals); + + /* Clear the eval global variabls */ + ao_lisp_eval_clear_globals(); + + /* Reset the allocator */ + ao_lisp_top = AO_LISP_POOL; + ao_lisp_collect(); + + /* Re-create the evaluator stack */ + if (!ao_lisp_eval_restart()) + return AO_LISP_NIL; + return _ao_lisp_atom_t; + } +#endif + return AO_LISP_NIL; +} -- cgit v1.2.3 From 33aeffc123af1f9063969acf585f1caac885ced4 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 11 Nov 2016 23:34:54 -0800 Subject: altos/lisp: Append a CRC to the saved image to validate on restore The CRC is actually of the ROM bits, so we can tell if the restored image relates to the currently running code. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lisp_os_save.c | 53 ++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp.h | 18 ++++++++---- src/lisp/ao_lisp_make_const.c | 28 +++++++++++++++++++ src/lisp/ao_lisp_mem.c | 2 +- src/lisp/ao_lisp_save.c | 27 +++++++++++++++--- src/test/ao_lisp_test.c | 18 ++++++++++++ src/test/hanoi.lisp | 8 ------ 7 files changed, 136 insertions(+), 18 deletions(-) create mode 100644 src/lambdakey-v1.0/ao_lisp_os_save.c (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lambdakey-v1.0/ao_lisp_os_save.c b/src/lambdakey-v1.0/ao_lisp_os_save.c new file mode 100644 index 00000000..44138398 --- /dev/null +++ b/src/lambdakey-v1.0/ao_lisp_os_save.c @@ -0,0 +1,53 @@ +/* + * 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 +#include +#include + +extern uint8_t __flash__[]; + +/* saved variables to rebuild the heap + + ao_lisp_atoms + ao_lisp_frame_global + */ + +int +ao_lisp_os_save(void) +{ + int i; + + for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { + uint32_t *dst = (uint32_t *) &__flash__[i]; + uint32_t *src = (uint32_t *) &ao_lisp_pool[i]; + + ao_flash_page(dst, src); + } + return 1; +} + +int +ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) +{ + memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); + return 1; +} + +int +ao_lisp_os_restore(void) +{ + memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); + return 1; +} diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 44838a34..ea3d2a09 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -26,15 +26,21 @@ typedef int16_t ao_signed_poly; #ifdef AO_LISP_SAVE struct ao_lisp_os_save { - ao_poly ao_lisp_atoms; - ao_poly ao_lisp_globals; + ao_poly atoms; + ao_poly globals; + uint16_t const_checksum; + uint16_t const_checksum_inv; }; -#define AO_LISP_POOL (AO_LISP_POOL_TOTAL - sizeof (struct ao_lisp_os_save)) +#define AO_LISP_POOL_EXTRA (sizeof(struct ao_lisp_os_save)) +#define AO_LISP_POOL ((int) (AO_LISP_POOL_TOTAL - AO_LISP_POOL_EXTRA)) int ao_lisp_os_save(void); +int +ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset); + int ao_lisp_os_restore(void); @@ -67,12 +73,14 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_eval _atom("eval") #define _ao_lisp_atom_read _atom("read") #define _ao_lisp_atom_eof _atom("eof") +#define _ao_lisp_atom_save _atom("save") +#define _ao_lisp_atom_restore _atom("restore") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL -#define AO_LISP_POOL 16384 +#define AO_LISP_POOL 3072 #endif -extern uint8_t ao_lisp_pool[AO_LISP_POOL]; +extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA]; #endif /* Primitive types */ diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 0a8c9d07..6a29f402 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -86,6 +86,33 @@ is_atom(int offset) return 0; } +#define AO_FEC_CRC_INIT 0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ + uint8_t bit; + + for (bit = 0; bit < 8; bit++) { + if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) + crc = (crc << 1) ^ 0x8005; + else + crc = (crc << 1); + byte <<= 1; + } + return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ + uint16_t crc = AO_FEC_CRC_INIT; + + while (len--) + crc = ao_fec_crc_byte(*bytes++, crc); + return crc; +} + int main(int argc, char **argv) { @@ -126,6 +153,7 @@ main(int argc, char **argv) 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(ao_lisp_frame_global)); + printf("#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 31ee9e1e..0373f015 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -24,7 +24,7 @@ uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #undef AO_LISP_POOL #define AO_LISP_POOL AO_LISP_POOL_CONST #else -uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); +uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); #endif #if 0 diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index 2b19fdcb..030846b7 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -17,12 +17,18 @@ ao_poly ao_lisp_save(struct ao_lisp_cons *cons) { + if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) + return AO_LISP_NIL; + #ifdef AO_LISP_SAVE struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) &ao_lisp_pool[AO_LISP_POOL]; ao_lisp_collect(); - os->ao_lisp_atoms = ao_lisp_atom_poly(ao_lisp_atoms); - os->ao_lisp_globals = ao_lisp_frame_poly(ao_lisp_frame_global); + os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); + os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); + os->const_checksum = ao_lisp_const_checksum; + os->const_checksum_inv = ~ao_lisp_const_checksum; + if (ao_lisp_os_save()) return _ao_lisp_atom_t; #endif @@ -32,13 +38,26 @@ ao_lisp_save(struct ao_lisp_cons *cons) ao_poly ao_lisp_restore(struct ao_lisp_cons *cons) { + if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) + return AO_LISP_NIL; + #ifdef AO_LISP_SAVE + struct ao_lisp_os_save save; struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) &ao_lisp_pool[AO_LISP_POOL]; + if (!ao_lisp_os_restore_save(&save, AO_LISP_POOL)) + return ao_lisp_error(AO_LISP_INVALID, "header restore failed"); + + if (save.const_checksum != ao_lisp_const_checksum || + save.const_checksum_inv != (uint16_t) ~ao_lisp_const_checksum) + { + return ao_lisp_error(AO_LISP_INVALID, "image is corrupted or stale"); + } + if (ao_lisp_os_restore()) { - ao_lisp_atoms = ao_lisp_poly_atom(os->ao_lisp_atoms); - ao_lisp_frame_global = ao_lisp_poly_frame(os->ao_lisp_globals); + ao_lisp_atoms = ao_lisp_poly_atom(os->atoms); + ao_lisp_frame_global = ao_lisp_poly_frame(os->globals); /* Clear the eval global variabls */ ao_lisp_eval_clear_globals(); diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 41dae07a..648d1abe 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -34,6 +34,24 @@ ao_lisp_os_save(void) return 1; } +int +ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + fseek(restore, offset, SEEK_SET); + ret = fread(save, sizeof (struct ao_lisp_os_save), 1, restore); + fclose(restore); + if (ret != 1) + return 0; + return 1; +} + int ao_lisp_os_restore(void) { diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index 01398d91..2b614829 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -6,19 +6,11 @@ (patom "\033[2J" nil) ) -(defun test () - (clear) - (move-to 30 12) - (patom "hello, world") - (move-to 0 19) - ) - (setq stack '("*" "**" "***" "****" "*****" "******" "*******")) (setq stacks nil) (defun display-string (x y str) - (move-to x y) (move-to x y) (patom str) ) -- cgit v1.2.3 From ddb4b8d90478ae324aa207a7541352c1ac9451ee Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 14 Nov 2016 18:45:12 -0800 Subject: altos/lisp: Change GC to do moves in batches of 32 This should make it quite a bit faster than doing one at a time. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 69 ++++- src/lisp/ao_lisp_atom.c | 14 +- src/lisp/ao_lisp_cons.c | 32 +- src/lisp/ao_lisp_eval.c | 21 +- src/lisp/ao_lisp_frame.c | 48 +-- src/lisp/ao_lisp_lambda.c | 3 + src/lisp/ao_lisp_mem.c | 745 ++++++++++++++++++++++++++++++++-------------- src/lisp/ao_lisp_read.c | 64 ++-- src/lisp/ao_lisp_string.c | 33 +- 9 files changed, 674 insertions(+), 355 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index ea3d2a09..906bae19 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -134,6 +134,7 @@ struct ao_lisp_type { int (*size)(void *addr); void (*mark)(void *addr); void (*move)(void *addr); + char name[]; }; struct ao_lisp_cons { @@ -304,11 +305,17 @@ ao_lisp_other_poly(const void *other) } static inline int -ao_lisp_mem_round(int size) +ao_lisp_size_round(int size) { return (size + 3) & ~3; } +static inline int +ao_lisp_size(const struct ao_lisp_type *type, void *addr) +{ + return ao_lisp_size_round(type->size(addr)); +} + #define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) static inline int ao_lisp_poly_base_type(ao_poly poly) { @@ -389,7 +396,7 @@ ao_lisp_mark(const struct ao_lisp_type *type, void *addr); /* returns 1 if the object was already marked */ int -ao_lisp_mark_memory(void *addr, int size); +ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); void * ao_lisp_move_map(void *addr); @@ -400,7 +407,7 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref); /* returns 1 if the object was already moved */ int -ao_lisp_move_memory(void **ref, int size); +ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); void * ao_lisp_alloc(int size); @@ -408,14 +415,23 @@ ao_lisp_alloc(int size); void ao_lisp_collect(void); -int -ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); +void +ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); -int -ao_lisp_root_poly_add(ao_poly *p); +struct ao_lisp_cons * +ao_lisp_cons_fetch(int id); void -ao_lisp_root_clear(void *addr); +ao_lisp_string_stash(int id, char *string); + +char * +ao_lisp_string_fetch(int id); + +void +ao_lisp_poly_stash(int id, ao_poly poly); + +ao_poly +ao_lisp_poly_fetch(int id); /* cons */ extern const struct ao_lisp_type ao_lisp_cons_type; @@ -435,9 +451,6 @@ ao_lisp_cons_length(struct ao_lisp_cons *cons); /* string */ extern const struct ao_lisp_type ao_lisp_string_type; -char * -ao_lisp_string_new(int len); - char * ao_lisp_string_copy(char *a); @@ -529,6 +542,10 @@ char * ao_lisp_args_name(uint8_t args); /* read */ +extern struct ao_lisp_cons *ao_lisp_read_cons; +extern struct ao_lisp_cons *ao_lisp_read_cons_tail; +extern struct ao_lisp_cons *ao_lisp_read_stack; + ao_poly ao_lisp_read(void); @@ -585,6 +602,8 @@ ao_lisp_restore(struct ao_lisp_cons *cons); /* error */ +extern const struct ao_lisp_type ao_lisp_stack_type; + void ao_lisp_stack_print(void); @@ -631,4 +650,32 @@ ao_lisp_frames_dump(void) #define DBG_FRAMES() #endif +#define DBG_MEM 1 +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) + +extern int dbg_mem; + +#define MDBG_DO(a) a +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN() (dbg_move_depth++) +#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index e1d9b082..6705f140 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -38,7 +38,7 @@ static void atom_mark(void *addr) atom = ao_lisp_poly_atom(atom->next); if (!atom) break; - if (ao_lisp_mark_memory(atom, atom_size(atom))) + if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) break; } } @@ -53,7 +53,7 @@ static void atom_move(void *addr) if (!next) break; - ret = ao_lisp_move_memory((void **) &next, atom_size(next)); + ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); if (next != ao_lisp_poly_atom(atom->next)) atom->next = ao_lisp_atom_poly(next); if (ret) @@ -66,6 +66,7 @@ const struct ao_lisp_type ao_lisp_atom_type = { .mark = atom_mark, .size = atom_size, .move = atom_move, + .name = "atom" }; struct ao_lisp_atom *ao_lisp_atoms; @@ -85,12 +86,12 @@ ao_lisp_atom_intern(char *name) return atom; } #endif + ao_lisp_string_stash(0, name); atom = ao_lisp_alloc(name_size(name)); + name = ao_lisp_string_fetch(0); 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); } @@ -103,11 +104,8 @@ struct ao_lisp_frame *ao_lisp_frame_current; static void ao_lisp_atom_init(void) { - if (!ao_lisp_frame_global) { + if (!ao_lisp_frame_global) ao_lisp_frame_global = ao_lisp_frame_new(0); - ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global); - ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current); - } } static ao_poly * diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index c7d8382f..311d63ab 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -14,8 +14,6 @@ #include "ao_lisp.h" -#define OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_const)) - static void cons_mark(void *addr) { struct ao_lisp_cons *cons = addr; @@ -25,7 +23,7 @@ static void cons_mark(void *addr) cons = ao_lisp_poly_cons(cons->cdr); if (!cons) break; - if (ao_lisp_mark_memory(cons, sizeof (struct ao_lisp_cons))) + if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) break; } } @@ -47,13 +45,17 @@ static void cons_move(void *addr) struct ao_lisp_cons *cdr; int ret; + MDBG_MOVE("cons_move start %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); (void) ao_lisp_poly_move(&cons->car, 1); cdr = ao_lisp_poly_cons(cons->cdr); if (!cdr) break; - ret = ao_lisp_move_memory((void **) &cdr, sizeof (struct ao_lisp_cons)); + ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); if (cdr != ao_lisp_poly_cons(cons->cdr)) cons->cdr = ao_lisp_cons_poly(cdr); + MDBG_MOVE("cons_move end %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); if (ret) break; cons = cdr; @@ -64,31 +66,23 @@ const struct ao_lisp_type ao_lisp_cons_type = { .mark = cons_mark, .size = cons_size, .move = cons_move, + .name = "cons", }; -static ao_poly cons_car; -static struct ao_lisp_cons *cons_cdr; -static int been_here; - struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { struct ao_lisp_cons *cons; - if (!been_here) { - ao_lisp_root_add(&ao_lisp_cons_type, &cons_cdr); - ao_lisp_root_poly_add(&cons_car); - been_here = 1; - } - cons_car = car; - cons_cdr = cdr; + ao_lisp_poly_stash(0, car); + ao_lisp_cons_stash(0, cdr); cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + car = ao_lisp_poly_fetch(0); + cdr = ao_lisp_cons_fetch(0); if (!cons) return NULL; - cons->car = cons_car; - cons->cdr = ao_lisp_cons_poly(cons_cdr); - cons_car = AO_LISP_NIL; - cons_cdr = NULL; + cons->car = car; + cons->cdr = ao_lisp_cons_poly(cdr); return cons; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index f945bc16..04d0e70a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -16,6 +16,8 @@ #include "ao_lisp.h" #include +const struct ao_lisp_type ao_lisp_stack_type; + static int stack_size(void *addr) { @@ -34,13 +36,11 @@ stack_mark(void *addr) ao_lisp_poly_mark(stack->frame, 0); ao_lisp_poly_mark(stack->list, 0); stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) + if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) break; } } -static const struct ao_lisp_type ao_lisp_stack_type; - static void stack_move(void *addr) { @@ -57,8 +57,7 @@ stack_move(void *addr) prev = ao_lisp_poly_stack(stack->prev); if (!prev) break; - ret = ao_lisp_move_memory((void **) &prev, - sizeof (struct ao_lisp_stack)); + ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); if (ret) @@ -67,10 +66,11 @@ stack_move(void *addr) } } -static const struct ao_lisp_type ao_lisp_stack_type = { +const struct ao_lisp_type ao_lisp_stack_type = { .size = stack_size, .mark = stack_mark, - .move = stack_move + .move = stack_move, + .name = "stack" }; struct ao_lisp_stack *ao_lisp_stack; @@ -567,14 +567,7 @@ ao_lisp_eval_restart(void) ao_poly ao_lisp_eval(ao_poly _v) { - static uint8_t been_here; - ao_lisp_v = _v; - if (!been_here) { - been_here = 1; - ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack); - ao_lisp_root_poly_add(&ao_lisp_v); - } if (!ao_lisp_stack_push()) return AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 082860ee..e23a6413 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -14,12 +14,6 @@ #include "ao_lisp.h" -#if 0 -#define DBG(...) printf(__VA_ARGS__) -#else -#define DBG(...) -#endif - static inline int frame_num_size(int num) { @@ -33,8 +27,6 @@ frame_size(void *addr) return frame_num_size(frame->num); } -#define OFFSET(a) ((int) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const)) - static void frame_mark(void *addr) { @@ -42,22 +34,23 @@ frame_mark(void *addr) int f; for (;;) { - DBG("frame mark %p\n", frame); + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); - 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); + MDBG_MOVE("frame mark atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); } frame = ao_lisp_poly_frame(frame->next); - DBG("frame next %p\n", frame); + MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) break; - if (ao_lisp_mark_memory(frame, frame_size(frame))) + if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) break; } } @@ -72,22 +65,29 @@ frame_move(void *addr) struct ao_lisp_frame *next; int ret; - DBG("frame move %p\n", frame); + MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); - DBG("moved atom %s\n", ao_lisp_poly_atom(v->atom)->name); ao_lisp_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); } next = ao_lisp_poly_frame(frame->next); if (!next) break; - ret = ao_lisp_move_memory((void **) &next, frame_size(next)); - if (next != ao_lisp_poly_frame(frame->next)) + ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &next); + if (next != ao_lisp_poly_frame(frame->next)) { + MDBG_MOVE("frame next moved from %d to %d\n", + MDBG_OFFSET(ao_lisp_poly_frame(frame->next)), + MDBG_OFFSET(next)); frame->next = ao_lisp_frame_poly(next); + } if (ret) break; frame = next; @@ -97,7 +97,8 @@ frame_move(void *addr) const struct ao_lisp_type ao_lisp_frame_type = { .mark = frame_mark, .size = frame_size, - .move = frame_move + .move = frame_move, + .name = "frame", }; void @@ -206,8 +207,8 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) if (!ref) { int f; - ao_lisp_root_poly_add(&atom); - ao_lisp_root_poly_add(&val); + ao_lisp_poly_stash(0, atom); + ao_lisp_poly_stash(1, val); if (frame) { f = frame->num; frame = ao_lisp_frame_realloc(frame_ref, f + 1); @@ -215,12 +216,11 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) f = 0; frame = ao_lisp_frame_new(1); } - ao_lisp_root_clear(&atom); - ao_lisp_root_clear(&val); + atom = ao_lisp_poly_fetch(0); + val = ao_lisp_poly_fetch(1); if (!frame) return 0; *frame_ref = frame; - 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; } diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index c53a38fd..6020a8b8 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -47,6 +47,7 @@ const struct ao_lisp_type ao_lisp_lambda_type = { .size = lambda_size, .mark = lambda_mark, .move = lambda_move, + .name = "lambda", }; void @@ -68,7 +69,9 @@ ao_lisp_lambda_print(ao_poly poly) ao_poly ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) { + ao_lisp_cons_stash(0, code); struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + code = ao_lisp_cons_fetch(0); struct ao_lisp_cons *arg; int f; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 0373f015..60f4bbee 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -18,64 +18,243 @@ #include #ifdef AO_LISP_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + #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 + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); -#endif -#if 0 -#define MDBG_COLLECT_ALWAYS #endif #if 0 #define MDBG_POOL #endif -#if 0 -#include -#define MDBG_INCLUDE -#if 1 -#define MDBG_MOVE(...) do { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } while (0) -#endif -#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) -#define MDBG(...) printf(__VA_ARGS__) -#define MDBG_DO(a) a -static int move_depth; -#define MDBG_MOVE_IN() (move_depth++) -#define MDBG_MOVE_OUT() (assert(--move_depth >= 0)) +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_collects = 0; +int dbg_validate = 0; + +struct ao_lisp_record { + struct ao_lisp_record *next; + const struct ao_lisp_type *type; + void *addr; + int size; +}; + +static struct ao_lisp_record *record_head, **record_tail; + +static void +ao_lisp_record_free(struct ao_lisp_record *record) +{ + while (record) { + struct ao_lisp_record *next = record->next; + free(record); + record = next; + } +} + +static void +ao_lisp_record_reset(void) +{ + ao_lisp_record_free(record_head); + record_head = NULL; + record_tail = &record_head; +} + +static void +ao_lisp_record(const struct ao_lisp_type *type, + void *addr, + int size) +{ + struct ao_lisp_record *r = malloc(sizeof (struct ao_lisp_record)); + + r->next = NULL; + r->type = type; + r->addr = addr; + r->size = size; + *record_tail = r; + record_tail = &r->next; +} + +static struct ao_lisp_record * +ao_lisp_record_save(void) +{ + struct ao_lisp_record *r = record_head; + + record_head = NULL; + record_tail = &record_head; + return r; +} + +static void +ao_lisp_record_compare(char *where, + struct ao_lisp_record *a, + struct ao_lisp_record *b) +{ + while (a && b) { + if (a->type != b->type || a->size != b->size) { + printf("%s record difers %d %s %d -> %d %s %d\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_lisp_abort(); + } + a = a->next; + b = b->next; + } + if (a) { + printf("%s record differs %d %s %d -> NULL\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size); + ao_lisp_abort(); + } + if (b) { + printf("%s record differs NULL -> %d %s %d\n", + where, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_lisp_abort(); + } +} + #else -#define MDBG(...) -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() +#define ao_lisp_record_reset() #endif uint8_t ao_lisp_exception; struct ao_lisp_root { - void **addr; const struct ao_lisp_type *type; + void **addr; }; -#define AO_LISP_ROOT 16 +static struct ao_lisp_cons *save_cons[2]; +static char *save_string[2]; +static ao_poly save_poly[2]; + +static const struct ao_lisp_root ao_lisp_root[] = { + { + .type = &ao_lisp_cons_type, + .addr = (void **) &save_cons[0], + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &save_cons[1], + }, + { + .type = &ao_lisp_string_type, + .addr = (void **) &save_string[0] + }, + { + .type = &ao_lisp_string_type, + .addr = (void **) &save_string[1] + }, + { + .type = NULL, + .addr = (void **) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) &save_poly[1] + }, + { + .type = &ao_lisp_atom_type, + .addr = (void **) &ao_lisp_atoms + }, + { + .type = &ao_lisp_frame_type, + .addr = (void **) &ao_lisp_frame_global, + }, + { + .type = &ao_lisp_frame_type, + .addr = (void **) &ao_lisp_frame_current, + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &ao_lisp_stack, + }, + { + .type = NULL, + .addr = (void **) &ao_lisp_v, + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &ao_lisp_read_cons, + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &ao_lisp_read_cons_tail, + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &ao_lisp_read_stack, + }, +}; -static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; +#define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) #define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_moving[AO_LISP_BUSY_SIZE]; static uint8_t ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; static uint8_t ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; static uint8_t ao_lisp_cons_noted; uint16_t ao_lisp_top; +struct ao_lisp_chunk { + uint16_t old_addr; + union { + uint16_t size; + uint16_t new_addr; + }; +}; + +#define AO_LISP_NCHUNK 32 + +static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { + if (!AO_LISP_IS_POOL(addr)) + ao_lisp_abort(); + return ((uint8_t *) addr) - ao_lisp_pool; +} + +/* + * Convert back and forth between 'poly's used + * as short addresses in the pool and addresses. + * These are used in the chunk code. + */ +static inline ao_poly pool_poly(void *addr) { + if (!AO_LISP_IS_POOL(addr)) + ao_lisp_abort(); + return ((uint8_t *) addr) - AO_LISP_POOL_BASE; +} + +static inline void *pool_ref(ao_poly p) { + return AO_LISP_POOL_BASE + p; +} + static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; @@ -101,24 +280,28 @@ static inline int limit(int offset) { return min(AO_LISP_POOL, max(offset, 0)); } +static int total_marked; + +/* + * Mark a range of addresses + */ static int mark_object(uint8_t *tag, void *addr, int size) { int base; int bound; - if (!addr) - return 1; + MDBG_DO(if (!AO_LISP_IS_POOL((uint8_t *) addr + size - 1)) + ao_lisp_abort()); - 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 = pool_offset(addr); bound = base + size; - base = limit(base); - bound = limit(bound); + MDBG_DO(if (bound > ao_lisp_top) ao_lisp_abort()); + if (busy(tag, base)) return 1; + if (tag == ao_lisp_busy) + total_marked += size; while (base < bound) { mark(tag, base); base += 4; @@ -126,12 +309,14 @@ mark_object(uint8_t *tag, void *addr, int size) { return 0; } +MDBG_DO( static int clear_object(uint8_t *tag, void *addr, int size) { int base; int bound; - if (!addr) - return 1; + + MDBG_DO(if (!AO_LISP_IS_POOL((uint8_t *) addr + size - 1)) + ao_lisp_abort()); base = (uint8_t *) addr - ao_lisp_pool; bound = base + size; @@ -140,29 +325,13 @@ clear_object(uint8_t *tag, void *addr, int size) { bound = limit(bound); if (!busy(tag, base)) return 1; + total_marked -= size; while (base < bound) { clear(tag, base); base += 4; } 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 note_cons(void *addr) @@ -175,31 +344,63 @@ note_cons(void *addr) } } +static uint16_t chunk_low; +static uint16_t chunk_first, chunk_last; + +static void +note_chunk(uint16_t addr, uint16_t size) +{ + int i; + + if (addr < chunk_low) + return; + + for (i = 0; i < AO_LISP_NCHUNK; i++) { + if (ao_lisp_chunk[i].size && ao_lisp_chunk[i].old_addr == addr) { + if (ao_lisp_chunk[i].size != size) + ao_lisp_abort(); + return; + } + if (ao_lisp_chunk[i].old_addr > addr) { + memmove(&ao_lisp_chunk[i+1], + &ao_lisp_chunk[i], + (AO_LISP_NCHUNK - (i+1)) * sizeof (struct ao_lisp_chunk)); + ao_lisp_chunk[i].size = 0; + } + if (ao_lisp_chunk[i].size == 0) { + ao_lisp_chunk[i].old_addr = addr; + ao_lisp_chunk[i].size = size; + return; + } + } +} + /* * Walk all referenced objects calling functions on each one */ static void -walk(uint8_t *tag, - int (*visit_addr)(const struct ao_lisp_type *type, void **addr), +walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) { int i; - memset(tag, '\0', sizeof (ao_lisp_busy)); + total_marked = 0; + ao_lisp_record_reset(); + memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_ROOT; i++) { if (ao_lisp_root[i].type) { void **a = ao_lisp_root[i].addr, *v; if (a && (v = *a)) { - MDBG("root ptr %d\n", MDBG_OFFSET(v)); + MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); visit_addr(ao_lisp_root[i].type, a); } } else { ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; if (a && (p = *a)) { - MDBG("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); + MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); visit_poly(a, 0); } } @@ -211,33 +412,32 @@ walk(uint8_t *tag, for (i = 0; i < AO_LISP_POOL; i += 4) { if (busy(ao_lisp_cons_last, i)) { void *v = ao_lisp_pool + i; - MDBG("root cons %d\n", MDBG_OFFSET(v)); + MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); visit_addr(&ao_lisp_cons_type, &v); } } } } -static void *move_old, *move_new; -static int move_size; - #if MDBG_DUMP static void dump_busy(void) { int i; - printf("busy:"); + MDBG_MOVE("busy:"); for (i = 0; i < ao_lisp_top; i += 4) { - if ((i & 0xff) == 0) - printf("\n"); + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } else if ((i & 0x1f) == 0) - printf(" "); + MDBG_MORE(" "); if (busy(ao_lisp_busy, i)) - putchar('*'); + MDBG_MORE("*"); else - putchar('-'); + MDBG_MORE("-"); } - printf ("\n"); + MDBG_MORE ("\n"); } #define DUMP_BUSY() dump_busy() #else @@ -272,183 +472,241 @@ ao_lisp_collect(void) { int i; int top; +#if DBG_MEM + int loops = 0; + int marked; + int moved; + struct ao_lisp_record *mark_record = NULL, *move_record = NULL; + + ++dbg_collects; + MDBG_MOVE("collect %d\n", dbg_collects); + marked = moved = 0; +#endif + chunk_low = 0; + top = 0; + for (;;) { + MDBG_DO(loops++); + MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); + /* Find the sizes of the first chunk of objects to move */ + memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); +#if DBG_MEM + marked = total_marked; + + ao_lisp_record_free(mark_record); + mark_record = ao_lisp_record_save(); + if (mark_record && move_record) + ao_lisp_record_compare("mark", move_record, mark_record); + + if (moved && moved != marked) + ao_lisp_abort(); +#endif - MDBG("collect\n"); - /* Mark */ - walk(ao_lisp_busy, ao_lisp_mark_ref, ao_lisp_poly_mark_ref); + DUMP_BUSY(); - DUMP_BUSY(); - /* Compact */ - MDBG("find first busy\n"); - for (i = 0; i < ao_lisp_top; i += 4) { - if (!busy(ao_lisp_busy, i)) - break; - } - top = i; - while(i < ao_lisp_top) { - if (busy(ao_lisp_busy, i)) { - MDBG("busy %d -> %d\n", i, top); - MDBG_MOVE_IN(); - move_old = &ao_lisp_pool[i]; - move_new = &ao_lisp_pool[top]; - move_size = 0; - walk(ao_lisp_moving, ao_lisp_move, ao_lisp_poly_move); - MDBG("\tbusy size %d\n", move_size); - if (move_size == 0) + /* Find the first moving object */ + for (i = 0; i < AO_LISP_NCHUNK; i++) { + uint16_t size = ao_lisp_chunk[i].size; + + if (!size) + break; + + if (ao_lisp_chunk[i].old_addr > top) + break; + if (ao_lisp_chunk[i].old_addr != top) + ao_lisp_abort(); + + top += size; + MDBG_MOVE("chunk %d %d not moving\n", + ao_lisp_chunk[i].old_addr, + ao_lisp_chunk[i].size); + chunk_low = ao_lisp_chunk[i].old_addr + size; + } + + chunk_first = i; + /* Copy all of the objects */ + for (; i < AO_LISP_NCHUNK; i++) { + uint16_t size = ao_lisp_chunk[i].size; + + if (!size) + break; + + MDBG_MOVE("chunk %d %d -> %d\n", + ao_lisp_chunk[i].old_addr, + size, + top); + ao_lisp_chunk[i].new_addr = top; + memmove(&ao_lisp_pool[top], + &ao_lisp_pool[ao_lisp_chunk[i].old_addr], + size); + MDBG_DO(clear_object(ao_lisp_busy, &ao_lisp_pool[ao_lisp_chunk[i].old_addr], size)); + MDBG_DO(mark_object(ao_lisp_busy, &ao_lisp_pool[top], size)); + top += size; + chunk_low = ao_lisp_chunk[i].old_addr + size; + } + + MDBG_MOVE("after moving objects, busy is now:\n"); + DUMP_BUSY(); + chunk_last = i; + + if (chunk_first < chunk_last) { + /* Relocate all references to the objects */ + walk(ao_lisp_move, ao_lisp_poly_move); + +#if DBG_MEM + ao_lisp_record_free(move_record); + move_record = ao_lisp_record_save(); + if (mark_record && move_record) + ao_lisp_record_compare("move", mark_record, move_record); + + moved = total_marked; + if (moved != marked) ao_lisp_abort(); - clear_object(ao_lisp_busy, move_old, move_size); - mark_object(ao_lisp_busy, move_new, move_size); - if (busy_object(ao_lisp_cons_note, move_old)) { - clear_object(ao_lisp_cons_note, move_old, move_size); - mark_object(ao_lisp_cons_note, move_new, move_size); - } - i += move_size; - top += move_size; -#if MDBG_MOVE - DUMP_BUSY(); #endif - MDBG_MOVE_OUT(); - } else { - i += 4; } + + if (chunk_last != AO_LISP_NCHUNK) + break; } ao_lisp_top = top; + + MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); + +// printf ("collect. top %d loops %d\n", top, loops); } +/* + * Mark interfaces for objects + * + * Note a reference to memory and + * collect information about a few object sizes + * at a time + */ int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr) +ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) { - if (!addr) + int size; + if (!AO_LISP_IS_POOL(addr)) return 1; - MDBG_MOVE_IN(); + + size = ao_lisp_size(type, addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (!mark_object(ao_lisp_busy, addr, size)) { + note_chunk(pool_offset(addr), size); + MDBG_DO(ao_lisp_record(type, addr, size)); + return 0; + } + MDBG_MOVE("already marked\n"); + return 1; +} + +int +ao_lisp_mark(const struct ao_lisp_type *type, void *addr) +{ + int ret; MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); - if (mark_object(ao_lisp_busy, addr, type->size(addr))) { - MDBG_MOVE("already marked\n"); - MDBG_MOVE_OUT(); - return 1; + MDBG_MOVE_IN(); + ret = ao_lisp_mark_memory(type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + type->mark(addr); } - type->mark(addr); MDBG_MOVE_OUT(); - return 0; + return ret; } int ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) { - uint8_t type = ao_lisp_poly_type(p); + uint8_t type; + void *addr; if (!p) return 1; + + type = ao_lisp_poly_base_type(p); + addr = ao_lisp_ref(p); + + if (!AO_LISP_IS_POOL(addr)) + return 1; + if (type == AO_LISP_CONS && do_note_cons) { - MDBG_MOVE("note cons %d\n", MDBG_OFFSET(ao_lisp_ref(p))); note_cons(ao_lisp_ref(p)); - return 0; - } else { - const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; - if (lisp_type) - return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); return 1; - } -} + } else { + const struct ao_lisp_type *lisp_type; -int -ao_lisp_mark_memory(void *addr, int size) -{ - return mark_object(ao_lisp_busy, addr, size); -} + if (type == AO_LISP_OTHER) { + type = ao_lisp_other_type(ao_lisp_poly_other(p)); + if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) + ao_lisp_abort(); + } -/* - * 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 (move_size != 0) - return move_new; + lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; + if (!lisp_type) + return 1; + return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); } - return addr; } static void * -check_move(void *addr, int size) +move_map(void *addr) { - if (addr == move_old) { - MDBG_MOVE("mapping %d -> %d\n", MDBG_OFFSET(addr), MDBG_OFFSET(move_new)); - if (move_size && move_size != ((size + 3) & ~3)) - ao_lisp_abort(); - - /* Only copy the object once, otherwise we may - * smash stuff - */ - if (move_size == 0) { - MDBG_MOVE(" copy %d\n", size); - memmove(move_new, move_old, size); - move_size = (size + 3) & ~3; + uint16_t offset = pool_offset(addr); + int i; + + for (i = chunk_first; i < chunk_last; i++) { + if (ao_lisp_chunk[i].old_addr == offset) { + MDBG_MOVE("move %d -> %d\n", + ao_lisp_chunk[i].old_addr, + ao_lisp_chunk[i].new_addr); + return ao_lisp_pool + ao_lisp_chunk[i].new_addr; } - addr = move_new; } return addr; } int -ao_lisp_move(const struct ao_lisp_type *type, void **ref) +ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) { void *addr = *ref; - uint8_t *a = addr; - int size = type->size(ao_lisp_move_map(addr)); + int size; - if (!addr) + if (!AO_LISP_IS_POOL(addr)) return 1; -#ifndef AO_LISP_MAKE_CONST - if (AO_LISP_IS_CONST(addr)) - return 1; -#endif - MDBG_MOVE("object %d\n", MDBG_OFFSET(addr)); - if (!AO_LISP_IS_POOL(a)) - ao_lisp_abort(); - MDBG_MOVE_IN(); - addr = check_move(addr, size); - if (addr != *ref) + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); + addr = move_map(addr); + size = ao_lisp_size(type, addr); + if (addr != *ref) { + MDBG_MOVE("update ref %d %d -> %d\n", + AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + MDBG_OFFSET(*ref), MDBG_OFFSET(addr)); *ref = addr; - if (mark_object(ao_lisp_moving, addr, size)) { - MDBG_MOVE("already moved\n"); - MDBG_MOVE_OUT(); - return 1; } - MDBG_MOVE_OUT(); - MDBG_MOVE("recursing...\n"); - MDBG_MOVE_IN(); - type->move(addr); - MDBG_MOVE_OUT(); - MDBG_MOVE("done %d\n", MDBG_OFFSET(addr)); - return 0; + if (!mark_object(ao_lisp_busy, addr, size)) { + MDBG_DO(ao_lisp_record(type, addr, size)); + return 0; + } + MDBG_MOVE("already moved\n"); + return 1; } int -ao_lisp_move_memory(void **ref, int size) +ao_lisp_move(const struct ao_lisp_type *type, void **ref) { - void *addr = *ref; - if (!addr) - return 1; - - MDBG_MOVE("memory %d\n", MDBG_OFFSET(addr)); + int ret; + MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); MDBG_MOVE_IN(); - addr = check_move(addr, size); - if (addr != *ref) - *ref = addr; - if (mark_object(ao_lisp_moving, addr, size)) { - MDBG_MOVE("already moved\n"); - MDBG_MOVE_OUT(); - return 1; + ret = ao_lisp_move_memory(type, ref); + if (!ret) { + MDBG_MOVE("move recurse\n"); + type->move(*ref); } MDBG_MOVE_OUT(); - return 0; + return ret; } int @@ -456,7 +714,6 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) { uint8_t type; ao_poly p = *ref; - const struct ao_lisp_type *lisp_type; int ret; void *addr; @@ -466,20 +723,24 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) type = ao_lisp_poly_base_type(p); addr = ao_lisp_ref(p); - if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) + if (!AO_LISP_IS_POOL(addr)) return 1; if (type == AO_LISP_CONS && do_note_cons) { - addr = check_move(addr, sizeof (struct ao_lisp_cons)); +// addr = move_map(addr); + MDBG_DO(if (addr != move_map(addr)) MDBG_MOVE("noting cons at old addr %d instead of new addr %d\n", MDBG_OFFSET(addr), MDBG_OFFSET(move_map(addr)));); + note_cons(addr); + addr = move_map(addr); ret = 1; } else { + 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))); - - if (type >= AO_LISP_NUM_TYPE) - ao_lisp_abort(); + if (type == AO_LISP_OTHER) { + type = ao_lisp_other_type(move_map(ao_lisp_poly_other(p))); + if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) + ao_lisp_abort(); + } lisp_type = ao_lisp_types[type]; if (!lisp_type) @@ -487,10 +748,11 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) ret = ao_lisp_move(lisp_type, &addr); } + /* Re-write the poly value */ if (addr != ao_lisp_ref(p)) { ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); - MDBG("poly %d moved %d -> %d\n", - type, MDBG_OFFSET(ao_lisp_ref(p)), MDBG_OFFSET(ao_lisp_ref(np))); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, MDBG_OFFSET(ao_lisp_ref(p)), MDBG_OFFSET(ao_lisp_ref(np))); *ref = np; } return ret; @@ -535,15 +797,28 @@ ao_lisp_poison(void) #define AO_LISP_POOL_CUR AO_LISP_POOL #endif +#if DBG_MEM +void +ao_lisp_validate(void) +{ + chunk_low = 0; + memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); +} + +int dbg_allocs; + +#endif + + void * ao_lisp_alloc(int size) { void *addr; - size = ao_lisp_mem_round(size); -#ifdef MDBG_COLLECT_ALWAYS - ao_lisp_collect(); -#endif + MDBG_DO(++dbg_allocs); + MDBG_DO(if (dbg_validate) ao_lisp_validate()); + size = ao_lisp_size_round(size); if (ao_lisp_top + size > AO_LISP_POOL_CUR) { #ifdef MDBG_POOL if (AO_LISP_POOL_CUR < AO_LISP_POOL) { @@ -573,37 +848,47 @@ ao_lisp_alloc(int size) return addr; } -int -ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) +void +ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) { - int i; - MDBG("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; - ao_lisp_root[i].type = type; - return 1; - } - } - ao_lisp_abort(); - return 0; + if (save_cons[id] != NULL) + ao_lisp_abort(); + save_cons[id] = cons; } -int -ao_lisp_root_poly_add(ao_poly *p) +struct ao_lisp_cons * +ao_lisp_cons_fetch(int id) { - return ao_lisp_root_add(NULL, p); + struct ao_lisp_cons *cons = save_cons[id]; + save_cons[id] = NULL; + return cons; } void -ao_lisp_root_clear(void *addr) +ao_lisp_string_stash(int id, char *string) { - int i; - for (i = 0; i < AO_LISP_ROOT; i++) { - if (ao_lisp_root[i].addr == addr) { - ao_lisp_root[i].addr = 0; - ao_lisp_root[i].type = 0; - break; - } - } + if (save_cons[id] != NULL) + ao_lisp_abort(); + save_string[id] = string; +} + +char * +ao_lisp_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} +void +ao_lisp_poly_stash(int id, ao_poly poly) +{ + save_poly[id] = poly; +} + +ao_poly +ao_lisp_poly_fetch(int id) +{ + ao_poly poly = save_poly[id]; + save_poly[id] = AO_LISP_NIL; + return poly; } diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 7a5751ce..b792c2f1 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -357,25 +357,25 @@ lex(void) } static int parse_token; -static uint8_t been_here; -static struct ao_lisp_cons *read_cons; -static struct ao_lisp_cons *read_cons_tail; -static struct ao_lisp_cons *read_stack; + +struct ao_lisp_cons *ao_lisp_read_cons; +struct ao_lisp_cons *ao_lisp_read_cons_tail; +struct ao_lisp_cons *ao_lisp_read_stack; static int push_read_stack(int cons, int in_quote) { - DBGI("push read stack %p %d\n", read_cons, in_quote); + DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); DBG_IN(); if (cons) { - read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), + ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), - read_stack)); - if (!read_stack) + ao_lisp_read_stack)); + if (!ao_lisp_read_stack) return 0; } - read_cons = NULL; - read_cons_tail = NULL; + ao_lisp_read_cons = NULL; + ao_lisp_read_cons_tail = NULL; return 1; } @@ -384,21 +384,21 @@ pop_read_stack(int cons) { int in_quote = 0; if (cons) { - read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = ao_lisp_poly_cons(read_stack->cdr); - in_quote = ao_lisp_poly_int(read_stack->car); - read_stack = ao_lisp_poly_cons(read_stack->cdr); - for (read_cons_tail = read_cons; - read_cons_tail && read_cons_tail->cdr; - read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) + ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); + ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); + in_quote = ao_lisp_poly_int(ao_lisp_read_stack->car); + ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); + for (ao_lisp_read_cons_tail = ao_lisp_read_cons; + ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; + ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) ; } else { - read_cons = 0; - read_cons_tail = 0; - read_stack = 0; + ao_lisp_read_cons = 0; + ao_lisp_read_cons_tail = 0; + ao_lisp_read_stack = 0; } DBG_OUT(); - DBGI("pop read stack %p %d\n", read_cons, in_quote); + DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); return in_quote; } @@ -411,18 +411,12 @@ ao_lisp_read(void) int in_quote; ao_poly v; - if (!been_here) { - 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(); DBGI("token %d (%s)\n", parse_token, token_string); cons = 0; in_quote = 0; - read_cons = read_cons_tail = read_stack = 0; + ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; for (;;) { while (parse_token == OPEN) { if (!push_read_stack(cons, in_quote)) @@ -469,7 +463,7 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; } - v = ao_lisp_cons_poly(read_cons); + v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; in_quote = pop_read_stack(cons); break; @@ -484,16 +478,16 @@ ao_lisp_read(void) if (!read) return AO_LISP_NIL; - if (read_cons_tail) - read_cons_tail->cdr = ao_lisp_cons_poly(read); + if (ao_lisp_read_cons_tail) + ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); else - read_cons = read; - read_cons_tail = read; + ao_lisp_read_cons = read; + ao_lisp_read_cons_tail = read; - if (!in_quote || !read_cons->cdr) + if (!in_quote || !ao_lisp_read_cons->cdr) break; - v = ao_lisp_cons_poly(read_cons); + v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; in_quote = pop_read_stack(cons); } diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 9ee1a7dd..207d4f3b 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -38,23 +38,17 @@ const struct ao_lisp_type ao_lisp_string_type = { .mark = string_mark, .size = string_size, .move = string_move, + .name = "string", }; -char * -ao_lisp_string_new(int len) { - char *a = ao_lisp_alloc(len + 1); - if (!a) - return NULL; - a[len] = '\0'; - return a; -} - char * ao_lisp_string_copy(char *a) { int alen = strlen(a); + ao_lisp_string_stash(0, a); char *r = ao_lisp_alloc(alen + 1); + a = ao_lisp_string_fetch(0); if (!r) return NULL; strcpy(r, a); @@ -66,7 +60,12 @@ ao_lisp_string_cat(char *a, char *b) { int alen = strlen(a); int blen = strlen(b); + + ao_lisp_string_stash(0, a); + ao_lisp_string_stash(1, b); char *r = ao_lisp_alloc(alen + blen + 1); + a = ao_lisp_string_fetch(0); + b = ao_lisp_string_fetch(1); if (!r) return NULL; strcpy(r, a); @@ -78,7 +77,9 @@ ao_poly ao_lisp_string_pack(struct ao_lisp_cons *cons) { int len = ao_lisp_cons_length(cons); + ao_lisp_cons_stash(0, cons); char *r = ao_lisp_alloc(len + 1); + cons = ao_lisp_cons_fetch(0); char *s = r; while (cons) { @@ -96,11 +97,17 @@ ao_lisp_string_unpack(char *a) { struct ao_lisp_cons *cons = NULL, *tail = NULL; int c; + int i; - ao_lisp_root_add(&ao_lisp_cons_type, &cons); - ao_lisp_root_add(&ao_lisp_cons_type, &tail); - while ((c = *a++)) { + for (i = 0; (c = a[i]); i++) { + ao_lisp_cons_stash(0, cons); + ao_lisp_cons_stash(1, tail); + ao_lisp_string_stash(0, a); struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); + cons = ao_lisp_cons_fetch(0); + tail = ao_lisp_cons_fetch(1); + a = ao_lisp_string_fetch(0); + if (!n) { cons = NULL; break; @@ -111,8 +118,6 @@ ao_lisp_string_unpack(char *a) cons = n; tail = n; } - ao_lisp_root_clear(&cons); - ao_lisp_root_clear(&tail); return ao_lisp_cons_poly(cons); } -- cgit v1.2.3 From ce549b2c11e6b2571590021e1c0503d8a6e7a702 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 14 Nov 2016 19:55:36 -0800 Subject: altos/lisp: Simplify GC a bit by only marking the head of each object We don't need to mark the whole object now as we're getting information about where objects are by walking the tree each time around the loop; ao_lisp_busy is only useful for terminating the walk now. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 +- src/lisp/ao_lisp_mem.c | 94 ++++++++++---------------------------------------- 2 files changed, 20 insertions(+), 76 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 906bae19..e90d791a 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -650,7 +650,7 @@ ao_lisp_frames_dump(void) #define DBG_FRAMES() #endif -#define DBG_MEM 1 +#define DBG_MEM 0 #define DBG_MEM_START 1 #if DBG_MEM diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 60f4bbee..08b5bac0 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -282,62 +282,11 @@ static inline int limit(int offset) { static int total_marked; -/* - * Mark a range of addresses - */ -static int -mark_object(uint8_t *tag, void *addr, int size) { - int base; - int bound; - - MDBG_DO(if (!AO_LISP_IS_POOL((uint8_t *) addr + size - 1)) - ao_lisp_abort()); - - base = pool_offset(addr); - bound = base + size; - - MDBG_DO(if (bound > ao_lisp_top) ao_lisp_abort()); - - if (busy(tag, base)) - return 1; - if (tag == ao_lisp_busy) - total_marked += size; - while (base < bound) { - mark(tag, base); - base += 4; - } - return 0; -} - -MDBG_DO( -static int -clear_object(uint8_t *tag, void *addr, int size) { - int base; - int bound; - - MDBG_DO(if (!AO_LISP_IS_POOL((uint8_t *) addr + size - 1)) - ao_lisp_abort()); - - base = (uint8_t *) addr - ao_lisp_pool; - bound = base + size; - - base = limit(base); - bound = limit(bound); - if (!busy(tag, base)) - return 1; - total_marked -= size; - while (base < bound) { - clear(tag, base); - base += 4; - } - return 0; -}) - static void note_cons(void *addr) { if (AO_LISP_IS_POOL(addr)) { - int offset = (uint8_t *) addr - ao_lisp_pool; + int offset = pool_offset(addr); MDBG_MOVE("note cons %d\n", MDBG_OFFSET(addr)); ao_lisp_cons_noted = 1; mark(ao_lisp_cons_note, offset); @@ -539,14 +488,10 @@ ao_lisp_collect(void) memmove(&ao_lisp_pool[top], &ao_lisp_pool[ao_lisp_chunk[i].old_addr], size); - MDBG_DO(clear_object(ao_lisp_busy, &ao_lisp_pool[ao_lisp_chunk[i].old_addr], size)); - MDBG_DO(mark_object(ao_lisp_busy, &ao_lisp_pool[top], size)); top += size; chunk_low = ao_lisp_chunk[i].old_addr + size; } - MDBG_MOVE("after moving objects, busy is now:\n"); - DUMP_BUSY(); chunk_last = i; if (chunk_first < chunk_last) { @@ -587,19 +532,19 @@ ao_lisp_collect(void) int ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) { - int size; + int offset; if (!AO_LISP_IS_POOL(addr)) return 1; - size = ao_lisp_size(type, addr); + offset = pool_offset(addr); MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (!mark_object(ao_lisp_busy, addr, size)) { - note_chunk(pool_offset(addr), size); - MDBG_DO(ao_lisp_record(type, addr, size)); - return 0; + if (busy(ao_lisp_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; } - MDBG_MOVE("already marked\n"); - return 1; + mark(ao_lisp_busy, offset); + note_chunk(offset, ao_lisp_size(type, addr)); + return 0; } int @@ -672,26 +617,27 @@ int ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) { void *addr = *ref; - int size; + int offset; if (!AO_LISP_IS_POOL(addr)) return 1; MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); addr = move_map(addr); - size = ao_lisp_size(type, addr); if (addr != *ref) { MDBG_MOVE("update ref %d %d -> %d\n", AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, MDBG_OFFSET(*ref), MDBG_OFFSET(addr)); *ref = addr; } - if (!mark_object(ao_lisp_busy, addr, size)) { - MDBG_DO(ao_lisp_record(type, addr, size)); - return 0; + offset = pool_offset(addr); + if (busy(ao_lisp_busy, offset)) { + MDBG_MOVE("already moved\n"); + return 1; } - MDBG_MOVE("already moved\n"); - return 1; + mark(ao_lisp_busy, offset); + MDBG_DO(ao_lisp_record(type, addr, ao_lisp_size(type, addr))); + return 0; } int @@ -720,16 +666,14 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) if (!p) return 1; - type = ao_lisp_poly_base_type(p); addr = ao_lisp_ref(p); if (!AO_LISP_IS_POOL(addr)) return 1; - if (type == AO_LISP_CONS && do_note_cons) { -// addr = move_map(addr); - MDBG_DO(if (addr != move_map(addr)) MDBG_MOVE("noting cons at old addr %d instead of new addr %d\n", MDBG_OFFSET(addr), MDBG_OFFSET(move_map(addr)));); + type = ao_lisp_poly_base_type(p); + if (type == AO_LISP_CONS && do_note_cons) { note_cons(addr); addr = move_map(addr); ret = 1; -- cgit v1.2.3 From 5557f6b87a9b8bc9716de8191f2062a772a6ae6c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 14 Nov 2016 21:25:38 -0800 Subject: altos/lisp: Cache freed cons and stack items Track freed cons cells and stack items from the eval process where possible so that they can be re-used without needing to collect. This dramatically reduces the number of collect calls. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 17 ++++++++++++++ src/lisp/ao_lisp_cons.c | 32 +++++++++++++++++++------ src/lisp/ao_lisp_eval.c | 33 +++++++++++++++++++++----- src/lisp/ao_lisp_lambda.c | 1 + src/lisp/ao_lisp_make_const.c | 54 +++++++++++++++++++++---------------------- src/lisp/ao_lisp_mem.c | 41 ++++++++++++++++++++++++-------- src/lisp/ao_lisp_save.c | 2 +- 7 files changed, 130 insertions(+), 50 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index e90d791a..efd13cf5 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -206,6 +206,7 @@ ao_lisp_stack_poly(struct ao_lisp_stack *stack) } extern struct ao_lisp_stack *ao_lisp_stack; +extern struct ao_lisp_stack *ao_lisp_stack_free_list; extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 @@ -213,6 +214,14 @@ extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_MACRO 2 #define AO_LISP_FUNC_LEXPR 3 +#define AO_LISP_FUNC_FREE_ARGS 0x80 +#define AO_LISP_FUNC_MASK 0x7f + +#define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) +#define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) +#define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) +#define AO_LISP_FUNC_F_LEXPR (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) + struct ao_lisp_builtin { uint8_t type; uint8_t args; @@ -390,6 +399,9 @@ ao_lisp_builtin_poly(struct ao_lisp_builtin *b) } /* memory functions */ + +extern int ao_lisp_collects; + /* returns 1 if the object was already marked */ int ao_lisp_mark(const struct ao_lisp_type *type, void *addr); @@ -439,6 +451,11 @@ extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); +extern struct ao_lisp_cons *ao_lisp_cons_free_list; + +void +ao_lisp_cons_free(struct ao_lisp_cons *cons); + void ao_lisp_cons_print(ao_poly); diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 311d63ab..d2b60c9a 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -69,23 +69,41 @@ const struct ao_lisp_type ao_lisp_cons_type = { .name = "cons", }; +struct ao_lisp_cons *ao_lisp_cons_free_list; + struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { struct ao_lisp_cons *cons; - ao_lisp_poly_stash(0, car); - ao_lisp_cons_stash(0, cdr); - cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - car = ao_lisp_poly_fetch(0); - cdr = ao_lisp_cons_fetch(0); - if (!cons) - return NULL; + if (ao_lisp_cons_free_list) { + cons = ao_lisp_cons_free_list; + ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); + } else { + ao_lisp_poly_stash(0, car); + ao_lisp_cons_stash(0, cdr); + cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + car = ao_lisp_poly_fetch(0); + cdr = ao_lisp_cons_fetch(0); + if (!cons) + return NULL; + } cons->car = car; cons->cdr = ao_lisp_cons_poly(cdr); return cons; } +void +ao_lisp_cons_free(struct ao_lisp_cons *cons) +{ + while (cons) { + ao_poly cdr = cons->cdr; + cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); + ao_lisp_cons_free_list = cons; + cons = ao_lisp_poly_cons(cdr); + } +} + void ao_lisp_cons_print(ao_poly c) { diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 04d0e70a..5cc1b75a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -76,6 +76,8 @@ const struct ao_lisp_type ao_lisp_stack_type = { struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; +struct ao_lisp_stack *ao_lisp_stack_free_list; + ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -97,9 +99,15 @@ ao_lisp_stack_reset(struct ao_lisp_stack *stack) static int ao_lisp_stack_push(void) { - struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; + struct ao_lisp_stack *stack; + if (ao_lisp_stack_free_list) { + stack = ao_lisp_stack_free_list; + ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); + } else { + stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!stack) + return 0; + } stack->prev = ao_lisp_stack_poly(ao_lisp_stack); stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); stack->list = AO_LISP_NIL; @@ -114,9 +122,15 @@ ao_lisp_stack_push(void) static void ao_lisp_stack_pop(void) { + ao_poly prev; + if (!ao_lisp_stack) return; - ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); + prev = ao_lisp_stack->prev; + ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); + ao_lisp_stack_free_list = ao_lisp_stack; + + ao_lisp_stack = ao_lisp_poly_stack(prev); if (ao_lisp_stack) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else @@ -141,7 +155,7 @@ func_type(ao_poly func) return ao_lisp_error(AO_LISP_INVALID, "func is nil"); switch (ao_lisp_poly_type(func)) { case AO_LISP_BUILTIN: - return ao_lisp_poly_builtin(func)->args; + return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; case AO_LISP_LAMBDA: return ao_lisp_poly_lambda(func)->args; default: @@ -359,12 +373,15 @@ static int ao_lisp_eval_exec(void) { ao_poly v; + struct ao_lisp_builtin *builtin; + DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); ao_lisp_stack->sexprs = AO_LISP_NIL; switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_BUILTIN: ao_lisp_stack->state = eval_val; - v = ao_lisp_func(ao_lisp_poly_builtin(ao_lisp_v)) ( + builtin = ao_lisp_poly_builtin(ao_lisp_v); + v = ao_lisp_func(builtin) ( ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); @@ -372,6 +389,10 @@ ao_lisp_eval_exec(void) ao_poly val = ao_lisp_arg(cons, 2); DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); + builtin = ao_lisp_poly_builtin(ao_lisp_v); + if (builtin->args & AO_LISP_FUNC_FREE_ARGS) + ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); + ao_lisp_v = v; DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 6020a8b8..0dd8c698 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -168,6 +168,7 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } + ao_lisp_cons_free(cons); break; } case AO_LISP_FUNC_LEXPR: diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6a29f402..178b041e 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -33,42 +33,42 @@ struct builtin_func { }; struct builtin_func funcs[] = { - "eval", AO_LISP_FUNC_LAMBDA, builtin_eval, - "read", AO_LISP_FUNC_LAMBDA, builtin_read, + "eval", AO_LISP_FUNC_F_LAMBDA, builtin_eval, + "read", AO_LISP_FUNC_F_LAMBDA, builtin_read, "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, "macro", AO_LISP_FUNC_NLAMBDA, builtin_macro, - "car", AO_LISP_FUNC_LAMBDA, builtin_car, - "cdr", AO_LISP_FUNC_LAMBDA, builtin_cdr, - "cons", AO_LISP_FUNC_LAMBDA, builtin_cons, - "last", AO_LISP_FUNC_LAMBDA, builtin_last, - "length", AO_LISP_FUNC_LAMBDA, builtin_length, + "car", AO_LISP_FUNC_F_LAMBDA, builtin_car, + "cdr", AO_LISP_FUNC_F_LAMBDA, builtin_cdr, + "cons", AO_LISP_FUNC_F_LAMBDA, builtin_cons, + "last", AO_LISP_FUNC_F_LAMBDA, builtin_last, + "length", AO_LISP_FUNC_F_LAMBDA, builtin_length, "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, - "set", AO_LISP_FUNC_LAMBDA, builtin_set, + "set", AO_LISP_FUNC_F_LAMBDA, builtin_set, "setq", AO_LISP_FUNC_MACRO, builtin_setq, "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, "progn", AO_LISP_FUNC_NLAMBDA, builtin_progn, "while", AO_LISP_FUNC_NLAMBDA, builtin_while, - "print", AO_LISP_FUNC_LEXPR, builtin_print, - "patom", AO_LISP_FUNC_LEXPR, builtin_patom, - "+", AO_LISP_FUNC_LEXPR, builtin_plus, - "-", AO_LISP_FUNC_LEXPR, builtin_minus, - "*", AO_LISP_FUNC_LEXPR, builtin_times, - "/", AO_LISP_FUNC_LEXPR, builtin_divide, - "%", AO_LISP_FUNC_LEXPR, builtin_mod, - "=", AO_LISP_FUNC_LEXPR, builtin_equal, - "<", AO_LISP_FUNC_LEXPR, builtin_less, - ">", AO_LISP_FUNC_LEXPR, builtin_greater, - "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, - ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, - "pack", AO_LISP_FUNC_LAMBDA, builtin_pack, - "unpack", AO_LISP_FUNC_LAMBDA, builtin_unpack, - "flush", AO_LISP_FUNC_LAMBDA, builtin_flush, - "delay", AO_LISP_FUNC_LAMBDA, builtin_delay, - "led", AO_LISP_FUNC_LEXPR, builtin_led, - "save", AO_LISP_FUNC_LAMBDA, builtin_save, - "restore", AO_LISP_FUNC_LAMBDA, builtin_restore, + "print", AO_LISP_FUNC_F_LEXPR, builtin_print, + "patom", AO_LISP_FUNC_F_LEXPR, builtin_patom, + "+", AO_LISP_FUNC_F_LEXPR, builtin_plus, + "-", AO_LISP_FUNC_F_LEXPR, builtin_minus, + "*", AO_LISP_FUNC_F_LEXPR, builtin_times, + "/", AO_LISP_FUNC_F_LEXPR, builtin_divide, + "%", AO_LISP_FUNC_F_LEXPR, builtin_mod, + "=", AO_LISP_FUNC_F_LEXPR, builtin_equal, + "<", AO_LISP_FUNC_F_LEXPR, builtin_less, + ">", AO_LISP_FUNC_F_LEXPR, builtin_greater, + "<=", AO_LISP_FUNC_F_LEXPR, builtin_less_equal, + ">=", AO_LISP_FUNC_F_LEXPR, builtin_greater_equal, + "pack", AO_LISP_FUNC_F_LAMBDA, builtin_pack, + "unpack", AO_LISP_FUNC_F_LAMBDA, builtin_unpack, + "flush", AO_LISP_FUNC_F_LAMBDA, builtin_flush, + "delay", AO_LISP_FUNC_F_LAMBDA, builtin_delay, + "led", AO_LISP_FUNC_F_LEXPR, builtin_led, + "save", AO_LISP_FUNC_F_LAMBDA, builtin_save, + "restore", AO_LISP_FUNC_F_LAMBDA, builtin_restore, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 08b5bac0..e7ece960 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -43,7 +43,6 @@ uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4 #if DBG_MEM int dbg_move_depth; int dbg_mem = DBG_MEM_START; -int dbg_collects = 0; int dbg_validate = 0; struct ao_lisp_record { @@ -212,6 +211,13 @@ static const struct ao_lisp_root ao_lisp_root[] = { #define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) +static const void ** const ao_lisp_cache[] = { + (const void **) &ao_lisp_cons_free_list, + (const void **) &ao_lisp_stack_free_list, +}; + +#define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) + #define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; @@ -229,14 +235,16 @@ struct ao_lisp_chunk { }; }; -#define AO_LISP_NCHUNK 32 +#define AO_LISP_NCHUNK 64 static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; /* Offset of an address within the pool. */ static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM if (!AO_LISP_IS_POOL(addr)) ao_lisp_abort(); +#endif return ((uint8_t *) addr) - ao_lisp_pool; } @@ -246,8 +254,10 @@ static inline uint16_t pool_offset(void *addr) { * These are used in the chunk code. */ static inline ao_poly pool_poly(void *addr) { +#if DBG_MEM if (!AO_LISP_IS_POOL(addr)) ao_lisp_abort(); +#endif return ((uint8_t *) addr) - AO_LISP_POOL_BASE; } @@ -306,8 +316,10 @@ note_chunk(uint16_t addr, uint16_t size) for (i = 0; i < AO_LISP_NCHUNK; i++) { if (ao_lisp_chunk[i].size && ao_lisp_chunk[i].old_addr == addr) { +#if DBG_MEM if (ao_lisp_chunk[i].size != size) ao_lisp_abort(); +#endif return; } if (ao_lisp_chunk[i].old_addr > addr) { @@ -339,7 +351,7 @@ walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; - for (i = 0; i < AO_LISP_ROOT; i++) { + for (i = 0; i < (int) AO_LISP_ROOT; i++) { if (ao_lisp_root[i].type) { void **a = ao_lisp_root[i].addr, *v; if (a && (v = *a)) { @@ -416,6 +428,8 @@ ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) return ao_lisp_poly_mark(*p, do_note_cons); } +int ao_lisp_collects; + void ao_lisp_collect(void) { @@ -427,10 +441,15 @@ ao_lisp_collect(void) int moved; struct ao_lisp_record *mark_record = NULL, *move_record = NULL; - ++dbg_collects; - MDBG_MOVE("collect %d\n", dbg_collects); + MDBG_MOVE("collect %d\n", ao_lisp_collects); marked = moved = 0; #endif + + ++ao_lisp_collects; + + /* Clear references to all caches */ + for (i = 0; i < (int) AO_LISP_CACHE; i++) + *ao_lisp_cache[i] = NULL; chunk_low = 0; top = 0; for (;;) { @@ -462,8 +481,10 @@ ao_lisp_collect(void) if (ao_lisp_chunk[i].old_addr > top) break; +#if DBG_MEM if (ao_lisp_chunk[i].old_addr != top) ao_lisp_abort(); +#endif top += size; MDBG_MOVE("chunk %d %d not moving\n", @@ -585,8 +606,10 @@ ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) if (type == AO_LISP_OTHER) { type = ao_lisp_other_type(ao_lisp_poly_other(p)); +#if DBG_MEM if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) ao_lisp_abort(); +#endif } lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; @@ -622,6 +645,8 @@ ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) if (!AO_LISP_IS_POOL(addr)) return 1; + (void) type; + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); addr = move_map(addr); if (addr != *ref) { @@ -682,8 +707,10 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) if (type == AO_LISP_OTHER) { type = ao_lisp_other_type(move_map(ao_lisp_poly_other(p))); +#if DBG_MEM if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) ao_lisp_abort(); +#endif } lisp_type = ao_lisp_types[type]; @@ -795,8 +822,6 @@ ao_lisp_alloc(int size) void ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) { - if (save_cons[id] != NULL) - ao_lisp_abort(); save_cons[id] = cons; } @@ -811,8 +836,6 @@ ao_lisp_cons_fetch(int id) void ao_lisp_string_stash(int id, char *string) { - if (save_cons[id] != NULL) - ao_lisp_abort(); save_string[id] = string; } diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index 030846b7..d5f28e7d 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -27,7 +27,7 @@ ao_lisp_save(struct ao_lisp_cons *cons) os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); os->const_checksum = ao_lisp_const_checksum; - os->const_checksum_inv = ~ao_lisp_const_checksum; + os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; if (ao_lisp_os_save()) return _ao_lisp_atom_t; -- cgit v1.2.3 From 974717eb9dad105c9897ee24f953d98d57eaec77 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 15 Nov 2016 09:55:22 -0800 Subject: altos/lisp: Evaluate macros once, then smash them into place This assumes that macros are all pure functions, which should be true for syntactic macros. Signed-off-by: Keith Packard --- src/lisp/Makefile | 5 +- src/lisp/ao_lisp.h | 17 +-- src/lisp/ao_lisp_builtin.c | 2 + src/lisp/ao_lisp_const.lisp | 24 ++-- src/lisp/ao_lisp_eval.c | 23 +++- src/lisp/ao_lisp_make_const.c | 263 ++++++++++++++++++++++++++++++++---------- src/lisp/ao_lisp_os.h | 7 +- 7 files changed, 253 insertions(+), 88 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index dac11f66..b06e10dd 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -4,7 +4,7 @@ clean: rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const - ./ao_lisp_make_const < ao_lisp_const.lisp > $@ + ./ao_lisp_make_const -o $@ ao_lisp_const.lisp SRCS=\ ao_lisp_make_const.c\ @@ -25,10 +25,11 @@ SRCS=\ OBJS=$(SRCS:.c=.o) -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. +CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra HDRS=\ ao_lisp.h \ + ao_lisp_os.h \ ao_lisp_read.h ao_lisp_make_const: $(OBJS) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index efd13cf5..2db4914f 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -173,14 +173,15 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { enum eval_state { eval_sexpr, /* Evaluate an sexpr */ - eval_val, - eval_formal, - eval_exec, - eval_cond, - eval_cond_test, - eval_progn, - eval_while, - eval_while_test, + eval_val, /* Value computed */ + eval_formal, /* Formal computed */ + eval_exec, /* Start a lambda evaluation */ + eval_cond, /* Start next cond clause */ + eval_cond_test, /* Check cond condition */ + eval_progn, /* Start next progn entry */ + eval_while, /* Start while condition */ + eval_while_test, /* Check while condition */ + eval_macro, /* Finished with macro generation */ }; struct ao_lisp_stack { diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index ebc69f77..e4b7ef52 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -41,9 +41,11 @@ const struct ao_lisp_type ao_lisp_builtin_type = { #ifdef AO_LISP_MAKE_CONST char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + (void) b; return "???"; } char *ao_lisp_args_name(uint8_t args) { + (void) args; return "???"; } #else diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index c6f50e34..9d8af588 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -9,10 +9,6 @@ ;(setq progn (lexpr (l) (last l))) - ; simple math operators - -(setq 1+ (lambda (x) (+ x 1))) -(setq 1- (lambda (x) (- x 1))) ; ; Define a variable without returning the value @@ -64,7 +60,7 @@ ; make the list of names in the let ; - (set 'make-names (lambda (vars) + (setq make-names (lambda (vars) (cond (vars (cons (car (car vars)) (make-names (cdr vars)))) @@ -77,7 +73,7 @@ ; pre-pended to the ; expressions to evaluate ; - (set 'make-exprs (lambda (vars exprs) + (setq make-exprs (lambda (vars exprs) (progn (cond (vars (cons (list set @@ -94,13 +90,13 @@ ) ) ) - (set 'exprs (make-exprs vars exprs)) + (setq exprs (make-exprs vars exprs)) ; ; the parameters to the lambda is a list ; of nils of the right length ; - (set 'make-nils (lambda (vars) + (setq make-nils (lambda (vars) (cond (vars (cons nil (make-nils (cdr vars)))) ) ) @@ -108,7 +104,6 @@ ; ; build the lambda. ; - (set 'last-let-value (cons (list 'lambda @@ -120,8 +115,6 @@ (make-nils vars) ) ) - ) - ) (car let-param) (cdr let-param) @@ -158,3 +151,12 @@ ) ) ) + + ; simple math operators + ; + ; Do these last to run defun + ; at least once so the let macro + ; is resolved + +(defun 1+ (x) (+ x 1)) +(defun 1- (x) (- x 1)) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 5cc1b75a..3af56796 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -298,7 +298,7 @@ ao_lisp_eval_formal(void) break; case AO_LISP_FUNC_MACRO: /* Evaluate the result once more */ - ao_lisp_stack->state = eval_sexpr; + ao_lisp_stack->state = eval_macro; if (!ao_lisp_stack_push()) return 0; @@ -308,7 +308,6 @@ ao_lisp_eval_formal(void) prev = ao_lisp_poly_stack(ao_lisp_stack->prev); ao_lisp_stack->state = eval_sexpr; ao_lisp_stack->sexprs = prev->sexprs; - prev->sexprs = AO_LISP_NIL; DBGI(".. start macro\n"); DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); @@ -555,6 +554,25 @@ ao_lisp_eval_while_test(void) return 1; } +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_lisp_eval_macro(void) +{ + DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + + if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { + *ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); + ao_lisp_v = ao_lisp_stack->sexprs; + DBGI("sexprs rewritten to: "); DBG_POLY(ao_lisp_v); DBG("\n"); + } + ao_lisp_stack->sexprs = AO_LISP_NIL; + ao_lisp_stack->state = eval_sexpr; + return 1; +} + static int (*const evals[])(void) = { [eval_sexpr] = ao_lisp_eval_sexpr, [eval_val] = ao_lisp_eval_val, @@ -565,6 +583,7 @@ static int (*const evals[])(void) = { [eval_progn] = ao_lisp_eval_progn, [eval_while] = ao_lisp_eval_while, [eval_while_test] = ao_lisp_eval_while_test, + [eval_macro] = ao_lisp_eval_macro, }; /* diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 178b041e..ae53bd35 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -15,6 +15,8 @@ #include "ao_lisp.h" #include #include +#include +#include static struct ao_lisp_builtin * ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { @@ -33,42 +35,42 @@ struct builtin_func { }; struct builtin_func funcs[] = { - "eval", AO_LISP_FUNC_F_LAMBDA, builtin_eval, - "read", AO_LISP_FUNC_F_LAMBDA, builtin_read, - "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, - "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, - "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, - "macro", AO_LISP_FUNC_NLAMBDA, builtin_macro, - "car", AO_LISP_FUNC_F_LAMBDA, builtin_car, - "cdr", AO_LISP_FUNC_F_LAMBDA, builtin_cdr, - "cons", AO_LISP_FUNC_F_LAMBDA, builtin_cons, - "last", AO_LISP_FUNC_F_LAMBDA, builtin_last, - "length", AO_LISP_FUNC_F_LAMBDA, builtin_length, - "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, - "set", AO_LISP_FUNC_F_LAMBDA, builtin_set, - "setq", AO_LISP_FUNC_MACRO, builtin_setq, - "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, - "progn", AO_LISP_FUNC_NLAMBDA, builtin_progn, - "while", AO_LISP_FUNC_NLAMBDA, builtin_while, - "print", AO_LISP_FUNC_F_LEXPR, builtin_print, - "patom", AO_LISP_FUNC_F_LEXPR, builtin_patom, - "+", AO_LISP_FUNC_F_LEXPR, builtin_plus, - "-", AO_LISP_FUNC_F_LEXPR, builtin_minus, - "*", AO_LISP_FUNC_F_LEXPR, builtin_times, - "/", AO_LISP_FUNC_F_LEXPR, builtin_divide, - "%", AO_LISP_FUNC_F_LEXPR, builtin_mod, - "=", AO_LISP_FUNC_F_LEXPR, builtin_equal, - "<", AO_LISP_FUNC_F_LEXPR, builtin_less, - ">", AO_LISP_FUNC_F_LEXPR, builtin_greater, - "<=", AO_LISP_FUNC_F_LEXPR, builtin_less_equal, - ">=", AO_LISP_FUNC_F_LEXPR, builtin_greater_equal, - "pack", AO_LISP_FUNC_F_LAMBDA, builtin_pack, - "unpack", AO_LISP_FUNC_F_LAMBDA, builtin_unpack, - "flush", AO_LISP_FUNC_F_LAMBDA, builtin_flush, - "delay", AO_LISP_FUNC_F_LAMBDA, builtin_delay, - "led", AO_LISP_FUNC_F_LEXPR, builtin_led, - "save", AO_LISP_FUNC_F_LAMBDA, builtin_save, - "restore", AO_LISP_FUNC_F_LAMBDA, builtin_restore, + { .name = "eval", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_eval }, + { .name = "read", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_read }, + { .name = "lambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lambda }, + { .name = "lexpr", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lexpr }, + { .name = "nlambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_nlambda }, + { .name = "macro", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_macro }, + { .name = "car", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_car }, + { .name = "cdr", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cdr }, + { .name = "cons", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cons }, + { .name = "last", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_last }, + { .name = "length", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_length }, + { .name = "quote", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_quote }, + { .name = "set", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_set }, + { .name = "setq", .args = AO_LISP_FUNC_MACRO, .func = builtin_setq }, + { .name = "cond", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_cond }, + { .name = "progn", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_progn }, + { .name = "while", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_while }, + { .name = "print", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_print }, + { .name = "patom", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_patom }, + { .name = "+", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_plus }, + { .name = "-", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_minus }, + { .name = "*", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_times }, + { .name = "/", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_divide }, + { .name = "%", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_mod }, + { .name = "=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_equal }, + { .name = "<", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less }, + { .name = ">", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater }, + { .name = "<=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less_equal }, + { .name = ">=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater_equal }, + { .name = "pack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_pack }, + { .name = "unpack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_unpack }, + { .name = "flush", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_flush }, + { .name = "delay", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_delay }, + { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, + { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, + { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) @@ -113,18 +115,127 @@ ao_fec_crc(const uint8_t *bytes, uint8_t len) return crc; } +int +ao_is_macro(ao_poly p) +{ + struct ao_lisp_builtin *builtin; + struct ao_lisp_lambda *lambda; + +// printf ("macro scanning "); ao_lisp_poly_print(p); printf("\n"); + switch (ao_lisp_poly_type(p)) { + case AO_LISP_ATOM: + return ao_is_macro(ao_lisp_atom_get(p)); + case AO_LISP_BUILTIN: + builtin = ao_lisp_poly_builtin(p); + if ((builtin->args & AO_LISP_FUNC_MASK) == AO_LISP_FUNC_MACRO) + return 1; + return 0; + case AO_LISP_LAMBDA: + lambda = ao_lisp_poly_lambda(p); + if (lambda->args == AO_LISP_FUNC_MACRO) + return 1; + return 0; + default: + return 0; + } +} + +ao_poly +ao_has_macro(ao_poly p) +{ + struct ao_lisp_cons *cons; + struct ao_lisp_lambda *lambda; + ao_poly m; + + if (p == AO_LISP_NIL) + return AO_LISP_NIL; + + switch (ao_lisp_poly_type(p)) { + case AO_LISP_LAMBDA: + lambda = ao_lisp_poly_lambda(p); + return ao_has_macro(lambda->code); + case AO_LISP_CONS: + cons = ao_lisp_poly_cons(p); + if (ao_is_macro(cons->car)) + return cons->car; + + cons = ao_lisp_poly_cons(cons->cdr); + while (cons) { + m = ao_has_macro(cons->car); + if (m) + return m; + cons = ao_lisp_poly_cons(cons->cdr); + } + return AO_LISP_NIL; + + default: + return AO_LISP_NIL; + } +} + +int +ao_lisp_read_eval_abort(void) +{ + ao_poly in, out = AO_LISP_NIL; + for(;;) { + in = ao_lisp_read(); + if (in == _ao_lisp_atom_eof) + break; + out = ao_lisp_eval(in); + if (ao_lisp_exception) + return 0; + ao_lisp_poly_print(out); + putchar ('\n'); + } + return 1; +} + +static FILE *in; +static FILE *out; + +int +ao_lisp_getc(void) +{ + return getc(in); +} + +static const struct option options[] = { + { .name = "out", .has_arg = 1, .val = 'o' }, + { 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ + fprintf(stderr, "usage: %s [--out=] [input]\n", program); + exit(1); +} + int main(int argc, char **argv) { - int f, o, i; - ao_poly sexpr, val; + int f, o; + ao_poly val; struct ao_lisp_atom *a; struct ao_lisp_builtin *b; int in_atom; + char *out_name; + int c; + + in = stdin; + out = stdout; + + while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { + switch (c) { + case 'o': + out_name = optarg; + break; + default: + usage(argv[0]); + break; + } + } - printf("/*\n"); - printf(" * Generated file, do not edit\n"); - for (f = 0; f < N_FUNC; f++) { + for (f = 0; f < (int) N_FUNC; f++) { b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); ao_lisp_atom_set(ao_lisp_atom_poly(a), @@ -143,47 +254,79 @@ main(int argc, char **argv) ao_lisp_atom_set(ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); - ao_lisp_read_eval_print(); + if (argv[optind]){ + in = fopen(argv[optind], "r"); + if (!in) { + perror(argv[optind]); + exit(1); + } + } + if (!ao_lisp_read_eval_abort()) { + fprintf(stderr, "eval failed\n"); + exit(1); + } /* Reduce to referenced values */ ao_lisp_collect(); - printf(" */\n"); - 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(ao_lisp_frame_global)); - printf("#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); + for (f = 0; f < ao_lisp_frame_global->num; f++) { + val = ao_has_macro(ao_lisp_frame_global->vals[f].val); + if (val != AO_LISP_NIL) { + printf("error: function %s contains unresolved macro: ", + ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); + ao_lisp_poly_print(val); + printf(stderr, "\n"); + exit(1); + } + } + + if (out_name) { + out = fopen(out_name, "w"); + if (!out) { + perror(out_name); + exit(1); + } + } + + fprintf(out, "/* Generated file, do not edit */\n\n"); + + fprintf(out, "#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); + fprintf(out, "extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); + fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); + fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); + fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); + for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; - printf ("#define _ao_lisp_atom_"); + fprintf(out, "#define _ao_lisp_atom_"); while ((c = *n++)) { if (isalnum(c)) - printf("%c", c); + fprintf(out, "%c", c); else - printf("%02x", c); + fprintf(out, "%02x", c); } - printf(" 0x%04x\n", ao_lisp_atom_poly(a)); + fprintf(out, " 0x%04x\n", ao_lisp_atom_poly(a)); } - printf("#ifdef AO_LISP_CONST_BITS\n"); - printf("const uint8_t ao_lisp_const[] = {"); + fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); + fprintf(out, "const uint8_t ao_lisp_const[] = {"); for (o = 0; o < ao_lisp_top; o++) { uint8_t c; if ((o & 0xf) == 0) - printf("\n\t"); + fprintf(out, "\n\t"); else - printf(" "); + fprintf(out, " "); c = ao_lisp_const[o]; if (!in_atom) in_atom = is_atom(o); if (in_atom) { - printf (" '%c',", c); + fprintf(out, " '%c',", c); in_atom--; } else { - printf("0x%02x,", c); + fprintf(out, "0x%02x,", c); } } - printf("\n};\n"); - printf("#endif /* AO_LISP_CONST_BITS */\n"); + fprintf(out, "\n};\n"); + fprintf(out, "#endif /* AO_LISP_CONST_BITS */\n"); + exit(0); } diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h index b7bf7a2c..5fa3686b 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/lisp/ao_lisp_os.h @@ -22,13 +22,10 @@ #include #include -static inline int -ao_lisp_getc() { - return getchar(); -} +extern int ao_lisp_getc(void); static inline void -ao_lisp_os_flush() { +ao_lisp_os_flush(void) { fflush(stdout); } -- cgit v1.2.3 From 881161fe1c5fb0e2b1220c30572eb2c45bedbafe Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 15 Nov 2016 20:18:59 -0800 Subject: altos/lisp: re-use small frames This saves a pile more use of the allocator by noting when frames have not been referenced from another frame and freeing them when they go out of scope. Frames with references are left to the allocator to deal with. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 37 +++++++++++++++++-- src/lisp/ao_lisp_atom.c | 4 +-- src/lisp/ao_lisp_error.c | 6 ++-- src/lisp/ao_lisp_eval.c | 6 +++- src/lisp/ao_lisp_frame.c | 91 +++++++++++++++++++++++++++++++---------------- src/lisp/ao_lisp_lambda.c | 4 +-- src/lisp/ao_lisp_mem.c | 8 +++++ 7 files changed, 116 insertions(+), 40 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 2db4914f..bcb0a17f 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -156,13 +156,33 @@ struct ao_lisp_val { struct ao_lisp_frame { uint8_t type; - uint8_t num; - ao_poly next; + uint8_t _num; + ao_poly prev; struct ao_lisp_val vals[]; }; +#define AO_LISP_FRAME_NUM_MASK 0x7f + +/* Set when the frame escapes the lambda */ +#define AO_LISP_FRAME_MARK 0x80 + +static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { + if (f->_num == 0xff) + ao_lisp_abort(); + return f->_num & AO_LISP_FRAME_NUM_MASK; +} + +static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { + if (f->_num == 0xff) + ao_lisp_abort(); + return f->_num & AO_LISP_FRAME_MARK; +} + static inline struct ao_lisp_frame * ao_lisp_poly_frame(ao_poly poly) { + struct ao_lisp_frame *frame = ao_lisp_ref(poly); + if (frame && frame->_num == 0xff) + ao_lisp_abort(); return ao_lisp_ref(poly); } @@ -500,6 +520,9 @@ ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); +ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom); + ao_poly ao_lisp_atom_get(ao_poly atom); @@ -574,12 +597,22 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; +#define AO_LISP_FRAME_FREE 4 + +extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + +ao_poly +ao_lisp_frame_mark(struct ao_lisp_frame *frame); + ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num); +void +ao_lisp_frame_free(struct ao_lisp_frame *frame); + int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 6705f140..8c9e8ed1 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -108,7 +108,7 @@ ao_lisp_atom_init(void) ao_lisp_frame_global = ao_lisp_frame_new(0); } -static ao_poly * +ao_poly * ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) { ao_poly *ref; @@ -117,7 +117,7 @@ ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) ref = ao_lisp_frame_ref(frame, atom); if (ref) return ref; - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } if (ao_lisp_frame_global) { ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index cfa78d22..2b15c418 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -49,7 +49,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { if (f != 0) { tabs(indent); printf(" "); @@ -59,8 +59,8 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) ao_lisp_poly_print(frame->vals[f].val); printf("\n"); } - if (frame->next) - ao_lisp_error_frame(indent + 1, "next: ", ao_lisp_poly_frame(frame->next)); + if (frame->prev) + ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); } tabs(indent); printf(" }\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3af56796..6f56a120 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -122,7 +122,8 @@ ao_lisp_stack_push(void) static void ao_lisp_stack_pop(void) { - ao_poly prev; + ao_poly prev; + struct ao_lisp_frame *prev_frame; if (!ao_lisp_stack) return; @@ -131,10 +132,13 @@ ao_lisp_stack_pop(void) ao_lisp_stack_free_list = ao_lisp_stack; ao_lisp_stack = ao_lisp_poly_stack(prev); + prev_frame = ao_lisp_frame_current; if (ao_lisp_stack) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else ao_lisp_frame_current = NULL; + if (ao_lisp_frame_current != prev_frame) + ao_lisp_frame_free(prev_frame); DBG_OUT(); DBGI("stack pop\n"); DBG_FRAMES(); diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index e23a6413..052d27d7 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -24,7 +24,7 @@ static int frame_size(void *addr) { struct ao_lisp_frame *frame = addr; - return frame_num_size(frame->num); + return frame_num_size(ao_lisp_frame_num(frame)); } static void @@ -37,7 +37,7 @@ frame_mark(void *addr) MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); @@ -46,7 +46,7 @@ frame_mark(void *addr) MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); } - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) break; @@ -62,13 +62,13 @@ frame_move(void *addr) int f; for (;;) { - struct ao_lisp_frame *next; + struct ao_lisp_frame *prev; int ret; MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); @@ -78,19 +78,19 @@ frame_move(void *addr) MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); } - next = ao_lisp_poly_frame(frame->next); - if (!next) + prev = ao_lisp_poly_frame(frame->prev); + if (!prev) break; - ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &next); - if (next != ao_lisp_poly_frame(frame->next)) { - MDBG_MOVE("frame next moved from %d to %d\n", - MDBG_OFFSET(ao_lisp_poly_frame(frame->next)), - MDBG_OFFSET(next)); - frame->next = ao_lisp_frame_poly(next); + ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); + if (prev != ao_lisp_poly_frame(frame->prev)) { + MDBG_MOVE("frame prev moved from %d to %d\n", + MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), + MDBG_OFFSET(prev)); + frame->prev = ao_lisp_frame_poly(prev); } if (ret) break; - frame = next; + frame = prev; } } @@ -109,15 +109,15 @@ ao_lisp_frame_print(ao_poly p) printf ("{"); if (frame) { - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { if (f != 0) printf(", "); ao_lisp_poly_print(frame->vals[f].atom); printf(" = "); ao_lisp_poly_print(frame->vals[f].val); } - if (frame->next) - ao_lisp_poly_print(frame->next); + if (frame->prev) + ao_lisp_poly_print(frame->prev); } printf("}"); } @@ -126,7 +126,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; - for (f = 0; f < frame->num; f++) + for (f = 0; f < ao_lisp_frame_num(frame); f++) if (frame->vals[f].atom == atom) return &frame->vals[f].val; return NULL; @@ -143,7 +143,7 @@ ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) return 1; } } - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } return 0; } @@ -155,25 +155,55 @@ ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) ao_poly *ref = ao_lisp_frame_ref(frame, atom); if (ref) return *ref; - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } return AO_LISP_NIL; } +struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + struct ao_lisp_frame * ao_lisp_frame_new(int num) { - struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num)); + struct ao_lisp_frame *frame; - if (!frame) - return NULL; + if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) + ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); + else { + frame = ao_lisp_alloc(frame_num_size(num)); + if (!frame) + return NULL; + } frame->type = AO_LISP_FRAME; - frame->num = num; - frame->next = AO_LISP_NIL; + frame->_num = num; + frame->prev = AO_LISP_NIL; memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); return frame; } +ao_poly +ao_lisp_frame_mark(struct ao_lisp_frame *frame) +{ + if (!frame) + return AO_LISP_NIL; + if (frame->_num == 0xff) + ao_lisp_abort(); + frame->_num |= AO_LISP_FRAME_MARK; + return ao_lisp_frame_poly(frame); +} + +void +ao_lisp_frame_free(struct ao_lisp_frame *frame) +{ + if (!ao_lisp_frame_marked(frame)) { + int num = ao_lisp_frame_num(frame); + if (num < AO_LISP_FRAME_FREE) { + frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); + ao_lisp_frame_free_list[num] = frame; + } + } +} + static struct ao_lisp_frame * ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) { @@ -181,7 +211,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) struct ao_lisp_frame *new; int copy; - if (new_num == frame->num) + if (new_num == ao_lisp_frame_num(frame)) return frame; new = ao_lisp_frame_new(new_num); if (!new) @@ -192,10 +222,11 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) */ frame = *frame_ref; copy = new_num; - if (copy > frame->num) - copy = frame->num; + if (copy > ao_lisp_frame_num(frame)) + copy = ao_lisp_frame_num(frame); memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); - new->next = frame->next; + new->prev = frame->prev; + ao_lisp_frame_free(frame); return new; } @@ -210,7 +241,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); if (frame) { - f = frame->num; + f = ao_lisp_frame_num(frame); frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 0dd8c698..8b761714 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -94,7 +94,7 @@ ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) lambda->type = AO_LISP_LAMBDA; lambda->args = args; lambda->code = ao_lisp_cons_poly(code); - lambda->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); DBG_STACK(); return ao_lisp_lambda_poly(lambda); @@ -179,7 +179,7 @@ ao_lisp_lambda_eval(void) next_frame->vals[0].val = cons->cdr; break; } - next_frame->next = lambda->frame; + next_frame->prev = lambda->frame; DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); ao_lisp_frame_current = next_frame; ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index e7ece960..7e7464c4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -214,8 +214,16 @@ static const struct ao_lisp_root ao_lisp_root[] = { static const void ** const ao_lisp_cache[] = { (const void **) &ao_lisp_cons_free_list, (const void **) &ao_lisp_stack_free_list, + (const void **) &ao_lisp_frame_free_list[0], + (const void **) &ao_lisp_frame_free_list[1], + (const void **) &ao_lisp_frame_free_list[2], + (const void **) &ao_lisp_frame_free_list[3], }; +#if AO_LISP_FRAME_FREE != 4 +#error Unexpected AO_LISP_FRAME_FREE value +#endif + #define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) #define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) -- cgit v1.2.3 From c8f9db184cc929ebde845730a6d4b7864e423a84 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 16 Nov 2016 12:34:14 -0800 Subject: altos/lisp: Add incremental collection Realizing that long-lived objects will eventually float to the bottom of the heap, I added a simple hack to the collector that 'remembers' the top of the heap the last time a full collect was run and then runs incremental collects looking to shift only objects above that boundary. That doesn't perfectly capture the bounds of transient objects, but does manage to reduce the amount of time spent not moving persistent objects each time through the collector. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 10 +++-- src/lisp/ao_lisp_make_const.c | 4 +- src/lisp/ao_lisp_mem.c | 97 +++++++++++-------------------------------- src/lisp/ao_lisp_save.c | 4 +- src/test/ao_lisp_test.c | 7 +++- 5 files changed, 42 insertions(+), 80 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index bcb0a17f..e9432913 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -421,7 +421,8 @@ ao_lisp_builtin_poly(struct ao_lisp_builtin *b) /* memory functions */ -extern int ao_lisp_collects; +extern int ao_lisp_collects[2]; +extern int ao_lisp_freed[2]; /* returns 1 if the object was already marked */ int @@ -445,8 +446,11 @@ ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); void * ao_lisp_alloc(int size); -void -ao_lisp_collect(void); +#define AO_LISP_COLLECT_FULL 1 +#define AO_LISP_COLLECT_INCREMENTAL 0 + +int +ao_lisp_collect(uint8_t style); void ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 416a95d9..60bb80f0 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -147,7 +147,7 @@ ao_lisp_macro_pop(void) free(m); } -#define DBG_MACRO 1 +#define DBG_MACRO 0 #if DBG_MACRO int macro_scan_depth; @@ -355,7 +355,7 @@ main(int argc, char **argv) } /* Reduce to referenced values */ - ao_lisp_collect(); + ao_lisp_collect(AO_LISP_COLLECT_FULL); for (f = 0; f < ao_lisp_frame_num(ao_lisp_frame_global); f++) { val = ao_has_macro(ao_lisp_frame_global->vals[f].val); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 7e7464c4..37d0af2b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -36,10 +36,6 @@ uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4 #endif -#if 0 -#define MDBG_POOL -#endif - #if DBG_MEM int dbg_move_depth; int dbg_mem = DBG_MEM_START; @@ -436,15 +432,19 @@ ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) return ao_lisp_poly_mark(*p, do_note_cons); } -int ao_lisp_collects; +int ao_lisp_collects[2]; +int ao_lisp_freed[2]; -void -ao_lisp_collect(void) +int ao_lisp_last_top; + +int +ao_lisp_collect(uint8_t style) { + int ret; int i; int top; -#if DBG_MEM int loops = 0; +#if DBG_MEM int marked; int moved; struct ao_lisp_record *mark_record = NULL, *move_record = NULL; @@ -453,15 +453,18 @@ ao_lisp_collect(void) marked = moved = 0; #endif - ++ao_lisp_collects; + ++ao_lisp_collects[style]; /* Clear references to all caches */ for (i = 0; i < (int) AO_LISP_CACHE; i++) *ao_lisp_cache[i] = NULL; - chunk_low = 0; - top = 0; + if (style == AO_LISP_COLLECT_FULL) { + chunk_low = top = 0; + } else { + chunk_low = top = ao_lisp_last_top; + } for (;;) { - MDBG_DO(loops++); + loops++; MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); /* Find the sizes of the first chunk of objects to move */ memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); @@ -542,12 +545,18 @@ ao_lisp_collect(void) if (chunk_last != AO_LISP_NCHUNK) break; } + ret = ao_lisp_top - top; + ao_lisp_freed[style] += ret; + ao_lisp_top = top; + if (style == AO_LISP_COLLECT_FULL || ao_lisp_last_top == 0) + ao_lisp_last_top = top; MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); -// printf ("collect. top %d loops %d\n", top, loops); +// printf ("collect. style %d loops %d freed %d\n", style, loops, ret); + return ret; } /* @@ -737,45 +746,6 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) return ret; } -#ifdef MDBG_POOL -static int AO_LISP_POOL_CUR = AO_LISP_POOL / 8; - -static void -ao_lisp_poison(void) -{ - int i; - - printf("poison\n"); - ao_lisp_mark_busy(); - for (i = 0; i < AO_LISP_POOL_CUR; i += 4) { - uint32_t *a = (uint32_t *) &ao_lisp_pool[i]; - if (!busy_object(ao_lisp_busy, a)) - *a = 0xBEEFBEEF; - } - for (i = 0; i < AO_LISP_POOL_CUR; i += 2) { - ao_poly *a = (uint16_t *) &ao_lisp_pool[i]; - ao_poly p = *a; - - if (!ao_lisp_is_const(p)) { - void *r = ao_lisp_ref(p); - - if (ao_lisp_pool <= (uint8_t *) r && - (uint8_t *) r <= ao_lisp_pool + AO_LISP_POOL_CUR) - { - if (!busy_object(ao_lisp_busy, r)) { - printf("missing reference from %d to %d\n", - (int) ((uint8_t *) a - ao_lisp_pool), - (int) ((uint8_t *) r - ao_lisp_pool)); - } - } - } - } -} - -#else -#define AO_LISP_POOL_CUR AO_LISP_POOL -#endif - #if DBG_MEM void ao_lisp_validate(void) @@ -789,7 +759,6 @@ int dbg_allocs; #endif - void * ao_lisp_alloc(int size) { @@ -798,26 +767,10 @@ ao_lisp_alloc(int size) MDBG_DO(++dbg_allocs); MDBG_DO(if (dbg_validate) ao_lisp_validate()); size = ao_lisp_size_round(size); - if (ao_lisp_top + size > AO_LISP_POOL_CUR) { -#ifdef MDBG_POOL - if (AO_LISP_POOL_CUR < AO_LISP_POOL) { - AO_LISP_POOL_CUR += AO_LISP_POOL / 8; - ao_lisp_poison(); - } else -#endif - ao_lisp_collect(); -#ifdef MDBG_POOL + if (ao_lisp_top + size > AO_LISP_POOL) { + if (!ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) && + !ao_lisp_collect(AO_LISP_COLLECT_FULL)) { - int i; - - for (i = ao_lisp_top; i < AO_LISP_POOL; i += 4) { - uint32_t *p = (uint32_t *) &ao_lisp_pool[i]; - *p = 0xbeefbeef; - } - } -#endif - - if (ao_lisp_top + size > AO_LISP_POOL) { ao_lisp_error(AO_LISP_OOM, "out of memory"); return NULL; } diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index d5f28e7d..e6e8b65e 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -23,7 +23,7 @@ ao_lisp_save(struct ao_lisp_cons *cons) #ifdef AO_LISP_SAVE struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) &ao_lisp_pool[AO_LISP_POOL]; - ao_lisp_collect(); + ao_lisp_collect(AO_LISP_COLLECT_FULL); os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); os->const_checksum = ao_lisp_const_checksum; @@ -64,7 +64,7 @@ ao_lisp_restore(struct ao_lisp_cons *cons) /* Reset the allocator */ ao_lisp_top = AO_LISP_POOL; - ao_lisp_collect(); + ao_lisp_collect(AO_LISP_COLLECT_FULL); /* Re-create the evaluator stack */ if (!ao_lisp_eval_restart()) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index bbaa3f9d..720355d2 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -101,5 +101,10 @@ main (int argc, char **argv) ao_lisp_file = NULL; } ao_lisp_read_eval_print(); - printf ("%d collects\n", ao_lisp_collects); + printf ("collects: full: %d incremental %d\n", + ao_lisp_collects[AO_LISP_COLLECT_FULL], + ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + printf ("freed: full %d incremental %d\n", + ao_lisp_freed[AO_LISP_COLLECT_FULL], + ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); } -- cgit v1.2.3 From daa06c8dedc6dc1cf21936ee2769d9d25f0567bd Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 16 Nov 2016 13:19:20 -0800 Subject: altos/lisp: Optimize chunk searching in collect Note range of existing chunks to exclude objects outside. Only look at chunks which have been set to reduce loop cost. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 1 + src/lisp/ao_lisp_const.lisp | 62 ++++++++++++++++++++++--------------------- src/lisp/ao_lisp_make_const.c | 3 ++- src/lisp/ao_lisp_mem.c | 54 ++++++++++++++++++++++++++----------- src/test/ao_lisp_test.c | 24 +++++++++++++++++ src/test/hanoi.lisp | 11 +++++++- 6 files changed, 107 insertions(+), 48 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index e9432913..ea8d98b5 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -423,6 +423,7 @@ ao_lisp_builtin_poly(struct ao_lisp_builtin *b) extern int ao_lisp_collects[2]; extern int ao_lisp_freed[2]; +extern int ao_lisp_loops[2]; /* returns 1 if the object was already marked */ int diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 4dc63bbf..6fbc35b6 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -75,32 +75,6 @@ (defun 1+ (x) (+ x 1)) (defun 1- (x) (- x 1)) - ; boolean operators - -(def or (lexpr (l) - (let ((ret nil)) - (while l - (cond ((setq ret (car l)) - (setq l nil)) - ((setq l (cdr l))))) - ret - ) - ) - ) - -(def and (lexpr (l) - (let ((ret t)) - (while l - (cond ((setq ret (car l)) - (setq l (cdr l))) - ((setq ret (setq l nil))) - ) - ) - ret - ) - ) - ) - ; define a set of local ; variables and then evaluate ; a list of sexprs @@ -192,9 +166,37 @@ ) ) - ; run the let macro once to - ; evaluate all of the internal - ; macro calls + ; boolean operators + +(def or (lexpr (l) + (let ((ret nil)) + (while l + (cond ((setq ret (car l)) + (setq l nil)) + ((setq l (cdr l))))) + ret + ) + ) + ) + + ; execute to resolve macros + +(or nil t) + +(def and (lexpr (l) + (let ((ret t)) + (while l + (cond ((setq ret (car l)) + (setq l (cdr l))) + ((setq ret (setq l nil))) + ) + ) + ret + ) + ) + ) + + ; execute to resolve macros -(let ((let-param 1))) +(and t nil) diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 60bb80f0..0f243eb0 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -136,6 +136,7 @@ ao_lisp_macro_push(ao_poly p) m->p = p; m->next = macro_stack; macro_stack = m; + return 0; } void @@ -397,7 +398,7 @@ main(int argc, char **argv) fprintf(out, " 0x%04x\n", ao_lisp_atom_poly(a)); } fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); - fprintf(out, "const uint8_t ao_lisp_const[] = {"); + fprintf(out, "const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute((aligned(4))) = {"); for (o = 0; o < ao_lisp_top; o++) { uint8_t c; if ((o & 0xf) == 0) diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 37d0af2b..b681dbd5 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -307,18 +307,19 @@ note_cons(void *addr) } } -static uint16_t chunk_low; +static uint16_t chunk_low, chunk_high; static uint16_t chunk_first, chunk_last; +static int chunk_busy; static void note_chunk(uint16_t addr, uint16_t size) { int i; - if (addr < chunk_low) + if (addr < chunk_low || chunk_high < addr) return; - for (i = 0; i < AO_LISP_NCHUNK; i++) { + for (i = 0; i < chunk_busy; i++) { if (ao_lisp_chunk[i].size && ao_lisp_chunk[i].old_addr == addr) { #if DBG_MEM if (ao_lisp_chunk[i].size != size) @@ -327,17 +328,30 @@ note_chunk(uint16_t addr, uint16_t size) return; } if (ao_lisp_chunk[i].old_addr > addr) { + int end = min(AO_LISP_NCHUNK, chunk_busy + 1); memmove(&ao_lisp_chunk[i+1], &ao_lisp_chunk[i], - (AO_LISP_NCHUNK - (i+1)) * sizeof (struct ao_lisp_chunk)); - ao_lisp_chunk[i].size = 0; - } - if (ao_lisp_chunk[i].size == 0) { - ao_lisp_chunk[i].old_addr = addr; - ao_lisp_chunk[i].size = size; - return; + (end - (i+1)) * sizeof (struct ao_lisp_chunk)); + break; } } + if (i < AO_LISP_NCHUNK) { + ao_lisp_chunk[i].old_addr = addr; + ao_lisp_chunk[i].size = size; + if (chunk_busy < AO_LISP_NCHUNK) + chunk_busy++; + else + chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_addr + + ao_lisp_chunk[AO_LISP_NCHUNK-1].size; + } +} + +static void +reset_chunks(void) +{ + memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + chunk_high = ao_lisp_top; + chunk_busy = 0; } /* @@ -434,6 +448,7 @@ ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) int ao_lisp_collects[2]; int ao_lisp_freed[2]; +int ao_lisp_loops[2]; int ao_lisp_last_top; @@ -453,7 +468,9 @@ ao_lisp_collect(uint8_t style) marked = moved = 0; #endif - ++ao_lisp_collects[style]; + /* The first time through, we're doing a full collect */ + if (ao_lisp_last_top == 0) + style = AO_LISP_COLLECT_FULL; /* Clear references to all caches */ for (i = 0; i < (int) AO_LISP_CACHE; i++) @@ -467,7 +484,7 @@ ao_lisp_collect(uint8_t style) loops++; MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); /* Find the sizes of the first chunk of objects to move */ - memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + reset_chunks(); walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); #if DBG_MEM marked = total_marked; @@ -501,7 +518,6 @@ ao_lisp_collect(uint8_t style) MDBG_MOVE("chunk %d %d not moving\n", ao_lisp_chunk[i].old_addr, ao_lisp_chunk[i].size); - chunk_low = ao_lisp_chunk[i].old_addr + size; } chunk_first = i; @@ -521,7 +537,6 @@ ao_lisp_collect(uint8_t style) &ao_lisp_pool[ao_lisp_chunk[i].old_addr], size); top += size; - chunk_low = ao_lisp_chunk[i].old_addr + size; } chunk_last = i; @@ -544,18 +559,25 @@ ao_lisp_collect(uint8_t style) if (chunk_last != AO_LISP_NCHUNK) break; + + chunk_low = chunk_high; } + + /* Compute amount of memory freed */ ret = ao_lisp_top - top; + + /* Collect stats */ + ++ao_lisp_collects[style]; ao_lisp_freed[style] += ret; + ao_lisp_loops[style] += loops; ao_lisp_top = top; - if (style == AO_LISP_COLLECT_FULL || ao_lisp_last_top == 0) + if (style == AO_LISP_COLLECT_FULL) ao_lisp_last_top = top; MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); -// printf ("collect. style %d loops %d freed %d\n", style, loops, ret); return ret; } diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 720355d2..68e3a202 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -101,10 +101,34 @@ main (int argc, char **argv) ao_lisp_file = NULL; } ao_lisp_read_eval_print(); + printf ("collects: full: %d incremental %d\n", ao_lisp_collects[AO_LISP_COLLECT_FULL], ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + printf ("freed: full %d incremental %d\n", ao_lisp_freed[AO_LISP_COLLECT_FULL], ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); + + printf("loops: full %d incremental %d\n", + ao_lisp_loops[AO_LISP_COLLECT_FULL], + ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); + + printf("loops per collect: full %f incremental %f\n", + (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], + (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf("freed per collect: full %f incremental %f\n", + (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], + (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf("freed per loop: full %f incremental %f\n", + (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], + (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); } diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index 387e696a..7a25656c 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -126,7 +126,7 @@ (setq stacks (replace stacks from from-stack)) (setq stacks (replace stacks to to-stack)) (display) - (delay 100) +; (delay 100) ) ) @@ -158,3 +158,12 @@ (clear) (_hanoi len 0 1 2) ) + +(defun hanois(n) + (while (> n 0) + (progn + (hanoi) + (setq l (1- l)) + ) + ) + ) -- cgit v1.2.3 From bcf5eb5825b1217d74f117b02d09b4ce4b007beb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 16 Nov 2016 14:12:59 -0800 Subject: altos/lisp: Eliminate compiler warning about array bounds at -O3 Using ao_lisp_pool - 4 caused the compiler to whinge about computing an address outside the bounds of the array. Sigh. Restructure the code to do the adjustment-by-4 in the integer computations instead of the pointer ones. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 3 --- src/lisp/ao_lisp_mem.c | 17 ----------------- src/lisp/ao_lisp_poly.c | 8 ++++---- src/test/Makefile | 2 +- 4 files changed, 5 insertions(+), 25 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index ea8d98b5..25d13fa3 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -118,9 +118,6 @@ 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) diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 53ebf757..12a5ba55 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -252,23 +252,6 @@ static inline uint16_t pool_offset(void *addr) { return ((uint8_t *) addr) - ao_lisp_pool; } -/* - * Convert back and forth between 'poly's used - * as short addresses in the pool and addresses. - * These are used in the chunk code. - */ -static inline ao_poly pool_poly(void *addr) { -#if DBG_MEM - if (!AO_LISP_IS_POOL(addr)) - ao_lisp_abort(); -#endif - return ((uint8_t *) addr) - AO_LISP_POOL_BASE; -} - -static inline void *pool_ref(ao_poly p) { - return AO_LISP_POOL_BASE + p; -} - static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 9717fd73..236176e7 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -89,8 +89,8 @@ ao_lisp_ref(ao_poly poly) { if (poly == AO_LISP_NIL) return NULL; if (poly & AO_LISP_CONST) - return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); - return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); + return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); + return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); } ao_poly @@ -99,6 +99,6 @@ ao_lisp_poly(const void *addr, ao_poly type) { if (a == NULL) 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; + return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; + return (a - ao_lisp_pool + 4) | type; } diff --git a/src/test/Makefile b/src/test/Makefile index fae46ac8..0eaa9421 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -10,7 +10,7 @@ INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quat KALMAN=make-kalman -CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O3 -g -Wall -DAO_LISP_TEST -no-pie +CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall -DAO_LISP_TEST -no-pie all: $(PROGS) ao_aprs_data.wav -- cgit v1.2.3 From 2ce7ab37df07b3c1ea1ca9befc06477e3b6cdeac Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 17 Nov 2016 16:04:38 -0800 Subject: altos/lisp: Remove some stale frame debugging checks No-one sets frame->_num to 0xff to hit these Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 7 ------- src/lisp/ao_lisp_frame.c | 2 -- 2 files changed, 9 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 25d13fa3..bcefbabf 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -164,22 +164,15 @@ struct ao_lisp_frame { #define AO_LISP_FRAME_MARK 0x80 static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { - if (f->_num == 0xff) - ao_lisp_abort(); return f->_num & AO_LISP_FRAME_NUM_MASK; } static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - if (f->_num == 0xff) - ao_lisp_abort(); return f->_num & AO_LISP_FRAME_MARK; } static inline struct ao_lisp_frame * ao_lisp_poly_frame(ao_poly poly) { - struct ao_lisp_frame *frame = ao_lisp_ref(poly); - if (frame && frame->_num == 0xff) - ao_lisp_abort(); return ao_lisp_ref(poly); } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 052d27d7..9d17f6fa 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -186,8 +186,6 @@ ao_lisp_frame_mark(struct ao_lisp_frame *frame) { if (!frame) return AO_LISP_NIL; - if (frame->_num == 0xff) - ao_lisp_abort(); frame->_num |= AO_LISP_FRAME_MARK; return ao_lisp_frame_poly(frame); } -- cgit v1.2.3 From e600fc409c577eec02af612a36431c477a9c875e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 19:04:05 -0800 Subject: altos/lisp: Add continuations This provides call/cc and makes 'stacks' visible to the application. Signed-off-by: Keith Packard --- src/lisp/Makefile | 1 + src/lisp/ao_lisp.h | 77 +++++++++--- src/lisp/ao_lisp_builtin.c | 6 +- src/lisp/ao_lisp_error.c | 82 +++++-------- src/lisp/ao_lisp_eval.c | 151 ++++------------------- src/lisp/ao_lisp_frame.c | 44 ++++--- src/lisp/ao_lisp_lambda.c | 3 +- src/lisp/ao_lisp_make_const.c | 3 +- src/lisp/ao_lisp_mem.c | 28 +++++ src/lisp/ao_lisp_poly.c | 4 + src/lisp/ao_lisp_stack.c | 279 ++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 461 insertions(+), 217 deletions(-) create mode 100644 src/lisp/ao_lisp_stack.c (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 15297999..dd5a0cb4 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -21,6 +21,7 @@ SRCS=\ ao_lisp_eval.c \ ao_lisp_rep.c \ ao_lisp_save.c \ + ao_lisp_stack.c \ ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index bcefbabf..a8e1715a 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -75,6 +75,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_eof _atom("eof") #define _ao_lisp_atom_save _atom("save") #define _ao_lisp_atom_restore _atom("restore") +#define _ao_lisp_atom_call2fcc _atom("call/cc") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -99,7 +100,11 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA]; #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 #define AO_LISP_LAMBDA 7 -#define AO_LISP_NUM_TYPE 8 +#define AO_LISP_STACK 8 +#define AO_LISP_NUM_TYPE 9 + +/* Leave two bits for types to use as they please */ +#define AO_LISP_OTHER_TYPE_MASK 0x3f #define AO_LISP_NIL 0 @@ -153,22 +158,17 @@ struct ao_lisp_val { struct ao_lisp_frame { uint8_t type; - uint8_t _num; + uint8_t num; ao_poly prev; struct ao_lisp_val vals[]; }; -#define AO_LISP_FRAME_NUM_MASK 0x7f - -/* Set when the frame escapes the lambda */ +/* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 - -static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_NUM_MASK; -} +#define AO_LISP_FRAME_PRINT 0x40 static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_MARK; + return f->type & AO_LISP_FRAME_MARK; } static inline struct ao_lisp_frame * @@ -195,6 +195,7 @@ enum eval_state { }; struct ao_lisp_stack { + uint8_t type; /* AO_LISP_STACK */ uint8_t state; /* enum eval_state */ ao_poly prev; /* previous stack frame */ ao_poly sexprs; /* expressions to evaluate */ @@ -204,6 +205,17 @@ struct ao_lisp_stack { ao_poly list; /* most recent function call */ }; +#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { + return s->type & AO_LISP_STACK_MARK; +} + +static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { + s->type |= AO_LISP_STACK_MARK; +} + static inline struct ao_lisp_stack * ao_lisp_poly_stack(ao_poly p) { @@ -216,8 +228,6 @@ ao_lisp_stack_poly(struct ao_lisp_stack *stack) return ao_lisp_poly(stack, AO_LISP_OTHER); } -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 @@ -276,6 +286,7 @@ enum ao_lisp_builtin_id { builtin_led, builtin_save, builtin_restore, + builtin_call_cc, _builtin_last }; @@ -315,7 +326,7 @@ ao_lisp_poly_other(ao_poly poly) { static inline uint8_t ao_lisp_other_type(void *other) { - return *((uint8_t *) other); + return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; } static inline ao_poly @@ -455,6 +466,12 @@ ao_lisp_string_stash(int id, char *string); char * ao_lisp_string_fetch(int id); +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack); + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id); + void ao_lisp_poly_stash(int id, ao_poly poly); @@ -617,6 +634,8 @@ ao_lisp_frame_print(ao_poly p); /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; +extern const char *ao_lisp_state_names[]; + struct ao_lisp_lambda * ao_lisp_lambda_new(ao_poly cons); @@ -646,12 +665,40 @@ ao_lisp_save(struct ao_lisp_cons *cons); ao_poly ao_lisp_restore(struct ao_lisp_cons *cons); -/* error */ +/* stack */ extern const struct ao_lisp_type ao_lisp_stack_type; +extern struct ao_lisp_stack *ao_lisp_stack; +extern struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack); + +int +ao_lisp_stack_push(void); + +void +ao_lisp_stack_pop(void); + +void +ao_lisp_stack_clear(void); + +void +ao_lisp_stack_print(ao_poly stack); + +ao_poly +ao_lisp_stack_eval(void); + +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons); + +/* error */ + +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); void -ao_lisp_stack_print(void); +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); ao_poly ao_lisp_error(int error, char *format, ...); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6cbcb92c..4c845307 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -86,6 +86,7 @@ static const ao_poly builtin_names[] = { [builtin_led] = _ao_lisp_atom_led, [builtin_save] = _ao_lisp_atom_save, [builtin_restore] = _ao_lisp_atom_restore, + [builtin_call_cc] = _ao_lisp_atom_call2fcc, }; @@ -117,9 +118,7 @@ void ao_lisp_builtin_print(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("[builtin %s %s]", - ao_lisp_args_name(builtin->args), - ao_lisp_builtin_name(builtin->func)); + printf("%s", ao_lisp_builtin_name(builtin->func)); } ao_poly @@ -599,5 +598,6 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_delay] = ao_lisp_delay, [builtin_save] = ao_lisp_save, [builtin_restore] = ao_lisp_restore, + [builtin_call_cc] = ao_lisp_call_cc, }; diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 937739e9..54a9be10 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -15,23 +15,24 @@ #include "ao_lisp.h" #include -static void -ao_lisp_error_poly(char *name, ao_poly poly) +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) { int first = 1; printf("\t\t%s(", name); if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); - - if (cons) { - while (cons) { + if (poly) { + while (poly) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); if (!first) printf("\t\t "); else first = 0; ao_lisp_poly_print(cons->car); printf("\n"); - cons = ao_lisp_poly_cons(cons->cdr); + if (poly == last) + break; + poly = cons->cdr; } printf("\t\t )\n"); } else @@ -48,7 +49,7 @@ static void tabs(int indent) printf("\t"); } -static void +void ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) { int f; @@ -56,51 +57,30 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) { - tabs(indent); - printf(" "); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + printf("\n"); } - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); - printf("\n"); + if (frame->prev) + ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - } - tabs(indent); - printf(" }\n"); + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); } -static const char *state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", -}; - -void -ao_lisp_stack_print(void) -{ - struct ao_lisp_stack *s; - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); - printf("Stack:\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); - printf("\t\tstate: %s\n", state_names[s->state]); -// printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); - ao_lisp_error_poly ("sexprs: ", s->sexprs); - ao_lisp_error_poly ("values: ", s->values); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); -// ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); - printf("\t]\n"); - } -} ao_poly ao_lisp_error(int error, char *format, ...) @@ -112,7 +92,9 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); - ao_lisp_stack_print(); + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Stack:\n"); + ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); printf("Globals:\n\t"); ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); printf("\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index ef521605..2460a32a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -16,68 +16,9 @@ #include "ao_lisp.h" #include -const struct ao_lisp_type ao_lisp_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_lisp_stack *stack = addr; - for (;;) { - ao_lisp_poly_mark(stack->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; -struct ao_lisp_stack *ao_lisp_stack_free_list; - ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -86,72 +27,6 @@ ao_lisp_set_cond(struct ao_lisp_cons *c) return AO_LISP_NIL; } -static void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - - -static int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack; - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - } - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - ao_lisp_stack = stack; - ao_lisp_stack_reset(stack); - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -static void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -static void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - static int func_type(ao_poly func) { @@ -162,6 +37,8 @@ func_type(ao_poly func) return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; case AO_LISP_LAMBDA: return ao_lisp_poly_lambda(func)->args; + case AO_LISP_STACK: + return AO_LISP_FUNC_LAMBDA; default: ao_lisp_error(AO_LISP_INVALID, "not a func"); return -1; @@ -392,10 +269,12 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS) + if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; @@ -404,12 +283,18 @@ ao_lisp_eval_exec(void) ao_lisp_stack->state = eval_progn; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; + case AO_LISP_STACK: + DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_v = ao_lisp_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + break; } - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; return 1; } @@ -599,6 +484,16 @@ static int (*const evals[])(void) = { [eval_macro] = ao_lisp_eval_macro, }; +const char *ao_lisp_state_names[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", + "progn", +}; + /* * Called at restore time to reset all execution state */ diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 9d17f6fa..17fa141a 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -24,7 +24,7 @@ static int frame_size(void *addr) { struct ao_lisp_frame *frame = addr; - return frame_num_size(ao_lisp_frame_num(frame)); + return frame_num_size(frame->num); } static void @@ -37,7 +37,7 @@ frame_mark(void *addr) MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); @@ -68,7 +68,7 @@ frame_move(void *addr) MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); @@ -109,15 +109,21 @@ ao_lisp_frame_print(ao_poly p) printf ("{"); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + } + if (frame->prev) + ao_lisp_poly_print(frame->prev); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_poly_print(frame->prev); } printf("}"); } @@ -126,7 +132,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; - for (f = 0; f < ao_lisp_frame_num(frame); f++) + for (f = 0; f < frame->num; f++) if (frame->vals[f].atom == atom) return &frame->vals[f].val; return NULL; @@ -175,7 +181,7 @@ ao_lisp_frame_new(int num) return NULL; } frame->type = AO_LISP_FRAME; - frame->_num = num; + frame->num = num; frame->prev = AO_LISP_NIL; memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); return frame; @@ -186,7 +192,7 @@ ao_lisp_frame_mark(struct ao_lisp_frame *frame) { if (!frame) return AO_LISP_NIL; - frame->_num |= AO_LISP_FRAME_MARK; + frame->type |= AO_LISP_FRAME_MARK; return ao_lisp_frame_poly(frame); } @@ -194,7 +200,7 @@ void ao_lisp_frame_free(struct ao_lisp_frame *frame) { if (!ao_lisp_frame_marked(frame)) { - int num = ao_lisp_frame_num(frame); + int num = frame->num; if (num < AO_LISP_FRAME_FREE) { frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); ao_lisp_frame_free_list[num] = frame; @@ -209,7 +215,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) struct ao_lisp_frame *new; int copy; - if (new_num == ao_lisp_frame_num(frame)) + if (new_num == frame->num) return frame; new = ao_lisp_frame_new(new_num); if (!new) @@ -220,8 +226,8 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) */ frame = *frame_ref; copy = new_num; - if (copy > ao_lisp_frame_num(frame)) - copy = ao_lisp_frame_num(frame); + if (copy > frame->num) + copy = frame->num; memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); new->prev = frame->prev; ao_lisp_frame_free(frame); @@ -239,7 +245,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); if (frame) { - f = ao_lisp_frame_num(frame); + f = frame->num; frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index e2053a6f..656936cb 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -175,7 +175,8 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } - ao_lisp_cons_free(cons); + if (!ao_lisp_stack_marked(ao_lisp_stack)) + ao_lisp_cons_free(cons); cons = NULL; break; case AO_LISP_FUNC_LEXPR: diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 495e48cd..de9c5725 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -71,6 +71,7 @@ struct builtin_func funcs[] = { { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, + { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) @@ -358,7 +359,7 @@ main(int argc, char **argv) /* Reduce to referenced values */ ao_lisp_collect(AO_LISP_COLLECT_FULL); - for (f = 0; f < ao_lisp_frame_num(ao_lisp_frame_global); f++) { + for (f = 0; f < ao_lisp_frame_global->num; f++) { val = ao_has_macro(ao_lisp_frame_global->vals[f].val); if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 12a5ba55..0dfad1d7 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -144,6 +144,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; +static struct ao_lisp_stack *save_stack[3]; static ao_poly save_poly[2]; static const struct ao_lisp_root ao_lisp_root[] = { @@ -155,6 +156,18 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_cons_type, .addr = (void **) &save_cons[1], }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[0] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[1] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[2] + }, { .type = &ao_lisp_string_type, .addr = (void **) &save_string[0] @@ -434,6 +447,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, + [AO_LISP_STACK] = &ao_lisp_stack_type, }; static int @@ -818,6 +832,20 @@ ao_lisp_cons_fetch(int id) return cons; } +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) +{ + save_stack[id] = stack; +} + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id) +{ + struct ao_lisp_stack *stack = save_stack[id]; + save_stack[id] = NULL; + return stack; +} + void ao_lisp_string_stash(int id, char *string) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 236176e7..800ee06d 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -54,6 +54,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .print = ao_lisp_lambda_print, .patom = ao_lisp_lambda_print, }, + [AO_LISP_STACK] = { + .print = ao_lisp_stack_print, + .patom = ao_lisp_stack_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c new file mode 100644 index 00000000..9c773e83 --- /dev/null +++ b/src/lisp/ao_lisp_stack.c @@ -0,0 +1,279 @@ +/* + * 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. + */ + +#define DBG_EVAL 0 +#include "ao_lisp.h" + +const struct ao_lisp_type ao_lisp_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_lisp_stack *stack = addr; + for (;;) { + ao_lisp_poly_mark(stack->sexprs, 0); + ao_lisp_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_lisp_poly_mark(stack->frame, 0); + ao_lisp_poly_mark(stack->list, 0); + stack = ao_lisp_poly_stack(stack->prev); + if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + while (stack) { + struct ao_lisp_stack *prev; + int ret; + (void) ao_lisp_poly_move(&stack->sexprs, 0); + (void) ao_lisp_poly_move(&stack->values, 0); + (void) ao_lisp_poly_move(&stack->values_tail, 0); + (void) ao_lisp_poly_move(&stack->frame, 0); + (void) ao_lisp_poly_move(&stack->list, 0); + prev = ao_lisp_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); + if (prev != ao_lisp_poly_stack(stack->prev)) + stack->prev = ao_lisp_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_LISP_NIL; + stack->values = AO_LISP_NIL; + stack->values_tail = AO_LISP_NIL; +} + +static struct ao_lisp_stack * +ao_lisp_stack_new(void) +{ + struct ao_lisp_stack *stack; + + if (ao_lisp_stack_free_list) { + stack = ao_lisp_stack_free_list; + ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); + } else { + stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!stack) + return 0; + stack->type = AO_LISP_STACK; + } + ao_lisp_stack_reset(stack); + return stack; +} + +int +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *stack = ao_lisp_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_lisp_stack_poly(ao_lisp_stack); + stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack->list = AO_LISP_NIL; + + ao_lisp_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_lisp_stack_pop(void) +{ + ao_poly prev; + struct ao_lisp_frame *prev_frame; + + if (!ao_lisp_stack) + return; + prev = ao_lisp_stack->prev; + if (!ao_lisp_stack_marked(ao_lisp_stack)) { + ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); + ao_lisp_stack_free_list = ao_lisp_stack; + } + + ao_lisp_stack = ao_lisp_poly_stack(prev); + prev_frame = ao_lisp_frame_current; + if (ao_lisp_stack) + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + else + ao_lisp_frame_current = NULL; + if (ao_lisp_frame_current != prev_frame) + ao_lisp_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_lisp_stack_clear(void) +{ + ao_lisp_stack = NULL; + ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; +} + +void +ao_lisp_stack_print(ao_poly poly) +{ + struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); + + if (s->type & AO_LISP_STACK_PRINT) { + printf("[recurse...]"); + return; + } + while (s) { + s->type |= AO_LISP_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); + ao_lisp_error_poly ("values: ", s->values, s->values_tail); + ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); + ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_LISP_STACK_PRINT; + s = ao_lisp_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_lisp_stack * +ao_lisp_stack_copy(struct ao_lisp_stack *old) +{ + struct ao_lisp_stack *new = NULL; + struct ao_lisp_stack *n, *prev = NULL; + + while (old) { + ao_lisp_stack_stash(0, old); + ao_lisp_stack_stash(1, new); + ao_lisp_stack_stash(2, prev); + n = ao_lisp_stack_new(); + prev = ao_lisp_stack_fetch(2); + new = ao_lisp_stack_fetch(1); + old = ao_lisp_stack_fetch(0); + if (!n) + return NULL; + + ao_lisp_stack_mark(old); + ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_lisp_stack_poly(n); + else + new = n; + prev = n; + + old = ao_lisp_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_lisp_stack_eval(void) +{ + struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); + if (!new) + return AO_LISP_NIL; + + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + + if (!cons || !cons->cdr) + return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_lisp_stack = new; + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + + return ao_lisp_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons) +{ + struct ao_lisp_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) + return AO_LISP_NIL; + + /* go get the lambda */ + ao_lisp_v = ao_lisp_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_lisp_stack_copy(ao_lisp_stack); + if (!new) + return AO_LISP_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_lisp_stack_poly(new); + cons->cdr = AO_LISP_NIL; + v = ao_lisp_lambda_eval(); + ao_lisp_stack->sexprs = v; + ao_lisp_stack->state = eval_progn; + return AO_LISP_NIL; +} -- cgit v1.2.3 From 4c812b8c903bd7e689572f8800ecc092af9cfe18 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 21:12:50 -0800 Subject: altos/lisp: Make DBG settings global This avoids having different values in different files, which wasn't useful. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 8 +++++++- src/lisp/ao_lisp_eval.c | 1 - src/lisp/ao_lisp_lambda.c | 1 - 3 files changed, 7 insertions(+), 3 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a8e1715a..cea834fc 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,6 +15,9 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ +#define DBG_MEM 0 +#define DBG_EVAL 0 + #include #include //#include @@ -326,6 +329,10 @@ ao_lisp_poly_other(ao_poly poly) { static inline uint8_t ao_lisp_other_type(void *other) { +#if DBG_MEM + if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) + ao_lisp_abort(); +#endif return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; } @@ -743,7 +750,6 @@ ao_lisp_frames_dump(void) #define DBG_FRAMES() #endif -#define DBG_MEM 0 #define DBG_MEM_START 1 #if DBG_MEM diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 2460a32a..3be7c9c4 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,6 @@ * General Public License for more details. */ -#define DBG_EVAL 0 #include "ao_lisp.h" #include diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 656936cb..67ad24ee 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -15,7 +15,6 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#define DBG_EVAL 0 #include "ao_lisp.h" int -- cgit v1.2.3 From ecef616599d5ec4fd5d42e67d0dc779a0630079b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 21:14:47 -0800 Subject: altos/lisp: Use poly stashes for stacks Saves some memory. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 24 +++++++++++++---------- src/lisp/ao_lisp_mem.c | 49 ++++++++++++++--------------------------------- src/lisp/ao_lisp_string.c | 2 +- 3 files changed, 29 insertions(+), 46 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index cea834fc..e238d4fe 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -468,22 +468,26 @@ struct ao_lisp_cons * ao_lisp_cons_fetch(int id); void -ao_lisp_string_stash(int id, char *string); +ao_lisp_poly_stash(int id, ao_poly poly); -char * -ao_lisp_string_fetch(int id); +ao_poly +ao_lisp_poly_fetch(int id); void -ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack); +ao_lisp_string_stash(int id, char *string); -struct ao_lisp_stack * -ao_lisp_stack_fetch(int id); +char * +ao_lisp_string_fetch(int id); -void -ao_lisp_poly_stash(int id, ao_poly poly); +static inline void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) { + ao_lisp_poly_stash(id, ao_lisp_stack_poly(stack)); +} -ao_poly -ao_lisp_poly_fetch(int id); +static inline struct ao_lisp_stack * +ao_lisp_stack_fetch(int id) { + return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); +} /* cons */ extern const struct ao_lisp_type ao_lisp_cons_type; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 0dfad1d7..2599f719 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -144,8 +144,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; -static struct ao_lisp_stack *save_stack[3]; -static ao_poly save_poly[2]; +static ao_poly save_poly[3]; static const struct ao_lisp_root ao_lisp_root[] = { { @@ -156,25 +155,13 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_cons_type, .addr = (void **) &save_cons[1], }, - { - .type = &ao_lisp_stack_type, - .addr = (void **) &save_stack[0] - }, - { - .type = &ao_lisp_stack_type, - .addr = (void **) &save_stack[1] - }, - { - .type = &ao_lisp_stack_type, - .addr = (void **) &save_stack[2] - }, { .type = &ao_lisp_string_type, - .addr = (void **) &save_string[0] + .addr = (void **) &save_string[0], }, { .type = &ao_lisp_string_type, - .addr = (void **) &save_string[1] + .addr = (void **) &save_string[1], }, { .type = NULL, @@ -184,6 +171,10 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = NULL, .addr = (void **) &save_poly[1] }, + { + .type = NULL, + .addr = (void **) &save_poly[2] + }, { .type = &ao_lisp_atom_type, .addr = (void **) &ao_lisp_atoms @@ -833,17 +824,17 @@ ao_lisp_cons_fetch(int id) } void -ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) +ao_lisp_poly_stash(int id, ao_poly poly) { - save_stack[id] = stack; + save_poly[id] = poly; } -struct ao_lisp_stack * -ao_lisp_stack_fetch(int id) +ao_poly +ao_lisp_poly_fetch(int id) { - struct ao_lisp_stack *stack = save_stack[id]; - save_stack[id] = NULL; - return stack; + ao_poly poly = save_poly[id]; + save_poly[id] = AO_LISP_NIL; + return poly; } void @@ -859,16 +850,4 @@ ao_lisp_string_fetch(int id) save_string[id] = NULL; return string; } -void -ao_lisp_poly_stash(int id, ao_poly poly) -{ - save_poly[id] = poly; -} -ao_poly -ao_lisp_poly_fetch(int id) -{ - ao_poly poly = save_poly[id]; - save_poly[id] = AO_LISP_NIL; - return poly; -} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 207d4f3b..cd7b27a9 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -104,9 +104,9 @@ ao_lisp_string_unpack(char *a) ao_lisp_cons_stash(1, tail); ao_lisp_string_stash(0, a); struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); + a = ao_lisp_string_fetch(0); cons = ao_lisp_cons_fetch(0); tail = ao_lisp_cons_fetch(1); - a = ao_lisp_string_fetch(0); if (!n) { cons = NULL; -- cgit v1.2.3 From 35424031747b41b1125e715a975f1679b89fc27a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 21:16:11 -0800 Subject: altos/lisp: bounds check in move_map plus binary search This makes move_map faster by skipping all addresses which aren't changing. Also changed the interface from address to offset to avoid computing the offset multiple times. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 1 + src/lisp/ao_lisp_mem.c | 210 ++++++++++++++++++++++++++++--------------------- 2 files changed, 123 insertions(+), 88 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index e238d4fe..af6ff8bb 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -128,6 +128,7 @@ ao_lisp_is_const(ao_poly poly) { #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) +#define AO_LISP_IS_INT(p) (ao_lisp_base_type(p) == AO_LISP_INT); void * ao_lisp_ref(ao_poly poly); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 2599f719..e8907cf6 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -236,10 +236,10 @@ static uint8_t ao_lisp_cons_noted; uint16_t ao_lisp_top; struct ao_lisp_chunk { - uint16_t old_addr; + uint16_t old_offset; union { uint16_t size; - uint16_t new_addr; + uint16_t new_offset; }; }; @@ -284,14 +284,11 @@ static inline int limit(int offset) { static int total_marked; static void -note_cons(void *addr) +note_cons(uint16_t offset) { - if (AO_LISP_IS_POOL(addr)) { - int offset = pool_offset(addr); - MDBG_MOVE("note cons %d\n", MDBG_OFFSET(addr)); - ao_lisp_cons_noted = 1; - mark(ao_lisp_cons_note, offset); - } + MDBG_MOVE("note cons %d\n", offset); + ao_lisp_cons_noted = 1; + mark(ao_lisp_cons_note, offset); } static uint16_t chunk_low, chunk_high; @@ -299,11 +296,11 @@ static uint16_t chunk_first, chunk_last; static int chunk_busy; static void -note_chunk(uint16_t addr, uint16_t size) +note_chunk(uint16_t offset, uint16_t size) { int l, r; - if (addr < chunk_low || chunk_high <= addr) + if (offset < chunk_low || chunk_high <= offset) return; /* Binary search for the location */ @@ -311,7 +308,7 @@ note_chunk(uint16_t addr, uint16_t size) r = chunk_busy - 1; while (l <= r) { int m = (l + r) >> 1; - if (ao_lisp_chunk[m].old_addr < addr) + if (ao_lisp_chunk[m].old_offset < offset) l = m + 1; else r = m - 1; @@ -327,7 +324,7 @@ note_chunk(uint16_t addr, uint16_t size) ao_lisp_abort(); /* Off the left side */ - if (l == 0 && chunk_busy && addr > ao_lisp_chunk[0].old_addr) + if (l == 0 && chunk_busy && offset > ao_lisp_chunk[0].old_offset) ao_lisp_abort(); #endif @@ -339,7 +336,7 @@ note_chunk(uint16_t addr, uint16_t size) (end - (l+1)) * sizeof (struct ao_lisp_chunk)); /* Add new entry */ - ao_lisp_chunk[l].old_addr = addr; + ao_lisp_chunk[l].old_offset = offset; ao_lisp_chunk[l].size = size; /* Increment the number of elements up to the size of the array */ @@ -348,7 +345,7 @@ note_chunk(uint16_t addr, uint16_t size) /* Set the top address if the array is full */ if (chunk_busy == AO_LISP_NCHUNK) - chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_addr + + chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_offset + ao_lisp_chunk[AO_LISP_NCHUNK-1].size; } @@ -508,41 +505,53 @@ ao_lisp_collect(uint8_t style) DUMP_BUSY(); /* Find the first moving object */ - for (i = 0; i < AO_LISP_NCHUNK; i++) { + for (i = 0; i < chunk_busy; i++) { uint16_t size = ao_lisp_chunk[i].size; +#if DBG_MEM if (!size) - break; + ao_lisp_abort(); +#endif - if (ao_lisp_chunk[i].old_addr > top) + if (ao_lisp_chunk[i].old_offset > top) break; + + MDBG_MOVE("chunk %d %d not moving\n", + ao_lisp_chunk[i].old_offset, + ao_lisp_chunk[i].size); #if DBG_MEM - if (ao_lisp_chunk[i].old_addr != top) + if (ao_lisp_chunk[i].old_offset != top) ao_lisp_abort(); #endif - top += size; - MDBG_MOVE("chunk %d %d not moving\n", - ao_lisp_chunk[i].old_addr, - ao_lisp_chunk[i].size); } + /* + * Limit amount of chunk array used in mapping moves + * to the active region + */ chunk_first = i; + chunk_low = ao_lisp_chunk[i].old_offset; + /* Copy all of the objects */ - for (; i < AO_LISP_NCHUNK; i++) { + for (; i < chunk_busy; i++) { uint16_t size = ao_lisp_chunk[i].size; +#if DBG_MEM if (!size) - break; + ao_lisp_abort(); +#endif MDBG_MOVE("chunk %d %d -> %d\n", - ao_lisp_chunk[i].old_addr, + ao_lisp_chunk[i].old_offset, size, top); - ao_lisp_chunk[i].new_addr = top; + ao_lisp_chunk[i].new_offset = top; + memmove(&ao_lisp_pool[top], - &ao_lisp_pool[ao_lisp_chunk[i].old_addr], + &ao_lisp_pool[ao_lisp_chunk[i].old_offset], size); + top += size; } @@ -564,9 +573,13 @@ ao_lisp_collect(uint8_t style) #endif } + /* If we ran into the end of the heap, then + * there's no need to keep walking + */ if (chunk_last != AO_LISP_NCHUNK) break; + /* Next loop starts right above this loop */ chunk_low = chunk_high; } @@ -590,10 +603,11 @@ ao_lisp_collect(uint8_t style) /* * Mark interfaces for objects - * - * Note a reference to memory and - * collect information about a few object sizes - * at a time + */ + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time */ int @@ -614,6 +628,9 @@ ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) return 0; } +/* + * Mark an object and all that it refereces + */ int ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { @@ -629,64 +646,82 @@ ao_lisp_mark(const struct ao_lisp_type *type, void *addr) return ret; } +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ int ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) { uint8_t type; void *addr; - if (!p) + type = ao_lisp_poly_base_type(p); + + if (type == AO_LISP_INT) return 1; - type = ao_lisp_poly_base_type(p); addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) return 1; if (type == AO_LISP_CONS && do_note_cons) { - note_cons(ao_lisp_ref(p)); + note_cons(pool_offset(addr)); return 1; } else { - const struct ao_lisp_type *lisp_type; + if (type == AO_LISP_OTHER) + type = ao_lisp_other_type(addr); - if (type == AO_LISP_OTHER) { - type = ao_lisp_other_type(ao_lisp_poly_other(p)); + const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; #if DBG_MEM - if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) - ao_lisp_abort(); + if (!lisp_type) + ao_lisp_abort(); #endif - } - lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; - if (!lisp_type) - return 1; - return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); + return ao_lisp_mark(lisp_type, addr); } } -static void * -move_map(void *addr) +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) { - uint16_t offset = pool_offset(addr); - int i; - - for (i = chunk_first; i < chunk_last; i++) { - if (ao_lisp_chunk[i].old_addr == offset) { - MDBG_MOVE("move %d -> %d\n", - ao_lisp_chunk[i].old_addr, - ao_lisp_chunk[i].new_addr); - return ao_lisp_pool + ao_lisp_chunk[i].new_addr; - } + int l, r; + + if (offset < chunk_low || chunk_high <= offset) + return offset; + + /* Binary search for the location */ + l = chunk_first; + r = chunk_busy - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (ao_lisp_chunk[m].old_offset < offset) + l = m + 1; + else + r = m - 1; } - return addr; +#if DBG_MEM + if (ao_lisp_chunk[l].old_offset != offset) + ao_lisp_abort(); +#endif + return ao_lisp_chunk[l].new_offset; } int ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) { void *addr = *ref; - int offset; + uint16_t offset, orig_offset; if (!AO_LISP_IS_POOL(addr)) return 1; @@ -694,14 +729,14 @@ ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) (void) type; MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); - addr = move_map(addr); - if (addr != *ref) { + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + if (offset != orig_offset) { MDBG_MOVE("update ref %d %d -> %d\n", AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, - MDBG_OFFSET(*ref), MDBG_OFFSET(addr)); - *ref = addr; + orig_offset, offset); + *ref = ao_lisp_pool + offset; } - offset = pool_offset(addr); if (busy(ao_lisp_busy, offset)) { MDBG_MOVE("already moved\n"); return 1; @@ -729,47 +764,46 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) int ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) { - uint8_t type; - ao_poly p = *ref; - int ret; - void *addr; + uint8_t type; + ao_poly p = *ref; + int ret; + void *addr; + uint16_t offset, orig_offset; + uint8_t base_type; + + base_type = type = ao_lisp_poly_base_type(p); - if (!p) + if (type == AO_LISP_INT) return 1; addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) return 1; - type = ao_lisp_poly_base_type(p); + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); if (type == AO_LISP_CONS && do_note_cons) { - note_cons(addr); - addr = move_map(addr); + note_cons(orig_offset); ret = 1; } else { - const struct ao_lisp_type *lisp_type; + if (type == AO_LISP_OTHER) + type = ao_lisp_other_type(ao_lisp_pool + offset); - if (type == AO_LISP_OTHER) { - type = ao_lisp_other_type(move_map(ao_lisp_poly_other(p))); + const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; #if DBG_MEM - if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) - ao_lisp_abort(); + if (!lisp_type) + ao_lisp_abort(); #endif - } - lisp_type = ao_lisp_types[type]; - if (!lisp_type) - return 1; ret = ao_lisp_move(lisp_type, &addr); } /* Re-write the poly value */ - if (addr != ao_lisp_ref(p)) { - ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); + if (offset != orig_offset) { + ao_poly np = ao_lisp_poly(ao_lisp_pool + offset, base_type); MDBG_MOVE("poly %d moved %d -> %d\n", - type, MDBG_OFFSET(ao_lisp_ref(p)), MDBG_OFFSET(ao_lisp_ref(np))); + type, orig_offset, offset); *ref = np; } return ret; @@ -797,8 +831,8 @@ ao_lisp_alloc(int size) MDBG_DO(if (dbg_validate) ao_lisp_validate()); size = ao_lisp_size_round(size); if (ao_lisp_top + size > AO_LISP_POOL) { - if (!ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) && - !ao_lisp_collect(AO_LISP_COLLECT_FULL)) + if (ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) < size && + ao_lisp_collect(AO_LISP_COLLECT_FULL) < size) { ao_lisp_error(AO_LISP_OOM, "out of memory"); return NULL; -- cgit v1.2.3 From c3a4d7721f0f5d082336b8cc9c9d765ad2f7d17e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 22:41:46 -0800 Subject: altos/lisp: Sort frames by atom Fortunately, the collector always retains the relative order between addresses, so we can sort based on the atom address itself. This reduces the time spent looking for names in larger (e.g. global) frames. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 5 ++++- src/lisp/ao_lisp_frame.c | 51 +++++++++++++++++++++++++++++++++++++---------- src/lisp/ao_lisp_lambda.c | 9 +++------ src/lisp/ao_lisp_mem.c | 4 +++- 4 files changed, 50 insertions(+), 19 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index af6ff8bb..1f7c85e1 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -621,7 +621,7 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; -#define AO_LISP_FRAME_FREE 4 +#define AO_LISP_FRAME_FREE 6 extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; @@ -637,6 +637,9 @@ ao_lisp_frame_new(int num); void ao_lisp_frame_free(struct ao_lisp_frame *frame); +void +ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); + int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 17fa141a..05f6d253 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -128,14 +128,32 @@ ao_lisp_frame_print(ao_poly p) printf("}"); } +static int +ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) +{ + int l = 0; + int r = top - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (frame->vals[m].atom < atom) + l = m + 1; + else + r = m - 1; + } + return l; +} + 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 l = ao_lisp_frame_find(frame, frame->num, atom); + + if (l >= frame->num) + return NULL; + + if (frame->vals[l].atom != atom) + return NULL; + return &frame->vals[l].val; } int @@ -234,6 +252,18 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) return new; } +void +ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) +{ + int l = ao_lisp_frame_find(frame, num, atom); + + memmove(&frame->vals[l+1], + &frame->vals[l], + (num - l) * sizeof (struct ao_lisp_val)); + frame->vals[l].atom = atom; + frame->vals[l].val = val; +} + int ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) { @@ -251,14 +281,13 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) f = 0; frame = ao_lisp_frame_new(1); } - atom = ao_lisp_poly_fetch(0); - val = ao_lisp_poly_fetch(1); if (!frame) return 0; *frame_ref = frame; - frame->vals[f].atom = atom; - ref = &frame->vals[f].val; - } - *ref = val; + atom = ao_lisp_poly_fetch(0); + val = ao_lisp_poly_fetch(1); + ao_lisp_frame_bind(frame, frame->num - 1, atom, val); + } else + *ref = val; return 1; } diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index b164cd66..526863c5 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -166,8 +166,7 @@ ao_lisp_lambda_eval(void) case AO_LISP_FUNC_LAMBDA: for (f = 0; f < args_wanted; f++) { DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = vals->car; + ao_lisp_frame_bind(next_frame, f, args->car, vals->car); args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } @@ -180,14 +179,12 @@ ao_lisp_lambda_eval(void) case AO_LISP_FUNC_MACRO: for (f = 0; f < args_wanted - 1; f++) { DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = vals->car; + ao_lisp_frame_bind(next_frame, f, args->car, vals->car); args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = ao_lisp_cons_poly(vals); + ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); break; default: break; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index e8907cf6..1f09ede8 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -218,9 +218,11 @@ static const void ** const ao_lisp_cache[] = { (const void **) &ao_lisp_frame_free_list[1], (const void **) &ao_lisp_frame_free_list[2], (const void **) &ao_lisp_frame_free_list[3], + (const void **) &ao_lisp_frame_free_list[4], + (const void **) &ao_lisp_frame_free_list[5], }; -#if AO_LISP_FRAME_FREE != 4 +#if AO_LISP_FRAME_FREE != 6 #error Unexpected AO_LISP_FRAME_FREE value #endif -- cgit v1.2.3 From 1b1bc92e6781c563e3d3b117b9cda2dddccc44de Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 22:52:10 -0800 Subject: altos/lisp: Add builtin 'collect' Collect memory, return amount free. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 ++ src/lisp/ao_lisp_builtin.c | 11 +++++++++++ src/lisp/ao_lisp_make_const.c | 1 + 3 files changed, 14 insertions(+) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 1f7c85e1..1a8e7e91 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -79,6 +79,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_save _atom("save") #define _ao_lisp_atom_restore _atom("restore") #define _ao_lisp_atom_call2fcc _atom("call/cc") +#define _ao_lisp_atom_collect _atom("collect") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -291,6 +292,7 @@ enum ao_lisp_builtin_id { builtin_save, builtin_restore, builtin_call_cc, + builtin_collect, _builtin_last }; diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 4c845307..7cd131f5 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -87,6 +87,7 @@ static const ao_poly builtin_names[] = { [builtin_save] = _ao_lisp_atom_save, [builtin_restore] = _ao_lisp_atom_restore, [builtin_call_cc] = _ao_lisp_atom_call2fcc, + [builtin_collect] = _ao_lisp_atom_collect, }; @@ -561,6 +562,15 @@ ao_lisp_do_read(struct ao_lisp_cons *cons) return ao_lisp_read(); } +ao_poly +ao_lisp_do_collect(struct ao_lisp_cons *cons) +{ + int free; + (void) cons; + free = ao_lisp_collect(AO_LISP_COLLECT_FULL); + return ao_lisp_int_poly(free); +} + const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_eval] = ao_lisp_do_eval, [builtin_read] = ao_lisp_do_read, @@ -599,5 +609,6 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_save] = ao_lisp_save, [builtin_restore] = ao_lisp_restore, [builtin_call_cc] = ao_lisp_call_cc, + [builtin_collect] = ao_lisp_do_collect, }; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index de9c5725..49f989e6 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -72,6 +72,7 @@ struct builtin_func funcs[] = { { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, + { .name = "collect", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_collect }, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) -- cgit v1.2.3 From 129e07ccc9b8a33491a905a91ca6c5b0509aba9c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 22:53:36 -0800 Subject: altos/lisp: Cleanup some DBG defines Get rid of the remaining duplicate defines. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 3 +-- src/lisp/ao_lisp_poly.c | 6 ------ src/lisp/ao_lisp_read.c | 1 - src/lisp/ao_lisp_stack.c | 1 - 4 files changed, 1 insertion(+), 10 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 1a8e7e91..fa3632b1 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -20,7 +20,6 @@ #include #include -//#include #include typedef uint16_t ao_poly; @@ -735,7 +734,7 @@ int ao_lisp_stack_depth; #define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_print(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK() ao_lisp_stack_print() +#define DBG_STACK() ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)) static inline void ao_lisp_frames_dump(void) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 800ee06d..fb3b06fe 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -14,12 +14,6 @@ #include "ao_lisp.h" -#if 0 -#define DBG(...) printf (__VA_ARGS__) -#else -#define DBG(...) -#endif - struct ao_lisp_funcs { void (*print)(ao_poly); void (*patom)(ao_poly); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index b792c2f1..84ef2a61 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -12,7 +12,6 @@ * General Public License for more details. */ -#define DBG_EVAL 0 #include "ao_lisp.h" #include "ao_lisp_read.h" diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 9c773e83..ef07b88a 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -12,7 +12,6 @@ * General Public License for more details. */ -#define DBG_EVAL 0 #include "ao_lisp.h" const struct ao_lisp_type ao_lisp_stack_type; -- cgit v1.2.3 From 399ba0a62422f71ff9669ba03b6a058bb2981c27 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 10 Jan 2017 14:45:59 -0800 Subject: altos/lisp: Tell compiler that the two lisp memory pools are aligned Otherwise, it will generate unaligned accesses to things fetched from them. Sigh. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index fa3632b1..8f5c3d8e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -50,7 +50,7 @@ ao_lisp_os_restore(void); #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 -extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define ao_lisp_pool ao_lisp_const #define AO_LISP_POOL AO_LISP_POOL_CONST @@ -84,7 +84,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #ifndef AO_LISP_POOL #define AO_LISP_POOL 3072 #endif -extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA]; +extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); #endif /* Primitive types */ -- cgit v1.2.3 From bc076747f6cc00508aef909a3a5bd3edf8c9bd66 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 18 Feb 2017 12:14:59 -0800 Subject: altos/lisp: Start adding scheme symbols Migrating to something more like scheme Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 4 ++++ src/lisp/ao_lisp_builtin.c | 4 ++++ 2 files changed, 8 insertions(+) (limited to 'src/lisp/ao_lisp.h') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 8f5c3d8e..980514cc 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -79,6 +79,10 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define _ao_lisp_atom_restore _atom("restore") #define _ao_lisp_atom_call2fcc _atom("call/cc") #define _ao_lisp_atom_collect _atom("collect") +#define _ao_lisp_atom_symbolp _atom("symbol?") +#define _ao_lisp_atom_builtin _atom("builtin?") +#define _ao_lisp_atom_symbolp _atom("symbol?") +#define _ao_lisp_atom_symbolp _atom("symbol?") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 7cd131f5..006c32f9 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -88,6 +88,10 @@ static const ao_poly builtin_names[] = { [builtin_restore] = _ao_lisp_atom_restore, [builtin_call_cc] = _ao_lisp_atom_call2fcc, [builtin_collect] = _ao_lisp_atom_collect, + [builtin_symbolp] = _ao_lisp_atom_symbolp, + [builtin_listp] = _ao_lisp_atom_listp, + [builtin_stringp] = _ao_lisp_atom_stringp, + [builtin_numberp] = _ao_lisp_atom_numberp, }; -- cgit v1.2.3