From 56d46ceaa1413415f25e47e81036426132f99924 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 31 Oct 2016 16:43:44 -0700 Subject: Add first lisp bits Signed-off-by: Keith Packard --- src/lisp/ao_lisp_string.c | 87 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 87 insertions(+) create mode 100644 src/lisp/ao_lisp_string.c (limited to 'src/lisp/ao_lisp_string.c') diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c new file mode 100644 index 00000000..87024271 --- /dev/null +++ b/src/lisp/ao_lisp_string.c @@ -0,0 +1,87 @@ +/* + * 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. + */ + +#include "ao_lisp.h" + +static void string_mark(void *addr) +{ + (void) addr; +} + +static int string_size(void *addr) +{ + if (!addr) + return 0; + return strlen(addr) + 1; +} + +static void string_move(void *addr) +{ + (void) addr; +} + +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_cat(char *a, char *b) +{ + int alen = strlen(a); + int blen = strlen(b); + char *r = ao_lisp_alloc(alen + blen + 1); + if (!r) + return NULL; + strcpy(r, a); + strcpy(r+alen, b); + return r; +} + +const struct ao_lisp_mem_type ao_lisp_string_type = { + .mark = string_mark, + .size = string_size, + .move = string_move, +}; + +void +ao_lisp_string_print(char *s) +{ + char c; + putchar('"'); + while ((c = *s++)) { + switch (c) { + case '\n': + printf ("\\n"); + break; + case '\r': + printf ("\\r"); + break; + case '\t': + printf ("\\t"); + break; + default: + putchar(c); + break; + } + } + putchar('"'); +} -- cgit v1.2.3 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 +++++++++++++++++++++++++ src/lisp/ao_lisp_eval.c | 52 +++--- src/lisp/ao_lisp_lex.c | 130 -------------- src/lisp/ao_lisp_mem.c | 1 - src/lisp/ao_lisp_read.c | 448 ++++++++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_read.h | 49 +++++ src/lisp/ao_lisp_string.c | 12 ++ src/test/Makefile | 2 +- src/test/ao_lisp_test.c | 9 + 9 files changed, 792 insertions(+), 153 deletions(-) create mode 100644 src/lisp/ao_lisp.h create mode 100644 src/lisp/ao_lisp_read.c create mode 100644 src/lisp/ao_lisp_read.h (limited to 'src/lisp/ao_lisp_string.c') 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_ */ diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 531e3b72..23908e64 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -30,6 +30,16 @@ 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_POLY(a) ao_lisp_poly_print(a) +#else +#define DBG(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#endif + ao_lisp_poly ao_lisp_eval(ao_lisp_poly v) { @@ -66,9 +76,9 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = NULL; v = actuals->car; - printf("start: stack"); ao_lisp_cons_print(stack); printf("\n"); - printf("start: actuals"); ao_lisp_cons_print(actuals); printf("\n"); - printf("start: formals"); ao_lisp_cons_print(formals); printf("\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 */ @@ -83,7 +93,7 @@ ao_lisp_eval(ao_lisp_poly v) } for (;;) { - printf("add formal: "); ao_lisp_poly_print(v); printf("\n"); + DBG("add formal: "); DBG_POLY(v); DBG("\n"); formal = ao_lisp_cons(v, NULL); if (formals_tail) @@ -93,17 +103,17 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = formal; actuals = actuals->cdr; - printf("formals: "); - ao_lisp_cons_print(formals); - printf("\n"); - printf("actuals: "); - ao_lisp_cons_print(actuals); - printf("\n"); + DBG("formals: "); + DBG_CONS(formals); + DBG("\n"); + DBG("actuals: "); + DBG_CONS(actuals); + DBG("\n"); /* Process all of the arguments */ if (actuals) { v = actuals->car; - printf ("actual: "); ao_lisp_poly_print(v); printf("\n"); + DBG ("actual: "); DBG_POLY(v); DBG("\n"); break; } @@ -115,13 +125,13 @@ ao_lisp_eval(ao_lisp_poly v) v = b->func(formals->cdr); - printf ("eval: "); - ao_lisp_cons_print(formals); - printf(" -> "); - ao_lisp_poly_print(v); - printf ("\n"); + DBG ("eval: "); + DBG_CONS(formals); + DBG(" -> "); + DBG_POLY(v); + DBG ("\n"); } else { - printf ("invalid eval\n"); + DBG ("invalid eval\n"); } if (--cons) { @@ -137,11 +147,11 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = formal; stack = stack->cdr; - printf("stack pop: stack"); ao_lisp_cons_print(stack); printf("\n"); - printf("stack pop: actuals"); ao_lisp_cons_print(actuals); printf("\n"); - printf("stack pop: formals"); ao_lisp_cons_print(formals); printf("\n"); + 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 { - printf("done func\n"); + DBG("done func\n"); break; } } diff --git a/src/lisp/ao_lisp_lex.c b/src/lisp/ao_lisp_lex.c index d62db872..fe7c47f4 100644 --- a/src/lisp/ao_lisp_lex.c +++ b/src/lisp/ao_lisp_lex.c @@ -14,133 +14,3 @@ #include "ao_lisp.h" -const uint32_t classTable[256] = { - IGNORE, /* ^@ */ - IGNORE, /* ^A */ - IGNORE, /* ^B */ - IGNORE, /* ^C */ - IGNORE, /* ^D */ - IGNORE, /* ^E */ - IGNORE, /* ^F */ - IGNORE, /* ^G */ - IGNORE, /* ^H */ - WHITE, /* ^I */ - WHITE, /* ^J */ - WHITE, /* ^K */ - WHITE, /* ^L */ - WHITE, /* ^M */ - IGNORE, /* ^N */ - IGNORE, /* ^O */ - IGNORE, /* ^P */ - IGNORE, /* ^Q */ - IGNORE, /* ^R */ - IGNORE, /* ^S */ - IGNORE, /* ^T */ - IGNORE, /* ^U */ - IGNORE, /* ^V */ - IGNORE, /* ^W */ - IGNORE, /* ^X */ - IGNORE, /* ^Y */ - IGNORE, /* ^Z */ - IGNORE, /* ^[ */ - IGNORE, /* ^\ */ - IGNORE, /* ^] */ - IGNORE, /* ^^ */ - IGNORE, /* ^_ */ - PRINTABLE|WHITE, /* */ - PRINTABLE, /* ! */ - PRINTABLE|STRINGC, /* " */ - PRINTABLE|COMMENT, /* # */ - PRINTABLE, /* $ */ - PRINTABLE, /* % */ - PRINTABLE, /* & */ - PRINTABLE|QUOTEC, /* ' */ - PRINTABLE|BRA, /* ( */ - PRINTABLE|KET, /* ) */ - PRINTABLE, /* * */ - PRINTABLE|SIGN, /* + */ - PRINTABLE, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE|DOT, /* . */ - PRINTABLE, /* / */ - PRINTABLE|DIGIT, /* 0 */ - PRINTABLE|DIGIT, /* 1 */ - PRINTABLE|DIGIT, /* 2 */ - PRINTABLE|DIGIT, /* 3 */ - PRINTABLE|DIGIT, /* 4 */ - PRINTABLE|DIGIT, /* 5 */ - PRINTABLE|DIGIT, /* 6 */ - PRINTABLE|DIGIT, /* 7 */ - PRINTABLE|DIGIT, /* 8 */ - PRINTABLE|DIGIT, /* 9 */ - PRINTABLE, /* : */ - PRINTABLE|COMMENT, /* ; */ - PRINTABLE, /* < */ - PRINTABLE, /* = */ - PRINTABLE, /* > */ - PRINTABLE, /* ? */ - PRINTABLE, /* @ */ - PRINTABLE, /* A */ - PRINTABLE, /* B */ - PRINTABLE, /* C */ - PRINTABLE, /* D */ - PRINTABLE|EXP, /* E */ - PRINTABLE, /* F */ - PRINTABLE, /* G */ - PRINTABLE, /* H */ - PRINTABLE, /* I */ - PRINTABLE, /* J */ - PRINTABLE, /* K */ - PRINTABLE, /* L */ - PRINTABLE, /* M */ - PRINTABLE, /* N */ - PRINTABLE, /* O */ - PRINTABLE, /* P */ - PRINTABLE, /* Q */ - PRINTABLE, /* R */ - PRINTABLE, /* S */ - PRINTABLE, /* T */ - PRINTABLE, /* U */ - PRINTABLE, /* V */ - PRINTABLE, /* W */ - PRINTABLE, /* X */ - PRINTABLE, /* Y */ - PRINTABLE, /* Z */ - PRINTABLE|BRA, /* [ */ - PRINTABLE|BACKSLASH, /* \ */ - PRINTABLE|KET, /* ] */ - PRINTABLE, /* ^ */ - PRINTABLE, /* _ */ - PRINTABLE, /* ` */ - PRINTABLE, /* a */ - PRINTABLE, /* b */ - PRINTABLE, /* c */ - PRINTABLE, /* d */ - PRINTABLE|EXP, /* e */ - PRINTABLE, /* f */ - PRINTABLE, /* g */ - PRINTABLE, /* h */ - PRINTABLE, /* i */ - PRINTABLE, /* j */ - PRINTABLE, /* k */ - PRINTABLE, /* l */ - PRINTABLE, /* m */ - PRINTABLE, /* n */ - PRINTABLE, /* o */ - PRINTABLE, /* p */ - PRINTABLE, /* q */ - PRINTABLE, /* r */ - PRINTABLE, /* s */ - PRINTABLE, /* t */ - PRINTABLE, /* u */ - PRINTABLE, /* v */ - PRINTABLE, /* w */ - PRINTABLE, /* x */ - PRINTABLE, /* y */ - PRINTABLE, /* z */ - PRINTABLE|BRA, /* { */ - PRINTABLE|VBAR, /* | */ - PRINTABLE|KET, /* } */ - PRINTABLE|TWIDDLE, /* ~ */ - IGNORE, /* ^? */ -}; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index f6a108e9..d008519b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -120,7 +120,6 @@ collect(void) { int i; - printf("collect\n"); /* Mark */ memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); for (i = 0; i < AO_LISP_ROOT; i++) diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c new file mode 100644 index 00000000..ccb4ba3a --- /dev/null +++ b/src/lisp/ao_lisp_read.c @@ -0,0 +1,448 @@ +/* + * 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_lisp_read.h" + +static const uint16_t lex_classes[128] = { + IGNORE, /* ^@ */ + IGNORE, /* ^A */ + IGNORE, /* ^B */ + IGNORE, /* ^C */ + IGNORE, /* ^D */ + IGNORE, /* ^E */ + IGNORE, /* ^F */ + IGNORE, /* ^G */ + IGNORE, /* ^H */ + WHITE, /* ^I */ + WHITE, /* ^J */ + WHITE, /* ^K */ + WHITE, /* ^L */ + WHITE, /* ^M */ + IGNORE, /* ^N */ + IGNORE, /* ^O */ + IGNORE, /* ^P */ + IGNORE, /* ^Q */ + IGNORE, /* ^R */ + IGNORE, /* ^S */ + IGNORE, /* ^T */ + IGNORE, /* ^U */ + IGNORE, /* ^V */ + IGNORE, /* ^W */ + IGNORE, /* ^X */ + IGNORE, /* ^Y */ + IGNORE, /* ^Z */ + IGNORE, /* ^[ */ + IGNORE, /* ^\ */ + IGNORE, /* ^] */ + IGNORE, /* ^^ */ + IGNORE, /* ^_ */ + PRINTABLE|WHITE, /* */ + PRINTABLE, /* ! */ + PRINTABLE|STRINGC, /* " */ + PRINTABLE|COMMENT, /* # */ + PRINTABLE, /* $ */ + PRINTABLE, /* % */ + PRINTABLE, /* & */ + PRINTABLE|QUOTEC, /* ' */ + PRINTABLE|BRA, /* ( */ + PRINTABLE|KET, /* ) */ + PRINTABLE, /* * */ + PRINTABLE|SIGN, /* + */ + PRINTABLE, /* , */ + PRINTABLE|SIGN, /* - */ + PRINTABLE, /* . */ + PRINTABLE, /* / */ + PRINTABLE|DIGIT, /* 0 */ + PRINTABLE|DIGIT, /* 1 */ + PRINTABLE|DIGIT, /* 2 */ + PRINTABLE|DIGIT, /* 3 */ + PRINTABLE|DIGIT, /* 4 */ + PRINTABLE|DIGIT, /* 5 */ + PRINTABLE|DIGIT, /* 6 */ + PRINTABLE|DIGIT, /* 7 */ + PRINTABLE|DIGIT, /* 8 */ + PRINTABLE|DIGIT, /* 9 */ + PRINTABLE, /* : */ + PRINTABLE|COMMENT, /* ; */ + PRINTABLE, /* < */ + PRINTABLE, /* = */ + PRINTABLE, /* > */ + PRINTABLE, /* ? */ + PRINTABLE, /* @ */ + PRINTABLE, /* A */ + PRINTABLE, /* B */ + PRINTABLE, /* C */ + PRINTABLE, /* D */ + PRINTABLE, /* E */ + PRINTABLE, /* F */ + PRINTABLE, /* G */ + PRINTABLE, /* H */ + PRINTABLE, /* I */ + PRINTABLE, /* J */ + PRINTABLE, /* K */ + PRINTABLE, /* L */ + PRINTABLE, /* M */ + PRINTABLE, /* N */ + PRINTABLE, /* O */ + PRINTABLE, /* P */ + PRINTABLE, /* Q */ + PRINTABLE, /* R */ + PRINTABLE, /* S */ + PRINTABLE, /* T */ + PRINTABLE, /* U */ + PRINTABLE, /* V */ + PRINTABLE, /* W */ + PRINTABLE, /* X */ + PRINTABLE, /* Y */ + PRINTABLE, /* Z */ + PRINTABLE, /* [ */ + PRINTABLE|BACKSLASH, /* \ */ + PRINTABLE, /* ] */ + PRINTABLE, /* ^ */ + PRINTABLE, /* _ */ + PRINTABLE, /* ` */ + PRINTABLE, /* a */ + PRINTABLE, /* b */ + PRINTABLE, /* c */ + PRINTABLE, /* d */ + PRINTABLE, /* e */ + PRINTABLE, /* f */ + PRINTABLE, /* g */ + PRINTABLE, /* h */ + PRINTABLE, /* i */ + PRINTABLE, /* j */ + PRINTABLE, /* k */ + PRINTABLE, /* l */ + PRINTABLE, /* m */ + PRINTABLE, /* n */ + PRINTABLE, /* o */ + PRINTABLE, /* p */ + PRINTABLE, /* q */ + PRINTABLE, /* r */ + PRINTABLE, /* s */ + PRINTABLE, /* t */ + PRINTABLE, /* u */ + PRINTABLE, /* v */ + PRINTABLE, /* w */ + PRINTABLE, /* x */ + PRINTABLE, /* y */ + PRINTABLE, /* z */ + PRINTABLE, /* { */ + PRINTABLE|VBAR, /* | */ + PRINTABLE, /* } */ + PRINTABLE|TWIDDLE, /* ~ */ + IGNORE, /* ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get() +{ + int c; + if (lex_unget_c) { + c = lex_unget_c; + lex_unget_c = 0; + } else + c = getchar(); + return c; +} + +static inline void +lex_unget(int c) +{ + if (c != EOF) + lex_unget_c = c; +} + +static int +lex_quoted (void) +{ + int c; + int v; + int count; + + c = lex_get(); +// if (jumping) +// return nil; + if (c == EOF) + return EOF; + c &= 0x7f; + switch (c) { + case 'n': + return '\n'; + case 'f': + return '\f'; + case 'b': + return '\b'; + case 'r': + return '\r'; + case 'v': + return '\v'; + case 't': + return '\t'; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + v = c - '0'; + count = 1; + while (count <= 3) { + c = lex_get(); +// if (jumping) +// return nil; + if (c == EOF) + return EOF; + c &= 0x7f; + if (c < '0' || '7' < c) { + lex_unget(c); + break; + } + v = (v << 3) + c - '0'; + ++count; + } + return v; + default: + return c; + } +} + +static uint16_t lex_class; + +static int +lexc(void) +{ + int c; + do { + c = lex_get(); + if (c == EOF) { + lex_class = ENDOFFILE; + c = 0; + } else { + c &= 0x7f; + lex_class = lex_classes[c]; + if (lex_class & BACKSLASH) { + c = lex_quoted(); + if (c == EOF) + lex_class = ENDOFFILE; + else + lex_class = PRINTABLE; + } + } + } while (lex_class & IGNORE); + return c; +} + +#define AO_LISP_TOKEN_MAX 32 + +static char token_string[AO_LISP_TOKEN_MAX]; +static int token_int; +static int token_len; + +static inline void add_token(int c) { + if (c && token_len < AO_LISP_TOKEN_MAX - 1) + token_string[token_len++] = c; +} + +static inline void end_token(void) { + token_string[token_len] = '\0'; +} + +static int +lex(void) +{ + int c; + + token_len = 0; + for (;;) { + c = lexc(); + if (lex_class & ENDOFFILE) + return AO_LISP_NIL; + +// if (jumping) +// return nil; + if (lex_class & WHITE) + continue; + + if (lex_class & (BRA|KET|QUOTEC)) { + add_token(c); + end_token(); + switch (c) { + case '(': + return OPEN; + case ')': + return CLOSE; + case '\'': + return QUOTE; + } + } + if (lex_class & TWIDDLE) { + token_int = lexc(); + return NUM; + } + if (lex_class & STRINGC) { + for (;;) { + c = lexc(); +// if (jumping) +// return nil; + if (lex_class & (STRINGC|ENDOFFILE)) { + end_token(); + return STRING; + } + add_token(c); + } + } + if (lex_class & PRINTABLE) { + int isnum; + int hasdigit; + int isneg; + + isnum = 1; + hasdigit = 0; + token_int = 0; + isneg = 0; + for (;;) { + if (!(lex_class & NUMBER)) { + isnum = 0; + } else { + if (token_len != 0 && + (lex_class & SIGN)) + { + isnum = 0; + } + if (c == '-') + isneg = 1; + if (lex_class & DIGIT) { + hasdigit = 1; + if (isnum) + token_int = token_int * 10 + c - '0'; + } + } + add_token (c); + c = lexc (); +// if (jumping) +// return nil; + if (lex_class & (NOTNAME)) { +// if (lex_class & ENDOFFILE) +// clearerr (f); + lex_unget(c); + end_token (); + if (isnum && hasdigit) { + if (isneg) + token_int = -token_int; + return NUM; + } + return NAME; + } + } + + } + } +} + +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; + +static ao_lisp_poly +read_item(void) +{ + struct ao_lisp_atom *atom; + char *string; + int cons; + ao_lisp_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); + } + + cons = 0; + read_cons = read_cons_tail = read_stack = 0; + for (;;) { + while (parse_token == OPEN) { + if (cons++) + read_stack = ao_lisp_cons(ao_lisp_cons_poly(read_cons), read_stack); + read_cons = NULL; + read_cons_tail = NULL; + parse_token = lex(); + } + + switch (parse_token) { + case ENDOFFILE: + default: + v = AO_LISP_NIL; + break; + case NAME: + atom = ao_lisp_atom_intern(token_string); + if (atom) + v = ao_lisp_atom_poly(atom); + else + v = AO_LISP_NIL; + break; + case NUM: + v = ao_lisp_int_poly(token_int); + break; + case STRING: + string = ao_lisp_string_copy(token_string); + if (string) + v = ao_lisp_string_poly(string); + else + v = AO_LISP_NIL; + break; + case CLOSE: + if (cons) + v = ao_lisp_cons_poly(read_cons); + else + v = AO_LISP_NIL; + if (--cons) { + read_cons = ao_lisp_poly_cons(read_stack->car); + read_stack = read_stack->cdr; + for (read_cons_tail = read_cons; + read_cons_tail && read_cons_tail->cdr; + read_cons_tail = read_cons_tail->cdr) + ; + } + break; + } + + if (!cons) + break; + + struct ao_lisp_cons *read = ao_lisp_cons(v, NULL); + if (read_cons_tail) + read_cons_tail->cdr = read; + else + read_cons = read; + read_cons_tail = read; + + parse_token = lex(); + } + return v; +} + +ao_lisp_poly +ao_lisp_read(void) +{ + parse_token = lex(); + return read_item(); +} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h new file mode 100644 index 00000000..1c994d56 --- /dev/null +++ b/src/lisp/ao_lisp_read.h @@ -0,0 +1,49 @@ +/* + * 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_READ_H_ +#define _AO_LISP_READ_H_ + +# define END 0 +# define NAME 1 +# define OPEN 2 +# define CLOSE 3 +# define QUOTE 4 +# define STRING 5 +# define NUM 6 + +/* + * character classes + */ + +# define PRINTABLE 0x00000001 /* \t \n ' ' - '~' */ +# define QUOTED 0x00000002 /* \ anything */ +# define BRA 0x00000004 /* ( [ { */ +# define KET 0x00000008 /* ) ] } */ +# define WHITE 0x00000010 /* ' ' \t \n */ +# define DIGIT 0x00000020 /* [0-9] */ +# define SIGN 0x00000040 /* +- */ +# define ENDOFFILE 0x00000080 /* end of file */ +# define COMMENT 0x00000100 /* ; # */ +# define IGNORE 0x00000200 /* \0 - ' ' */ +# define QUOTEC 0x00000400 /* ' */ +# define BACKSLASH 0x00000800 /* \ */ +# define VBAR 0x00001000 /* | */ +# define TWIDDLE 0x00002000 /* ~ */ +# define STRINGC 0x00004000 /* " */ + +# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) +# define NUMBER (DIGIT|SIGN) + +#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 87024271..1ab56933 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -43,6 +43,18 @@ ao_lisp_string_new(int len) { return a; } +char * +ao_lisp_string_copy(char *a) +{ + int alen = strlen(a); + + char *r = ao_lisp_alloc(alen + 1); + if (!r) + return NULL; + strcpy(r, a); + return r; +} + char * ao_lisp_string_cat(char *a, char *b) { diff --git a/src/test/Makefile b/src/test/Makefile index a409ae13..e841bfde 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -89,7 +89,7 @@ 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_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_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 bbadfa75..96f1fd72 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -23,6 +23,7 @@ main (int argc, char **argv) { 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); @@ -55,4 +56,12 @@ main (int argc, char **argv) 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); + } + } -- 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_string.c') 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 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_string.c') 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 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_string.c') 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 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_string.c') 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 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_string.c') 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