From d8c9024f3829dc3f241b16869f165f3ee01764f3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:25:51 -0800 Subject: altos/scheme: Support scheme subsetting via feature settings This provides for the creation of smaller versions of the interpreter, leaving out options like floating point numbers and vectors. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_mem.c | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 45d4de98..292d0f9d 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -465,9 +465,15 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, [AO_SCHEME_STACK] = &ao_scheme_stack_type, [AO_SCHEME_BOOL] = &ao_scheme_bool_type, +#ifdef AO_SCHEME_FEATURE_BIGINT [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = &ao_scheme_float_type, +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, +#endif }; static int -- cgit v1.2.3 From 839a7454686415a52f532d0e4f379061a68d5f1b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 18:01:21 -0800 Subject: altos/scheme: inline some mem calls to reduce stack usage. Also includes some code to display stack usage during collect calls. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_mem.c | 115 ++++++++++++++++++++++++++++++--------------- 1 file changed, 77 insertions(+), 38 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 292d0f9d..afa06d54 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -41,6 +41,36 @@ uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((ali #define DBG_MEM_STATS DBG_MEM #endif +#define DBG_MEM_STACK 0 +#if DBG_MEM_STACK +char *mem_collect_stack; +int64_t mem_collect_max_depth; + +static void +ao_scheme_check_stack(void) +{ + char x; + int64_t depth; + + depth = mem_collect_stack - &x; + if (depth > mem_collect_max_depth) + mem_collect_max_depth = depth; +} + +static void +_ao_scheme_reset_stack(char *x) +{ + mem_collect_stack = x; +// mem_collect_max_depth = 0; +} +#define ao_scheme_declare_stack char x; +#define ao_scheme_reset_stack() _ao_scheme_reset_stack(&x) +#else +#define ao_scheme_check_stack() +#define ao_scheme_declare_stack +#define ao_scheme_reset_stack() +#endif + #if DBG_MEM int dbg_move_depth; int dbg_mem = DBG_MEM_START; @@ -281,6 +311,7 @@ static inline uint16_t pool_offset(void *addr) { static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; + ao_scheme_check_stack(); tag[byte] |= (1 << bit); } @@ -303,7 +334,7 @@ static inline int limit(int offset) { return min(AO_SCHEME_POOL, max(offset, 0)); } -static void +static inline void note_cons(uint16_t offset) { MDBG_MOVE("note cons %d\n", offset); @@ -335,6 +366,7 @@ static void note_chunk(uint16_t offset, uint16_t size) { int l; + int end; if (offset < chunk_low || chunk_high <= offset) return; @@ -357,7 +389,7 @@ note_chunk(uint16_t offset, uint16_t size) #endif /* Shuffle existing entries right */ - int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + end = min(AO_SCHEME_NCHUNK, chunk_last + 1); memmove(&ao_scheme_chunk[l+1], &ao_scheme_chunk[l], @@ -476,6 +508,12 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = #endif }; +static int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +static int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + static int ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) { @@ -499,6 +537,7 @@ int ao_scheme_last_top; int ao_scheme_collect(uint8_t style) { + ao_scheme_declare_stack int i; int top; #if DBG_MEM_STATS @@ -511,6 +550,8 @@ ao_scheme_collect(uint8_t style) #endif MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + ao_scheme_reset_stack(); + /* The first time through, we're doing a full collect */ if (ao_scheme_last_top == 0) style = AO_SCHEME_COLLECT_FULL; @@ -628,6 +669,9 @@ ao_scheme_collect(uint8_t style) MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); +#if DBG_MEM_STACK + fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth); +#endif return AO_SCHEME_POOL - ao_scheme_top; } @@ -662,28 +706,6 @@ ao_scheme_cons_check(struct ao_scheme_cons *cons) */ -/* - * Mark a block of memory with an explicit size - */ - -int -ao_scheme_mark_block(void *addr, int size) -{ - int offset; - if (!AO_SCHEME_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_scheme_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_scheme_busy, offset); - note_chunk(offset, size); - return 0; -} - /* * Note a reference to memory and collect information about a few * object sizes at a time @@ -710,7 +732,7 @@ ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) /* * Mark an object and all that it refereces */ -int +static int ao_scheme_mark(const struct ao_scheme_type *type, void *addr) { int ret; @@ -737,6 +759,7 @@ ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) { uint8_t type; void *addr; + int ret; type = ao_scheme_poly_base_type(p); @@ -751,16 +774,26 @@ ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) note_cons(pool_offset(addr)); return 1; } else { + const struct ao_scheme_type *lisp_type; + if (type == AO_SCHEME_OTHER) type = ao_scheme_other_type(addr); - const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; + lisp_type = ao_scheme_types[type]; #if DBG_MEM if (!lisp_type) ao_scheme_abort(); #endif - return ao_scheme_mark(lisp_type, addr); + MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_mark_memory(lisp_type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + lisp_type->mark(addr); + } + MDBG_MOVE_OUT(); + return ret; } } @@ -817,7 +850,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) return 0; } -int +static int ao_scheme_move(const struct ao_scheme_type *type, void **ref) { int ret; @@ -835,16 +868,12 @@ ao_scheme_move(const struct ao_scheme_type *type, void **ref) int ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) { - uint8_t type; ao_poly p = *ref; int ret; void *addr; uint16_t offset, orig_offset; - uint8_t base_type; - base_type = type = ao_scheme_poly_base_type(p); - - if (type == AO_SCHEME_INT) + if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) return 1; addr = ao_scheme_ref(p); @@ -854,25 +883,35 @@ ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) orig_offset = pool_offset(addr); offset = move_map(orig_offset); - if (type == AO_SCHEME_CONS && do_note_cons) { + if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) { note_cons(orig_offset); ret = 1; } else { + uint8_t type = ao_scheme_poly_base_type(p); + const struct ao_scheme_type *lisp_type; + if (type == AO_SCHEME_OTHER) type = ao_scheme_other_type(ao_scheme_pool + offset); - const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; + lisp_type = ao_scheme_types[type]; #if DBG_MEM if (!lisp_type) ao_scheme_abort(); #endif - - ret = ao_scheme_move(lisp_type, &addr); + /* inline ao_scheme_move to save stack space */ + MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_move_memory(lisp_type, &addr); + if (!ret) { + MDBG_MOVE("move recurse\n"); + lisp_type->move(addr); + } + MDBG_MOVE_OUT(); } /* Re-write the poly value */ if (offset != orig_offset) { - ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p)); MDBG_MOVE("poly %d moved %d -> %d\n", type, orig_offset, offset); *ref = np; -- cgit v1.2.3 From 32f6877288ea6b7eb1cae9a42fbe8e2c5dbb2f08 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 14 Dec 2017 23:04:39 -0800 Subject: altos/scheme: swap BIGINT and STRING types This lets BIGINT be a primitive type, allowing it to use all 32 bits for storage. This does make strings another byte longer, and also slightly harder to deal with. It's a trade off. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 82 +++++++++++++----------------- src/scheme/ao_scheme_atom.c | 40 ++++++++++++--- src/scheme/ao_scheme_builtin.c | 55 +++++++++++---------- src/scheme/ao_scheme_float.c | 4 +- src/scheme/ao_scheme_int.c | 17 ++++--- src/scheme/ao_scheme_mem.c | 25 +++++++--- src/scheme/ao_scheme_poly.c | 16 +++--- src/scheme/ao_scheme_read.c | 4 +- src/scheme/ao_scheme_string.c | 110 +++++++++++++++++++++++++++++------------ src/scheme/ao_scheme_vector.c | 11 +++-- 10 files changed, 220 insertions(+), 144 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index ad80db2f..521ec105 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -23,6 +23,7 @@ #include #include +#include #define AO_SCHEME_BUILTIN_FEATURES #include "ao_scheme_builtin.h" #undef AO_SCHEME_BUILTIN_FEATURES @@ -93,7 +94,7 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut /* Primitive types */ #define AO_SCHEME_CONS 0 #define AO_SCHEME_INT 1 -#define AO_SCHEME_STRING 2 +#define AO_SCHEME_BIGINT 2 #define AO_SCHEME_OTHER 3 #define AO_SCHEME_TYPE_MASK 0x0003 @@ -109,17 +110,12 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_LAMBDA 8 #define AO_SCHEME_STACK 9 #define AO_SCHEME_BOOL 10 -#ifdef AO_SCHEME_FEATURE_BIGINT -#define AO_SCHEME_BIGINT 11 -#define _AO_SCHEME_BIGINT AO_SCHEME_BIGINT -#else -#define _AO_SCHEME_BIGINT AO_SCHEME_BOOL -#endif +#define AO_SCHEME_STRING 11 #ifdef AO_SCHEME_FEATURE_FLOAT -#define AO_SCHEME_FLOAT (_AO_SCHEME_BIGINT + 1) +#define AO_SCHEME_FLOAT 12 #define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT #else -#define _AO_SCHEME_FLOAT _AO_SCHEME_BIGINT +#define _AO_SCHEME_FLOAT 12 #endif #ifdef AO_SCHEME_FEATURE_VECTOR #define AO_SCHEME_VECTOR 13 @@ -180,6 +176,11 @@ struct ao_scheme_atom { char name[]; }; +struct ao_scheme_string { + uint8_t type; + char val[]; +}; + struct ao_scheme_val { ao_poly atom; ao_poly val; @@ -227,38 +228,16 @@ struct ao_scheme_vector { #define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) #ifdef AO_SCHEME_FEATURE_BIGINT + struct ao_scheme_bigint { uint32_t value; }; -#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) -#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) - -#if __BYTE_ORDER == __LITTLE_ENDIAN +#define AO_SCHEME_MIN_BIGINT INT32_MIN +#define AO_SCHEME_MAX_BIGINT INT32_MAX -static inline uint32_t -ao_scheme_int_bigint(int32_t i) { - return AO_SCHEME_BIGINT | (i << 8); -} -static inline int32_t -ao_scheme_bigint_int(uint32_t bi) { - return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_scheme_int_bigint(int32_t i) { - return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); -} -static inlint int32_t -ao_scheme_bigint_int(uint32_t bi) { - return (int32_t) (bi << 8) >> 8; -} - -#endif /* __BYTE_ORDER */ #endif /* AO_SCHEME_FEATURE_BIGINT */ -#define AO_SCHEME_NOT_INTEGER 0x7fffffff - /* Set on type when the frame escapes the lambda */ #define AO_SCHEME_FRAME_MARK 0x80 #define AO_SCHEME_FRAME_PRINT 0x40 @@ -475,20 +454,20 @@ ao_scheme_poly_bigint(ao_poly poly) static inline ao_poly ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) { - return ao_scheme_poly(bi, AO_SCHEME_OTHER); + return ao_scheme_poly(bi, AO_SCHEME_BIGINT); } #endif /* AO_SCHEME_FEATURE_BIGINT */ -static inline char * +static inline struct ao_scheme_string * ao_scheme_poly_string(ao_poly poly) { return ao_scheme_ref(poly); } static inline ao_poly -ao_scheme_string_poly(char *s) +ao_scheme_string_poly(struct ao_scheme_string *s) { - return ao_scheme_poly(s, AO_SCHEME_STRING); + return ao_scheme_poly(s, AO_SCHEME_OTHER); } static inline struct ao_scheme_atom * @@ -599,9 +578,9 @@ ao_poly ao_scheme_poly_fetch(int id); void -ao_scheme_string_stash(int id, char *string); +ao_scheme_string_stash(int id, struct ao_scheme_string *string); -char * +struct ao_scheme_string * ao_scheme_string_fetch(int id); static inline void @@ -667,17 +646,23 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons); /* string */ extern const struct ao_scheme_type ao_scheme_string_type; -char * -ao_scheme_string_copy(char *a); +struct ao_scheme_string * +ao_scheme_string_copy(struct ao_scheme_string *a); -char * -ao_scheme_string_cat(char *a, char *b); +struct ao_scheme_string * +ao_scheme_string_make(char *a); + +struct ao_scheme_string * +ao_scheme_atom_to_string(struct ao_scheme_atom *a); + +struct ao_scheme_string * +ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b); ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons); ao_poly -ao_scheme_string_unpack(char *a); +ao_scheme_string_unpack(struct ao_scheme_string *a); void ao_scheme_string_write(ao_poly s); @@ -695,6 +680,9 @@ extern struct ao_scheme_frame *ao_scheme_frame_current; void ao_scheme_atom_write(ao_poly a); +struct ao_scheme_atom * +ao_scheme_string_to_atom(struct ao_scheme_string *string); + struct ao_scheme_atom * ao_scheme_atom_intern(char *name); @@ -716,7 +704,7 @@ ao_scheme_int_write(ao_poly i); #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p); +ao_scheme_poly_integer(ao_poly p, bool *fail); ao_poly ao_scheme_integer_poly(int32_t i); @@ -734,7 +722,7 @@ extern const struct ao_scheme_type ao_scheme_bigint_type; #else -#define ao_scheme_poly_integer ao_scheme_poly_int +#define ao_scheme_poly_integer(a,b) ao_scheme_poly_int(a) #define ao_scheme_integer_poly ao_scheme_int_poly static inline int diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index cb32b7fe..745c32fe 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -71,8 +71,8 @@ const struct ao_scheme_type ao_scheme_atom_type = { struct ao_scheme_atom *ao_scheme_atoms; -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name) +static struct ao_scheme_atom * +ao_scheme_atom_find(char *name) { struct ao_scheme_atom *atom; @@ -86,15 +86,43 @@ ao_scheme_atom_intern(char *name) return atom; } #endif - ao_scheme_string_stash(0, name); - atom = ao_scheme_alloc(name_size(name)); - name = ao_scheme_string_fetch(0); + return NULL; +} + +static void +ao_scheme_atom_init(struct ao_scheme_atom *atom, char *name) +{ if (atom) { atom->type = AO_SCHEME_ATOM; + strcpy(atom->name, name); atom->next = ao_scheme_atom_poly(ao_scheme_atoms); ao_scheme_atoms = atom; - strcpy(atom->name, name); } +} + +struct ao_scheme_atom * +ao_scheme_string_to_atom(struct ao_scheme_string *string) +{ + struct ao_scheme_atom *atom = ao_scheme_atom_find(string->val); + + if (atom) + return atom; + ao_scheme_string_stash(0, string); + atom = ao_scheme_alloc(name_size(string->val)); + string = ao_scheme_string_fetch(0); + ao_scheme_atom_init(atom, string->val); + return atom; +} + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ + struct ao_scheme_atom *atom = ao_scheme_atom_find(name); + if (atom) + return atom; + + atom = ao_scheme_alloc(name_size(name)); + ao_scheme_atom_init(atom, name); return atom; } diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index b6788993..9a823f6a 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -130,10 +130,11 @@ ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int ty static int32_t ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) { - ao_poly p = ao_scheme_arg(cons, argc); - int32_t i = ao_scheme_poly_integer(p); + ao_poly p = ao_scheme_arg(cons, argc); + bool fail = false; + int32_t i = ao_scheme_poly_integer(p, &fail); - if (i == AO_SCHEME_NOT_INTEGER) + if (fail) (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); return i; } @@ -324,14 +325,14 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) switch (op) { case builtin_minus: if (ao_scheme_integer_typep(ct)) - ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret, NULL)); #ifdef AO_SCHEME_FEATURE_FLOAT else if (ct == AO_SCHEME_FLOAT) ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); #endif break; case builtin_divide: - if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) { + if (ao_scheme_poly_integer(ret, NULL) == 1) { } else { #ifdef AO_SCHEME_FEATURE_FLOAT if (ao_scheme_number_typep(ct)) { @@ -349,8 +350,8 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) } cons = ao_scheme_cons_fetch(0); } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { - int32_t r = ao_scheme_poly_integer(ret); - int32_t c = ao_scheme_poly_integer(car); + int32_t r = ao_scheme_poly_integer(ret, NULL); + int32_t c = ao_scheme_poly_integer(car, NULL); #ifdef AO_SCHEME_FEATURE_FLOAT int64_t t; #endif @@ -519,8 +520,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) uint8_t lt = ao_scheme_poly_type(left); uint8_t rt = ao_scheme_poly_type(right); if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { - int32_t l = ao_scheme_poly_integer(left); - int32_t r = ao_scheme_poly_integer(right); + int32_t l = ao_scheme_poly_integer(left, NULL); + int32_t r = ao_scheme_poly_integer(right, NULL); switch (op) { case builtin_less: @@ -577,8 +578,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) } #endif /* AO_SCHEME_FEATURE_FLOAT */ } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { - int c = strcmp(ao_scheme_poly_string(left), - ao_scheme_poly_string(right)); + int c = strcmp(ao_scheme_poly_string(left)->val, + ao_scheme_poly_string(right)->val); switch (op) { case builtin_less: if (!(c < 0)) @@ -664,16 +665,16 @@ ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_ref(struct ao_scheme_cons *cons) { - char *string; + char *string; int32_t ref; if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2)) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1); - if (ref == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; while (*string && ref) { ++string; --ref; @@ -689,20 +690,20 @@ ao_scheme_do_string_ref(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_length(struct ao_scheme_cons *cons) { - char *string; + struct ao_scheme_string *string; if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1)) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); - return ao_scheme_integer_poly(strlen(string)); + return ao_scheme_integer_poly(strlen(string->val)); } ao_poly ao_scheme_do_string_copy(struct ao_scheme_cons *cons) { - char *string; + struct ao_scheme_string *string; if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) return AO_SCHEME_NIL; @@ -715,7 +716,7 @@ ao_scheme_do_string_copy(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_set(struct ao_scheme_cons *cons) { - char *string; + char *string; int32_t ref; int32_t val; @@ -723,12 +724,12 @@ ao_scheme_do_string_set(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); - if (ref == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); - if (val == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; while (*string && ref) { ++string; @@ -759,7 +760,7 @@ ao_scheme_do_led(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0); - if (led == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; led = ao_scheme_arg(cons, 0); ao_scheme_os_led(ao_scheme_poly_int(led)); @@ -774,7 +775,7 @@ ao_scheme_do_delay(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) return AO_SCHEME_NIL; delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); - if (delay == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; ao_scheme_os_delay(delay); return delay; @@ -978,7 +979,7 @@ ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) return AO_SCHEME_NIL; - return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); + return ao_scheme_string_poly(ao_scheme_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0)))); } ao_poly @@ -989,7 +990,7 @@ ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; - return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); + return ao_scheme_atom_poly(ao_scheme_string_to_atom(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));; } ao_poly @@ -1009,7 +1010,7 @@ ao_scheme_do_write_char(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) return AO_SCHEME_NIL; - putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0), NULL)); return _ao_scheme_bool_true; } @@ -1068,7 +1069,7 @@ ao_scheme_do_make_vector(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2)) return AO_SCHEME_NIL; k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0); - if (k == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1))); } diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index c026c6fb..b75289d7 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -69,10 +69,10 @@ ao_scheme_poly_number(ao_poly p) switch (ao_scheme_poly_base_type(p)) { case AO_SCHEME_INT: return ao_scheme_poly_int(p); + case AO_SCHEME_BIGINT: + return ao_scheme_poly_bigint(p)->value; case AO_SCHEME_OTHER: switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { - case AO_SCHEME_BIGINT: - return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); case AO_SCHEME_FLOAT: return ao_scheme_poly_float(p)->value; } diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 43d6b8e1..4fcf4931 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -24,16 +24,19 @@ ao_scheme_int_write(ao_poly p) #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p) +ao_scheme_poly_integer(ao_poly p, bool *fail) { + if (fail) + *fail = false; switch (ao_scheme_poly_base_type(p)) { case AO_SCHEME_INT: return ao_scheme_poly_int(p); - case AO_SCHEME_OTHER: - if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) - return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_BIGINT: + return ao_scheme_poly_bigint(p)->value; } - return AO_SCHEME_NOT_INTEGER; + if (fail) + *fail = true; + return 0; } ao_poly @@ -44,7 +47,7 @@ ao_scheme_integer_poly(int32_t p) if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) return ao_scheme_int_poly(p); bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); - bi->value = ao_scheme_int_bigint(p); + bi->value = p; return ao_scheme_bigint_poly(bi); } @@ -77,6 +80,6 @@ ao_scheme_bigint_write(ao_poly p) { struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); - printf("%d", ao_scheme_bigint_int(bi->value)); + printf("%d", bi->value); } #endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index afa06d54..e7e89b89 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -178,7 +178,7 @@ struct ao_scheme_root { }; static struct ao_scheme_cons *save_cons[2]; -static char *save_string[2]; +static struct ao_scheme_string *save_string[2]; static struct ao_scheme_frame *save_frame[1]; static ao_poly save_poly[3]; @@ -488,7 +488,9 @@ dump_busy(void) static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { [AO_SCHEME_CONS] = &ao_scheme_cons_type, [AO_SCHEME_INT] = NULL, - [AO_SCHEME_STRING] = &ao_scheme_string_type, +#ifdef AO_SCHEME_FEATURE_BIGINT + [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +#endif [AO_SCHEME_OTHER] = (void *) 0x1, [AO_SCHEME_ATOM] = &ao_scheme_atom_type, [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, @@ -497,9 +499,7 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, [AO_SCHEME_STACK] = &ao_scheme_stack_type, [AO_SCHEME_BOOL] = &ao_scheme_bool_type, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, -#endif + [AO_SCHEME_STRING] = &ao_scheme_string_type, #ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = &ao_scheme_float_type, #endif @@ -533,6 +533,7 @@ uint64_t ao_scheme_loops[2]; #endif int ao_scheme_last_top; +int ao_scheme_collect_counts; int ao_scheme_collect(uint8_t style) @@ -556,6 +557,14 @@ ao_scheme_collect(uint8_t style) if (ao_scheme_last_top == 0) style = AO_SCHEME_COLLECT_FULL; + /* One in a while, just do a full collect */ + + if (ao_scheme_collect_counts >= 128) + style = AO_SCHEME_COLLECT_FULL; + + if (style == AO_SCHEME_COLLECT_FULL) + ao_scheme_collect_counts = 0; + /* Clear references to all caches */ for (i = 0; i < (int) AO_SCHEME_CACHE; i++) *ao_scheme_cache[i] = NULL; @@ -984,16 +993,16 @@ ao_scheme_poly_fetch(int id) } void -ao_scheme_string_stash(int id, char *string) +ao_scheme_string_stash(int id, struct ao_scheme_string *string) { assert(save_string[id] == NULL); save_string[id] = string; } -char * +struct ao_scheme_string * ao_scheme_string_fetch(int id) { - char *string = save_string[id]; + struct ao_scheme_string *string = save_string[id]; save_string[id] = NULL; return string; } diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 0bb427b9..2ea221ec 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -24,10 +24,12 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_cons_write, .display = ao_scheme_cons_display, }, - [AO_SCHEME_STRING] = { - .write = ao_scheme_string_write, - .display = ao_scheme_string_display, +#ifdef AO_SCHEME_FEATURE_BIGINT + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, }, +#endif [AO_SCHEME_INT] = { .write = ao_scheme_int_write, .display = ao_scheme_int_write, @@ -60,12 +62,10 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_bool_write, .display = ao_scheme_bool_write, }, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = { - .write = ao_scheme_bigint_write, - .display = ao_scheme_bigint_write, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, }, -#endif #ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = { .write = ao_scheme_float_write, diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index dce480ab..721211bc 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -555,7 +555,7 @@ ao_poly ao_scheme_read(void) { struct ao_scheme_atom *atom; - char *string; + struct ao_scheme_string *string; int read_state; ao_poly v = AO_SCHEME_NIL; @@ -605,7 +605,7 @@ ao_scheme_read(void) v = _ao_scheme_bool_false; break; case STRING: - string = ao_scheme_string_copy(token_string); + string = ao_scheme_string_make(token_string); if (string) v = ao_scheme_string_poly(string); else diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index ada626c3..e18a8e85 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -24,9 +24,10 @@ static void string_mark(void *addr) static int string_size(void *addr) { + struct ao_scheme_string *string = addr; if (!addr) return 0; - return strlen(addr) + 1; + return strlen(string->val) + 2; } static void string_move(void *addr) @@ -41,71 +42,114 @@ const struct ao_scheme_type ao_scheme_string_type = { .name = "string", }; -char * -ao_scheme_string_copy(char *a) +static struct ao_scheme_string * +ao_scheme_string_alloc(int len) { - int alen = strlen(a); - char *r; + struct ao_scheme_string *s; + + s = ao_scheme_alloc(len + 2); + if (!s) + return NULL; + s->type = AO_SCHEME_STRING; + return s; +} + +struct ao_scheme_string * +ao_scheme_string_copy(struct ao_scheme_string *a) +{ + int alen = strlen(a->val); + struct ao_scheme_string *r; ao_scheme_string_stash(0, a); - r = ao_scheme_alloc(alen + 1); + r = ao_scheme_string_alloc(alen); a = ao_scheme_string_fetch(0); if (!r) return NULL; - strcpy(r, a); + strcpy(r->val, a->val); + return r; +} + +struct ao_scheme_string * +ao_scheme_string_make(char *a) +{ + struct ao_scheme_string *r; + + r = ao_scheme_string_alloc(strlen(a)); + if (!r) + return NULL; + strcpy(r->val, a); + return r; +} + +struct ao_scheme_string * +ao_scheme_atom_to_string(struct ao_scheme_atom *a) +{ + int alen = strlen(a->name); + struct ao_scheme_string *r; + + ao_scheme_poly_stash(0, ao_scheme_atom_poly(a)); + r = ao_scheme_string_alloc(alen); + a = ao_scheme_poly_atom(ao_scheme_poly_fetch(0)); + if (!r) + return NULL; + strcpy(r->val, a->name); return r; } -char * -ao_scheme_string_cat(char *a, char *b) +struct ao_scheme_string * +ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) { - int alen = strlen(a); - int blen = strlen(b); - char *r; + int alen = strlen(a->val); + int blen = strlen(b->val); + struct ao_scheme_string *r; ao_scheme_string_stash(0, a); ao_scheme_string_stash(1, b); - r = ao_scheme_alloc(alen + blen + 1); + r = ao_scheme_string_alloc(alen + blen); a = ao_scheme_string_fetch(0); b = ao_scheme_string_fetch(1); if (!r) return NULL; - strcpy(r, a); - strcpy(r+alen, b); + strcpy(r->val, a->val); + strcpy(r->val+alen, b->val); return r; } ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons) { - char *r; - char *s; - int len; + struct ao_scheme_string *r; + char *rval; + int len; len = ao_scheme_cons_length(cons); ao_scheme_cons_stash(0, cons); - r = ao_scheme_alloc(len + 1); + r = ao_scheme_string_alloc(len); cons = ao_scheme_cons_fetch(0); - s = r; + if (!r) + return AO_SCHEME_NIL; + rval = r->val; while (cons) { - if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) + bool fail = false; + ao_poly car = cons->car; + *rval++ = ao_scheme_poly_integer(car, &fail); + if (fail) return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); - *s++ = ao_scheme_poly_integer(cons->car); - cons = ao_scheme_poly_cons(cons->cdr); + cons = ao_scheme_cons_cdr(cons); } - *s++ = 0; + *rval++ = 0; return ao_scheme_string_poly(r); } ao_poly -ao_scheme_string_unpack(char *a) +ao_scheme_string_unpack(struct ao_scheme_string *a) { struct ao_scheme_cons *cons = NULL, *tail = NULL; int c; int i; - for (i = 0; (c = a[i]); i++) { + for (i = 0; (c = a->val[i]); i++) { struct ao_scheme_cons *n; ao_scheme_cons_stash(0, cons); ao_scheme_cons_stash(1, tail); @@ -131,11 +175,12 @@ ao_scheme_string_unpack(char *a) void ao_scheme_string_write(ao_poly p) { - char *s = ao_scheme_poly_string(p); - char c; + struct ao_scheme_string *s = ao_scheme_poly_string(p); + char *sval = s->val; + char c; putchar('"'); - while ((c = *s++)) { + while ((c = *sval++)) { switch (c) { case '\n': printf ("\\n"); @@ -160,9 +205,10 @@ ao_scheme_string_write(ao_poly p) void ao_scheme_string_display(ao_poly p) { - char *s = ao_scheme_poly_string(p); - char c; + struct ao_scheme_string *s = ao_scheme_poly_string(p); + char *sval = s->val; + char c; - while ((c = *s++)) + while ((c = *sval++)) putchar(c); } diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index 0114c5a9..a4127f64 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -107,14 +107,15 @@ ao_scheme_vector_display(ao_poly v) static int32_t ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i) { - int32_t offset = ao_scheme_poly_integer(i); + bool fail; + int32_t offset = ao_scheme_poly_integer(i, &fail); - if (offset == AO_SCHEME_NOT_INTEGER) + if (fail) ao_scheme_error(AO_SCHEME_INVALID, "vector index %v not integer", i); if (offset < 0 || vector->length <= offset) { ao_scheme_error(AO_SCHEME_INVALID, "vector index %v out of range (max %d)", i, vector->length); - offset = AO_SCHEME_NOT_INTEGER; + offset = -1; } return offset; } @@ -125,7 +126,7 @@ ao_scheme_vector_get(ao_poly v, ao_poly i) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); int32_t offset = ao_scheme_vector_offset(vector, i); - if (offset == AO_SCHEME_NOT_INTEGER) + if (offset < 0) return AO_SCHEME_NIL; return vector->vals[offset]; } @@ -136,7 +137,7 @@ ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); int32_t offset = ao_scheme_vector_offset(vector, i); - if (offset == AO_SCHEME_NOT_INTEGER) + if (offset < 0) return AO_SCHEME_NIL; return vector->vals[offset] = p; } -- cgit v1.2.3 From e1a6b3bf458f311d832aea7eec34935d42f8efed Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 17 Dec 2017 22:22:50 -0800 Subject: altos/scheme: Use memory manager mark code to note recursive print This flags any object being printed and checks before recursing to avoid infinite loops. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 15 ++++++++++++ src/scheme/ao_scheme_cons.c | 19 +++++++++------ src/scheme/ao_scheme_frame.c | 1 - src/scheme/ao_scheme_mem.c | 56 +++++++++++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_vector.c | 28 ++++++++++++---------- 5 files changed, 99 insertions(+), 20 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 48d0149b..cc7f8f1d 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -555,6 +555,21 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); void * ao_scheme_alloc(int size); +/* Marks an object as being printed, returns 1 if it was already marked */ +int +ao_scheme_print_mark_addr(void *addr); + +int +ao_scheme_print_mark_poly(ao_poly poly); + +/* Notes that printing has started */ +void +ao_scheme_print_start(void); + +/* Notes that printing has ended */ +void +ao_scheme_print_stop(void); + #define AO_SCHEME_COLLECT_FULL 1 #define AO_SCHEME_COLLECT_INCREMENTAL 0 diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 912100a9..0b3cbf80 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -181,16 +181,17 @@ ao_scheme_cons_write(ao_poly c) ao_poly cdr; int first = 1; + ao_scheme_print_start(); printf("("); while (cons) { if (!first) printf(" "); - ao_scheme_poly_write(cons->car); - cdr = cons->cdr; - if (cdr == c) { - printf(" ..."); + if (ao_scheme_print_mark_addr(cons)) { + printf("..."); break; } + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { cons = ao_scheme_poly_cons(cdr); first = 0; @@ -201,6 +202,7 @@ ao_scheme_cons_write(ao_poly c) } } printf(")"); + ao_scheme_print_stop(); } void @@ -209,13 +211,15 @@ ao_scheme_cons_display(ao_poly c) struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); ao_poly cdr; + ao_scheme_print_start(); while (cons) { - ao_scheme_poly_display(cons->car); - cdr = cons->cdr; - if (cdr == c) { + if (ao_scheme_print_mark_addr(cons)) { printf("..."); break; } + ao_scheme_poly_display(cons->car); + + cdr = cons->cdr; if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) cons = ao_scheme_poly_cons(cdr); else { @@ -223,6 +227,7 @@ ao_scheme_cons_display(ao_poly c) cons = NULL; } } + ao_scheme_print_stop(); } int diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 7f521863..3f4c9157 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -41,7 +41,6 @@ frame_vals_mark(void *addr) ao_scheme_poly_atom(v->atom)->name, MDBG_OFFSET(ao_scheme_ref(v->atom)), MDBG_OFFSET(ao_scheme_ref(v->val)), f); - MDBG_DO(ao_scheme_poly_write(v->val)); MDBG_DO(printf("\n")); } } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index e7e89b89..c7d6b1f8 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -280,6 +280,10 @@ static const void ** const ao_scheme_cache[] = { #define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) +static int ao_scheme_printing, ao_scheme_print_cleared; +#if DBG_MEM +static int ao_scheme_collecting; +#endif static uint8_t ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; static uint8_t ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; static uint8_t ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; @@ -550,6 +554,7 @@ ao_scheme_collect(uint8_t style) MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); #endif MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + MDBG_DO(++ao_scheme_collecting); ao_scheme_reset_stack(); @@ -681,6 +686,7 @@ ao_scheme_collect(uint8_t style) #if DBG_MEM_STACK fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth); #endif + MDBG_DO(--ao_scheme_collecting); return AO_SCHEME_POOL - ao_scheme_top; } @@ -1021,3 +1027,53 @@ ao_scheme_frame_fetch(int id) save_frame[id] = NULL; return frame; } + +int +ao_scheme_print_mark_addr(void *addr) +{ + int offset; + +#if DBG_MEM + if (ao_scheme_collecting) + ao_scheme_abort(); +#endif + + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + if (!ao_scheme_print_cleared) { + ao_scheme_print_cleared = 1; + memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); + } + offset = pool_offset(addr); + if (busy(ao_scheme_busy, offset)) + return 1; + mark(ao_scheme_busy, offset); + return 0; +} + +int +ao_scheme_print_mark_poly(ao_poly p) +{ + uint8_t type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + return ao_scheme_print_mark_addr(ao_scheme_ref(p)); +} + +/* Notes that printing has started */ +void +ao_scheme_print_start(void) +{ + ao_scheme_printing++; +} + +/* Notes that printing has ended */ +void +ao_scheme_print_stop(void) +{ + ao_scheme_printing--; + if (ao_scheme_printing == 0) + ao_scheme_print_cleared = 0; +} diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index a4127f64..ff2067e2 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -78,16 +78,19 @@ ao_scheme_vector_write(ao_poly v) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); unsigned int i; - printf("#("); - for (i = 0; i < vector->length; i++) { - if (i != 0) - printf(" "); - if (vector->vals[i] == v) - printf ("..."); - else + ao_scheme_print_start(); + if (ao_scheme_print_mark_addr(vector)) + printf ("..."); + else { + printf("#("); + for (i = 0; i < vector->length; i++) { + if (i != 0) + printf(" "); ao_scheme_poly_write(vector->vals[i]); + } + printf(")"); } - printf(")"); + ao_scheme_print_stop(); } void @@ -96,10 +99,11 @@ ao_scheme_vector_display(ao_poly v) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); unsigned int i; - for (i = 0; i < vector->length; i++) { - if (vector->vals[i] == v) - printf("..."); - else + ao_scheme_print_start(); + if (ao_scheme_print_mark_addr(vector)) + printf ("..."); + else { + for (i = 0; i < vector->length; i++) ao_scheme_poly_display(vector->vals[i]); } } -- cgit v1.2.3 From 9f1849e548e35498f88a0b8adbbc4a57c7a39222 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 18 Dec 2017 02:11:07 -0800 Subject: altos/scheme: rearrange debugging defines Allow applications to redefine these as desired, add more flexibility in what the various memory debugging flags can do. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 45 ++++++++++++++++++++++++++++++++------- src/scheme/ao_scheme_mem.c | 52 ++++++++++++++++++++++++++-------------------- 2 files changed, 67 insertions(+), 30 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index cc7f8f1d..0881721b 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -15,10 +15,18 @@ #ifndef _AO_SCHEME_H_ #define _AO_SCHEME_H_ +#ifndef DBG_MEM #define DBG_MEM 0 +#endif +#ifndef DBG_EVAL #define DBG_EVAL 0 +#endif +#ifndef DBG_READ #define DBG_READ 0 +#endif +#ifndef DBG_FREE_CONS #define DBG_FREE_CONS 0 +#endif #define NDEBUG 1 #include @@ -954,9 +962,11 @@ ao_scheme_error(int error, const char *format, ...); /* debugging macros */ -#if DBG_EVAL || DBG_READ || DBG_MEM -#define DBG_CODE 1 +#if DBG_EVAL || DBG_READ int ao_scheme_stack_depth; +#endif + +#if DBG_EVAL #define DBG_DO(a) a #define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf(" "); } while(0) #define DBG_IN() (++ao_scheme_stack_depth) @@ -993,27 +1003,46 @@ ao_scheme_frames_dump(void) #endif #if DBG_READ -#define RDBGI(...) DBGI(__VA_ARGS__) -#define RDBG_IN() DBG_IN() -#define RDBG_OUT() DBG_OUT() +#define RDBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); ao_scheme_printf(__VA_ARGS__); } while (0) +#define RDBG_IN() (++ao_scheme_stack_depth) +#define RDBG_OUT() (--ao_scheme_stack_depth) #else #define RDBGI(...) #define RDBG_IN() #define RDBG_OUT() #endif -#define DBG_MEM_START 1 +static inline int +ao_scheme_mdbg_offset(void *a) +{ + uint8_t *u = a; + + if (u == 0) + return -1; + + if (ao_scheme_pool <= u && u < ao_scheme_pool + AO_SCHEME_POOL) + return u - ao_scheme_pool; + +#ifndef AO_SCHEME_MAKE_CONST + if (ao_scheme_const <= u && u < ao_scheme_const + AO_SCHEME_POOL_CONST) + return - (int) (u - ao_scheme_const); +#endif + return -2; +} + +#define MDBG_OFFSET(a) ao_scheme_mdbg_offset(a) #if DBG_MEM +#define DBG_MEM_START 1 + #include extern int dbg_move_depth; #define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) extern int dbg_mem; -#define MDBG_DO(a) DBG_DO(a) +#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++) diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index c7d6b1f8..3659d3ec 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -71,11 +71,17 @@ _ao_scheme_reset_stack(char *x) #define ao_scheme_reset_stack() #endif +#if DBG_MEM +#define DBG_MEM_RECORD 1 +#endif + #if DBG_MEM int dbg_move_depth; int dbg_mem = DBG_MEM_START; int dbg_validate = 0; +#endif +#if DBG_MEM_RECORD struct ao_scheme_record { struct ao_scheme_record *next; const struct ao_scheme_type *type; @@ -129,9 +135,9 @@ ao_scheme_record_save(void) } static void -ao_scheme_record_compare(char *where, - struct ao_scheme_record *a, - struct ao_scheme_record *b) +ao_scheme_record_compare(const char *where, + struct ao_scheme_record *a, + struct ao_scheme_record *b) { while (a && b) { if (a->type != b->type || a->size != b->size) { @@ -168,6 +174,7 @@ ao_scheme_record_compare(char *where, #else #define ao_scheme_record_reset() +#define ao_scheme_record(t,a,s) #endif uint8_t ao_scheme_exception; @@ -390,6 +397,9 @@ note_chunk(uint16_t offset, uint16_t size) /* Off the left side */ if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) ao_scheme_abort(); + + if (l < chunk_last && ao_scheme_chunk[l].old_offset == offset) + ao_scheme_abort(); #endif /* Shuffle existing entries right */ @@ -469,20 +479,19 @@ static void dump_busy(void) { int i; - MDBG_MOVE("busy:"); + printf("busy:"); for (i = 0; i < ao_scheme_top; i += 4) { if ((i & 0xff) == 0) { - MDBG_MORE("\n"); - MDBG_MOVE("%s", ""); + printf("\n\t"); } else if ((i & 0x1f) == 0) - MDBG_MORE(" "); + printf(" "); if (busy(ao_scheme_busy, i)) - MDBG_MORE("*"); + printf("*"); else - MDBG_MORE("-"); + printf("-"); } - MDBG_MORE ("\n"); + printf ("\n"); } #define DUMP_BUSY() dump_busy() #else @@ -548,11 +557,11 @@ ao_scheme_collect(uint8_t style) #if DBG_MEM_STATS int loops = 0; #endif -#if DBG_MEM +#if DBG_MEM_RECORD struct ao_scheme_record *mark_record = NULL, *move_record = NULL; - - MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); #endif + MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]); + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); MDBG_DO(++ao_scheme_collecting); @@ -579,15 +588,12 @@ ao_scheme_collect(uint8_t style) chunk_low = top = ao_scheme_last_top; } for (;;) { -#if DBG_MEM_STATS - loops++; -#endif MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); /* Find the sizes of the first chunk of objects to move */ reset_chunks(); walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); -#if DBG_MEM +#if DBG_MEM_RECORD ao_scheme_record_free(mark_record); mark_record = ao_scheme_record_save(); if (mark_record && move_record) @@ -599,7 +605,6 @@ ao_scheme_collect(uint8_t style) /* Find the first moving object */ for (i = 0; i < chunk_last; i++) { uint16_t size = ao_scheme_chunk[i].size; - #if DBG_MEM if (!size) ao_scheme_abort(); @@ -651,7 +656,7 @@ ao_scheme_collect(uint8_t style) /* Relocate all references to the objects */ walk(ao_scheme_move, ao_scheme_poly_move); -#if DBG_MEM +#if DBG_MEM_RECORD ao_scheme_record_free(move_record); move_record = ao_scheme_record_save(); if (mark_record && move_record) @@ -659,6 +664,9 @@ ao_scheme_collect(uint8_t style) #endif } +#if DBG_MEM_STATS + loops++; +#endif /* If we ran into the end of the heap, then * there's no need to keep walking */ @@ -861,7 +869,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) return 1; } mark(ao_scheme_busy, offset); - MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + ao_scheme_record(type, addr, ao_scheme_size(type, addr)); return 0; } @@ -928,14 +936,14 @@ ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) if (offset != orig_offset) { ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p)); MDBG_MOVE("poly %d moved %d -> %d\n", - type, orig_offset, offset); + ao_scheme_poly_type(np), orig_offset, offset); *ref = np; } return ret; } #if DBG_MEM -void +static void ao_scheme_validate(void) { chunk_low = 0; -- cgit v1.2.3 From 6593570418e087b9f83ed7f90303d4e1e7d20e83 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 18 Dec 2017 02:12:04 -0800 Subject: altos/scheme: Work around gcc 7.2.0 optimization bug in memory manager After marking a set of memory chunks, it's possible that all of them will be packed tight against 'top', in which case none of them will be moving. In that case, gcc 7.2.0 appears to generate incorrect code causing the loop to be abandoned, meaning that we don't actually collect anything at all. Add a quick short-circuit test just after the mark phase that skips the code which wouldn't do anything in this case. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_mem.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 3659d3ec..94275451 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -623,6 +623,20 @@ ao_scheme_collect(uint8_t style) top += size; } + /* Short-circuit the rest of the loop when all of the + * found objects aren't moving. This isn't strictly + * necessary as the rest of the loop is structured to + * work in this case, but GCC 7.2.0 with optimization + * greater than 2 generates incorrect code for this... + */ + if (i == AO_SCHEME_NCHUNK) { + chunk_low = chunk_high; +#if DBG_MEM_STATS + loops++; +#endif + continue; + } + /* * Limit amount of chunk array used in mapping moves * to the active region -- cgit v1.2.3 From 431165e5fa72ba6dffd477de32960745cdec332c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:33:36 -0800 Subject: altos/scheme: Rework display/write code MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Unify output functions and add bool to switch between write and display mode. Make that only affect strings (as per r⁷rs). Use print recursion detection in frame and stack code, eliminating PRINT flags in type field. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 65 +++++++++--------------- src/scheme/ao_scheme_atom.c | 3 +- src/scheme/ao_scheme_bool.c | 3 +- src/scheme/ao_scheme_builtin.c | 11 ++-- src/scheme/ao_scheme_cons.c | 62 +++++++++++------------ src/scheme/ao_scheme_error.c | 74 ++------------------------- src/scheme/ao_scheme_float.c | 3 +- src/scheme/ao_scheme_frame.c | 55 +++++++++++++------- src/scheme/ao_scheme_int.c | 6 ++- src/scheme/ao_scheme_lambda.c | 4 +- src/scheme/ao_scheme_make_const.c | 6 +-- src/scheme/ao_scheme_mem.c | 33 ++++++++---- src/scheme/ao_scheme_poly.c | 103 ++++++++------------------------------ src/scheme/ao_scheme_rep.c | 2 +- src/scheme/ao_scheme_stack.c | 31 ++++++++---- src/scheme/ao_scheme_string.c | 56 +++++++++------------ src/scheme/ao_scheme_vector.c | 28 +++-------- 17 files changed, 213 insertions(+), 332 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 0881721b..b37e9098 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -249,7 +249,6 @@ struct ao_scheme_bigint { /* Set on type when the frame escapes the lambda */ #define AO_SCHEME_FRAME_MARK 0x80 -#define AO_SCHEME_FRAME_PRINT 0x40 static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { return f->type & AO_SCHEME_FRAME_MARK; @@ -301,7 +300,6 @@ struct ao_scheme_stack { }; #define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ -#define AO_SCHEME_STACK_PRINT 0x40 /* stack is being printed */ static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { return s->type & AO_SCHEME_STACK_MARK; @@ -567,15 +565,15 @@ ao_scheme_alloc(int size); int ao_scheme_print_mark_addr(void *addr); -int -ao_scheme_print_mark_poly(ao_poly poly); +void +ao_scheme_print_clear_addr(void *addr); /* Notes that printing has started */ void ao_scheme_print_start(void); -/* Notes that printing has ended */ -void +/* Notes that printing has ended, returns 1 if printing is still happening */ +int ao_scheme_print_stop(void); #define AO_SCHEME_COLLECT_FULL 1 @@ -628,7 +626,7 @@ ao_scheme_frame_fetch(int id); extern const struct ao_scheme_type ao_scheme_bool_type; void -ao_scheme_bool_write(ao_poly v); +ao_scheme_bool_write(ao_poly v, bool write); #ifdef AO_SCHEME_MAKE_CONST extern struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; @@ -656,10 +654,7 @@ void ao_scheme_cons_free(struct ao_scheme_cons *cons); void -ao_scheme_cons_write(ao_poly); - -void -ao_scheme_cons_display(ao_poly); +ao_scheme_cons_write(ao_poly, bool write); int ao_scheme_cons_length(struct ao_scheme_cons *cons); @@ -689,10 +684,7 @@ ao_poly ao_scheme_string_unpack(struct ao_scheme_string *a); void -ao_scheme_string_write(ao_poly s); - -void -ao_scheme_string_display(ao_poly s); +ao_scheme_string_write(ao_poly s, bool write); /* atom */ extern const struct ao_scheme_type ao_scheme_atom_type; @@ -702,7 +694,7 @@ extern struct ao_scheme_frame *ao_scheme_frame_global; extern struct ao_scheme_frame *ao_scheme_frame_current; void -ao_scheme_atom_write(ao_poly a); +ao_scheme_atom_write(ao_poly a, bool write); struct ao_scheme_atom * ao_scheme_string_to_atom(struct ao_scheme_string *string); @@ -724,7 +716,7 @@ ao_scheme_atom_def(ao_poly atom, ao_poly val); /* int */ void -ao_scheme_int_write(ao_poly i); +ao_scheme_int_write(ao_poly i, bool write); #ifdef AO_SCHEME_FEATURE_BIGINT int32_t @@ -740,7 +732,7 @@ ao_scheme_integer_typep(uint8_t t) } void -ao_scheme_bigint_write(ao_poly i); +ao_scheme_bigint_write(ao_poly i, bool write); extern const struct ao_scheme_type ao_scheme_bigint_type; @@ -760,10 +752,7 @@ ao_scheme_integer_typep(uint8_t t) /* vector */ void -ao_scheme_vector_write(ao_poly v); - -void -ao_scheme_vector_display(ao_poly v); +ao_scheme_vector_write(ao_poly v, bool write); struct ao_scheme_vector * ao_scheme_vector_alloc(uint16_t length, ao_poly fill); @@ -783,14 +772,10 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector); extern const struct ao_scheme_type ao_scheme_vector_type; /* prim */ -void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p); -void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p); - -static inline void -ao_scheme_poly_write(ao_poly p) { (*ao_scheme_poly_write_func(p))(p); } +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p, bool write); static inline void -ao_scheme_poly_display(ao_poly p) { (*ao_scheme_poly_display_func(p))(p); } +ao_scheme_poly_write(ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(p, write); } int ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); @@ -818,7 +803,7 @@ ao_scheme_set_cond(struct ao_scheme_cons *cons); extern const struct ao_scheme_type ao_scheme_float_type; void -ao_scheme_float_write(ao_poly p); +ao_scheme_float_write(ao_poly p, bool write); ao_poly ao_scheme_float_get(float value); @@ -836,7 +821,7 @@ ao_scheme_number_typep(uint8_t t) /* builtin */ void -ao_scheme_builtin_write(ao_poly b); +ao_scheme_builtin_write(ao_poly b, bool write); extern const struct ao_scheme_type ao_scheme_builtin_type; @@ -895,7 +880,7 @@ ao_poly ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); void -ao_scheme_frame_write(ao_poly p); +ao_scheme_frame_write(ao_poly p, bool write); void ao_scheme_frame_init(void); @@ -909,7 +894,7 @@ struct ao_scheme_lambda * ao_scheme_lambda_new(ao_poly cons); void -ao_scheme_lambda_write(ao_poly lambda); +ao_scheme_lambda_write(ao_poly lambda, bool write); ao_poly ao_scheme_lambda_eval(void); @@ -920,6 +905,8 @@ extern const struct ao_scheme_type ao_scheme_stack_type; extern struct ao_scheme_stack *ao_scheme_stack; extern struct ao_scheme_stack *ao_scheme_stack_free_list; +extern int ao_scheme_frame_print_indent; + void ao_scheme_stack_reset(struct ao_scheme_stack *stack); @@ -933,7 +920,7 @@ void ao_scheme_stack_clear(void); void -ao_scheme_stack_write(ao_poly stack); +ao_scheme_stack_write(ao_poly stack, bool write); ao_poly ao_scheme_stack_eval(void); @@ -946,12 +933,6 @@ ao_scheme_vprintf(const char *format, va_list args); void ao_scheme_printf(const char *format, ...); -void -ao_scheme_error_poly(const char *name, ao_poly poly, ao_poly last); - -void -ao_scheme_error_frame(int indent, const char *name, struct ao_scheme_frame *frame); - ao_poly ao_scheme_error(int error, const char *format, ...); @@ -974,10 +955,10 @@ int ao_scheme_stack_depth; #define DBG_RESET() (ao_scheme_stack_depth = 0) #define DBG(...) ao_scheme_printf(__VA_ARGS__) #define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a)) -#define DBG_POLY(a) ao_scheme_poly_write(a) +#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a), true) +#define DBG_POLY(a) ao_scheme_poly_write(a, true) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) -#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack), true) static inline void ao_scheme_frames_dump(void) { diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index 745c32fe..8989cefd 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -188,8 +188,9 @@ ao_scheme_atom_def(ao_poly atom, ao_poly val) } void -ao_scheme_atom_write(ao_poly a) +ao_scheme_atom_write(ao_poly a, bool write) { struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); + (void) write; printf("%s", atom->name); } diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c index c1e880ca..88970667 100644 --- a/src/scheme/ao_scheme_bool.c +++ b/src/scheme/ao_scheme_bool.c @@ -38,10 +38,11 @@ const struct ao_scheme_type ao_scheme_bool_type = { }; void -ao_scheme_bool_write(ao_poly v) +ao_scheme_bool_write(ao_poly v, bool write) { struct ao_scheme_bool *b = ao_scheme_poly_bool(v); + (void) write; if (b->value) printf("#t"); else diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 9a823f6a..221570c7 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -84,9 +84,10 @@ ao_scheme_args_name(uint8_t args) #endif void -ao_scheme_builtin_write(ao_poly b) +ao_scheme_builtin_write(ao_poly b, bool write) { struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + (void) write; printf("%s", ao_scheme_builtin_name(builtin->func)); } @@ -287,7 +288,7 @@ ao_scheme_do_write(struct ao_scheme_cons *cons) ao_poly val = AO_SCHEME_NIL; while (cons) { val = cons->car; - ao_scheme_poly_write(val); + ao_scheme_poly_write(val, true); cons = ao_scheme_cons_cdr(cons); if (cons) printf(" "); @@ -301,7 +302,7 @@ ao_scheme_do_display(struct ao_scheme_cons *cons) ao_poly val = AO_SCHEME_NIL; while (cons) { val = cons->car; - ao_scheme_poly_display(val); + ao_scheme_poly_write(val, false); cons = ao_scheme_cons_cdr(cons); } return _ao_scheme_bool_true; @@ -855,7 +856,7 @@ ao_scheme_do_pairp(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); - if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + if (v != AO_SCHEME_NIL && AO_SCHEME_IS_CONS(v)) return _ao_scheme_bool_true; return _ao_scheme_bool_false; } @@ -946,7 +947,7 @@ ao_scheme_do_listp(struct ao_scheme_cons *cons) for (;;) { if (v == AO_SCHEME_NIL) return _ao_scheme_bool_true; - if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) + if (!AO_SCHEME_IS_CONS(v)) return _ao_scheme_bool_false; v = ao_scheme_poly_cons(v)->cdr; } diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 0b3cbf80..7976250b 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -111,7 +111,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) ao_poly cdr = cons->cdr; if (cdr == AO_SCHEME_NIL) return NULL; - if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + if (!AO_SCHEME_IS_CONS(cdr)) { (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); return NULL; } @@ -151,7 +151,7 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons) tail->cdr = ao_scheme_cons_poly(new); tail = new; cdr = cons->cdr; - if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + if (!AO_SCHEME_IS_CONS(cdr)) { tail->cdr = cdr; break; } @@ -175,59 +175,53 @@ ao_scheme_cons_free(struct ao_scheme_cons *cons) } void -ao_scheme_cons_write(ao_poly c) +ao_scheme_cons_write(ao_poly c, bool write) { struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + struct ao_scheme_cons *clear = cons; ao_poly cdr; - int first = 1; + int written = 0; ao_scheme_print_start(); printf("("); while (cons) { - if (!first) + if (written != 0) printf(" "); + + /* Note if there's recursion in printing. Not + * as good as actual references, but at least + * we don't infinite loop... + */ if (ao_scheme_print_mark_addr(cons)) { printf("..."); break; } - ao_scheme_poly_write(cons->car); + + ao_scheme_poly_write(cons->car, write); + + /* keep track of how many pairs have been printed */ + written++; + cdr = cons->cdr; - if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { - cons = ao_scheme_poly_cons(cdr); - first = 0; - } else { + if (!AO_SCHEME_IS_CONS(cdr)) { printf(" . "); - ao_scheme_poly_write(cdr); - cons = NULL; + ao_scheme_poly_write(cdr, write); + break; } + cons = ao_scheme_poly_cons(cdr); } printf(")"); - ao_scheme_print_stop(); -} -void -ao_scheme_cons_display(ao_poly c) -{ - struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); - ao_poly cdr; - - ao_scheme_print_start(); - while (cons) { - if (ao_scheme_print_mark_addr(cons)) { - printf("..."); - break; - } - ao_scheme_poly_display(cons->car); + if (ao_scheme_print_stop()) { - cdr = cons->cdr; - if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) - cons = ao_scheme_poly_cons(cdr); - else { - ao_scheme_poly_display(cdr); - cons = NULL; + /* If we're still printing, clear the print marks on + * all printed pairs + */ + while (written--) { + ao_scheme_print_clear_addr(clear); + clear = ao_scheme_poly_cons(clear->cdr); } } - ao_scheme_print_stop(); } int diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c index c015c76a..6a71ca51 100644 --- a/src/scheme/ao_scheme_error.c +++ b/src/scheme/ao_scheme_error.c @@ -15,73 +15,6 @@ #include "ao_scheme.h" #include -void -ao_scheme_error_poly(const char *name, ao_poly poly, ao_poly last) -{ - int first = 1; - printf("\t\t%s(", name); - if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { - if (poly) { - while (poly) { - struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); - if (!first) - printf("\t\t "); - else - first = 0; - ao_scheme_poly_write(cons->car); - printf("\n"); - if (poly == last) - break; - poly = cons->cdr; - } - printf("\t\t )\n"); - } else - printf(")\n"); - } else { - ao_scheme_poly_write(poly); - printf("\n"); - } -} - -static void tabs(int indent) -{ - while (indent--) - printf("\t"); -} - -void -ao_scheme_error_frame(int indent, const char *name, struct ao_scheme_frame *frame) -{ - int f; - - tabs(indent); - printf ("%s{", name); - if (frame) { - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - if (frame->type & AO_SCHEME_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_SCHEME_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) { - tabs(indent); - printf(" "); - } - ao_scheme_poly_write(vals->vals[f].atom); - printf(" = "); - ao_scheme_poly_write(vals->vals[f].val); - printf("\n"); - } - if (frame->prev) - ao_scheme_error_frame(indent + 1, "prev: ", ao_scheme_poly_frame(frame->prev)); - frame->type &= ~AO_SCHEME_FRAME_PRINT; - } - tabs(indent); - printf(" }\n"); - } else - printf ("}\n"); -} - void ao_scheme_vprintf(const char *format, va_list args) { @@ -91,7 +24,10 @@ ao_scheme_vprintf(const char *format, va_list args) if (c == '%') { switch (c = *format++) { case 'v': - ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), true); + break; + case 'V': + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), false); break; case 'p': printf("%p", va_arg(args, void *)); @@ -133,7 +69,7 @@ ao_scheme_error(int error, const char *format, ...) ao_scheme_printf("Value: %v\n", ao_scheme_v); ao_scheme_printf("Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); printf("Stack:\n"); - ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); + ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack), true); ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); return AO_SCHEME_NIL; } diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index b75289d7..d8501548 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -46,11 +46,12 @@ const struct ao_scheme_type ao_scheme_float_type = { #endif void -ao_scheme_float_write(ao_poly p) +ao_scheme_float_write(ao_poly p, bool write) { struct ao_scheme_float *f = ao_scheme_poly_float(p); float v = f->value; + (void) write; if (isnanf(v)) printf("+nan.0"); else if (isinff(v)) { diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 3f4c9157..46f941e6 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -142,32 +142,53 @@ const struct ao_scheme_type ao_scheme_frame_type = { .name = "frame", }; +int ao_scheme_frame_print_indent; + +static void +ao_scheme_frame_indent(int extra) +{ + int i; + putchar('\n'); + for (i = 0; i < ao_scheme_frame_print_indent+extra; i++) + putchar('\t'); +} + void -ao_scheme_frame_write(ao_poly p) +ao_scheme_frame_write(ao_poly p, bool write) { struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); + struct ao_scheme_frame *clear = frame; struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); int f; + int written = 0; - printf ("{"); - if (frame) { - if (frame->type & AO_SCHEME_FRAME_PRINT) + ao_scheme_print_start(); + while (frame) { + if (written != 0) + printf(", "); + if (ao_scheme_print_mark_addr(frame)) { printf("recurse..."); - else { - frame->type |= AO_SCHEME_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) - printf(", "); - ao_scheme_poly_write(vals->vals[f].atom); - printf(" = "); - ao_scheme_poly_write(vals->vals[f].val); - } - if (frame->prev) - ao_scheme_poly_write(frame->prev); - frame->type &= ~AO_SCHEME_FRAME_PRINT; + break; + } + + putchar('{'); + written++; + for (f = 0; f < frame->num; f++) { + ao_scheme_frame_indent(1); + ao_scheme_poly_write(vals->vals[f].atom, write); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val, write); + } + frame = ao_scheme_poly_frame(frame->prev); + ao_scheme_frame_indent(0); + putchar('}'); + } + if (ao_scheme_print_stop()) { + while (written--) { + ao_scheme_print_clear_addr(clear); + clear = ao_scheme_poly_frame(clear->prev); } } - printf("}"); } static int diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 4fcf4931..01b571c0 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -15,9 +15,10 @@ #include "ao_scheme.h" void -ao_scheme_int_write(ao_poly p) +ao_scheme_int_write(ao_poly p, bool write) { int i = ao_scheme_poly_int(p); + (void) write; printf("%d", i); } @@ -76,10 +77,11 @@ const struct ao_scheme_type ao_scheme_bigint_type = { }; void -ao_scheme_bigint_write(ao_poly p) +ao_scheme_bigint_write(ao_poly p, bool write) { struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); + (void) write; printf("%d", bi->value); } #endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c index be87f4d1..e8ce0710 100644 --- a/src/scheme/ao_scheme_lambda.c +++ b/src/scheme/ao_scheme_lambda.c @@ -50,7 +50,7 @@ const struct ao_scheme_type ao_scheme_lambda_type = { }; void -ao_scheme_lambda_write(ao_poly poly) +ao_scheme_lambda_write(ao_poly poly, bool write) { struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); @@ -59,7 +59,7 @@ ao_scheme_lambda_write(ao_poly poly) printf("%s", ao_scheme_args_name(lambda->args)); while (cons) { printf(" "); - ao_scheme_poly_write(cons->car); + ao_scheme_poly_write(cons->car, write); cons = ao_scheme_poly_cons(cons->cdr); } printf(")"); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index 51bb1269..79ba1bf1 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -220,7 +220,7 @@ ao_has_macro(ao_poly p) list = cons->cdr; p = AO_SCHEME_NIL; - while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { + while (list != AO_SCHEME_NIL && AO_SCHEME_IS_CONS(list)) { cons = ao_scheme_poly_cons(list); m = ao_has_macro(cons->car); if (m) { @@ -280,7 +280,7 @@ ao_scheme_read_eval_abort(void) out = ao_scheme_eval(in); if (ao_scheme_exception) return 0; - ao_scheme_poly_write(out); + ao_scheme_poly_write(out, true); putchar ('\n'); } return 1; @@ -446,7 +446,7 @@ main(int argc, char **argv) if (val != AO_SCHEME_NIL) { printf("error: function %s contains unresolved macro: ", ao_scheme_poly_atom(vals->vals[f].atom)->name); - ao_scheme_poly_write(val); + ao_scheme_poly_write(val, true); printf("\n"); exit(1); } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 94275451..a336fdfe 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -1061,7 +1061,7 @@ ao_scheme_print_mark_addr(void *addr) #endif if (!AO_SCHEME_IS_POOL(addr)) - return 1; + return 0; if (!ao_scheme_print_cleared) { ao_scheme_print_cleared = 1; @@ -1074,14 +1074,23 @@ ao_scheme_print_mark_addr(void *addr) return 0; } -int -ao_scheme_print_mark_poly(ao_poly p) +void +ao_scheme_print_clear_addr(void *addr) { - uint8_t type = ao_scheme_poly_base_type(p); + int offset; - if (type == AO_SCHEME_INT) - return 1; - return ao_scheme_print_mark_addr(ao_scheme_ref(p)); +#if DBG_MEM + if (ao_scheme_collecting) + ao_scheme_abort(); +#endif + + if (!AO_SCHEME_IS_POOL(addr)) + return; + + if (!ao_scheme_print_cleared) + return; + offset = pool_offset(addr); + clear(ao_scheme_busy, offset); } /* Notes that printing has started */ @@ -1091,11 +1100,13 @@ ao_scheme_print_start(void) ao_scheme_printing++; } -/* Notes that printing has ended */ -void +/* Notes that printing has ended. Returns 1 if printing is still going on */ +int ao_scheme_print_stop(void) { ao_scheme_printing--; - if (ao_scheme_printing == 0) - ao_scheme_print_cleared = 0; + if (ao_scheme_printing != 0) + return 1; + ao_scheme_print_cleared = 0; + return 0; } diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 70e577a2..25ac6d67 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -14,100 +14,41 @@ #include "ao_scheme.h" -struct ao_scheme_funcs { - void (*write)(ao_poly); - void (*display)(ao_poly); -}; +static void ao_scheme_invalid_write(ao_poly p, bool write) { + printf("??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p); + (void) write; + ao_scheme_abort(); +} -static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { - [AO_SCHEME_CONS] = { - .write = ao_scheme_cons_write, - .display = ao_scheme_cons_display, - }, +static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (ao_poly p, bool write) = { + [AO_SCHEME_CONS] = ao_scheme_cons_write, #ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = { - .write = ao_scheme_bigint_write, - .display = ao_scheme_bigint_write, - }, + [AO_SCHEME_BIGINT] = ao_scheme_bigint_write, #endif - [AO_SCHEME_INT] = { - .write = ao_scheme_int_write, - .display = ao_scheme_int_write, - }, - [AO_SCHEME_ATOM] = { - .write = ao_scheme_atom_write, - .display = ao_scheme_atom_write, - }, - [AO_SCHEME_BUILTIN] = { - .write = ao_scheme_builtin_write, - .display = ao_scheme_builtin_write, - }, - [AO_SCHEME_FRAME] = { - .write = ao_scheme_frame_write, - .display = ao_scheme_frame_write, - }, - [AO_SCHEME_FRAME_VALS] = { - .write = NULL, - .display = NULL, - }, - [AO_SCHEME_LAMBDA] = { - .write = ao_scheme_lambda_write, - .display = ao_scheme_lambda_write, - }, - [AO_SCHEME_STACK] = { - .write = ao_scheme_stack_write, - .display = ao_scheme_stack_write, - }, - [AO_SCHEME_BOOL] = { - .write = ao_scheme_bool_write, - .display = ao_scheme_bool_write, - }, - [AO_SCHEME_STRING] = { - .write = ao_scheme_string_write, - .display = ao_scheme_string_display, - }, + [AO_SCHEME_INT] = ao_scheme_int_write, + [AO_SCHEME_ATOM] = ao_scheme_atom_write, + [AO_SCHEME_BUILTIN] = ao_scheme_builtin_write, + [AO_SCHEME_FRAME] = ao_scheme_frame_write, + [AO_SCHEME_FRAME_VALS] = ao_scheme_invalid_write, + [AO_SCHEME_LAMBDA] = ao_scheme_lambda_write, + [AO_SCHEME_STACK] = ao_scheme_stack_write, + [AO_SCHEME_BOOL] = ao_scheme_bool_write, + [AO_SCHEME_STRING] = ao_scheme_string_write, #ifdef AO_SCHEME_FEATURE_FLOAT - [AO_SCHEME_FLOAT] = { - .write = ao_scheme_float_write, - .display = ao_scheme_float_write, - }, + [AO_SCHEME_FLOAT] = ao_scheme_float_write, #endif #ifdef AO_SCHEME_FEATURE_VECTOR - [AO_SCHEME_VECTOR] = { - .write = ao_scheme_vector_write, - .display = ao_scheme_vector_display - }, + [AO_SCHEME_VECTOR] = ao_scheme_vector_write, #endif }; -static void ao_scheme_invalid_write(ao_poly p) { - printf("??? 0x%04x ???", p); - ao_scheme_abort(); -} - -static const struct ao_scheme_funcs ao_scheme_invalid_funcs = { - .write = ao_scheme_invalid_write, - .display = ao_scheme_invalid_write, -}; - -static const struct ao_scheme_funcs * -funcs(ao_poly p) +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p, bool write) { uint8_t type = ao_scheme_poly_type(p); if (type < AO_SCHEME_NUM_TYPE) - return &ao_scheme_funcs[type]; - return &ao_scheme_invalid_funcs; -} - -void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p) -{ - return funcs(p)->write; -} - -void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p) -{ - return funcs(p)->display; + return ao_scheme_write_funcs[type]; + return ao_scheme_invalid_write; } void * diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c index 5b94d940..b35ba5b8 100644 --- a/src/scheme/ao_scheme_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -30,7 +30,7 @@ ao_scheme_read_eval_print(void) break; ao_scheme_exception = 0; } else { - ao_scheme_poly_write(out); + ao_scheme_poly_write(out, true); putchar ('\n'); } } diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c index e062a093..e29e2b68 100644 --- a/src/scheme/ao_scheme_stack.c +++ b/src/scheme/ao_scheme_stack.c @@ -158,26 +158,35 @@ ao_scheme_stack_clear(void) } void -ao_scheme_stack_write(ao_poly poly) +ao_scheme_stack_write(ao_poly poly, bool write) { - struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + struct ao_scheme_stack *clear = s; + int written = 0; + (void) write; + ao_scheme_print_start(); + ao_scheme_frame_print_indent += 2; while (s) { - if (s->type & AO_SCHEME_STACK_PRINT) { + if (ao_scheme_print_mark_addr(s)) { printf("[recurse...]"); - return; + break; } - s->type |= AO_SCHEME_STACK_PRINT; + written++; printf("\t[\n"); - printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); - printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); - ao_scheme_error_poly ("values: ", s->values, s->values_tail); - ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); - ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + ao_scheme_printf("\t\texpr: %v\n", s->list); + ao_scheme_printf("\t\tvalues: %v\n", s->values); + ao_scheme_printf("\t\tframe: %v\n", s->frame); printf("\t]\n"); - s->type &= ~AO_SCHEME_STACK_PRINT; s = ao_scheme_poly_stack(s->prev); } + ao_scheme_frame_print_indent -= 2; + if (ao_scheme_print_stop()) { + while (written--) { + ao_scheme_print_clear_addr(clear); + clear = ao_scheme_poly_stack(clear->prev); + } + } } /* diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index e18a8e85..b00ef276 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -173,42 +173,36 @@ ao_scheme_string_unpack(struct ao_scheme_string *a) } void -ao_scheme_string_write(ao_poly p) +ao_scheme_string_write(ao_poly p, bool write) { struct ao_scheme_string *s = ao_scheme_poly_string(p); char *sval = s->val; char c; - putchar('"'); - while ((c = *sval++)) { - switch (c) { - case '\n': - printf ("\\n"); - break; - case '\r': - printf ("\\r"); - break; - case '\t': - printf ("\\t"); - break; - default: - if (c < ' ') - printf("\\%03o", c); - else - putchar(c); - break; + if (write) { + putchar('"'); + while ((c = *sval++)) { + switch (c) { + case '\n': + printf ("\\n"); + break; + case '\r': + printf ("\\r"); + break; + case '\t': + printf ("\\t"); + break; + default: + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); + break; + } } + putchar('"'); + } else { + while ((c = *sval++)) + putchar(c); } - putchar('"'); -} - -void -ao_scheme_string_display(ao_poly p) -{ - struct ao_scheme_string *s = ao_scheme_poly_string(p); - char *sval = s->val; - char c; - - while ((c = *sval++)) - putchar(c); } diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index ff2067e2..419d6765 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -73,39 +73,27 @@ ao_scheme_vector_alloc(uint16_t length, ao_poly fill) } void -ao_scheme_vector_write(ao_poly v) +ao_scheme_vector_write(ao_poly v, bool write) { struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); unsigned int i; + int was_marked = 0; ao_scheme_print_start(); - if (ao_scheme_print_mark_addr(vector)) + was_marked = ao_scheme_print_mark_addr(vector); + if (was_marked) { printf ("..."); - else { + } else { printf("#("); for (i = 0; i < vector->length; i++) { if (i != 0) printf(" "); - ao_scheme_poly_write(vector->vals[i]); + ao_scheme_poly_write(vector->vals[i], write); } printf(")"); } - ao_scheme_print_stop(); -} - -void -ao_scheme_vector_display(ao_poly v) -{ - struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - unsigned int i; - - ao_scheme_print_start(); - if (ao_scheme_print_mark_addr(vector)) - printf ("..."); - else { - for (i = 0; i < vector->length; i++) - ao_scheme_poly_display(vector->vals[i]); - } + if (ao_scheme_print_stop() && !was_marked) + ao_scheme_print_clear_addr(vector); } static int32_t -- cgit v1.2.3 From 71fb79492cb955af4bd52e79f1fa69d17e084dbc Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 12:16:24 -0800 Subject: altos/scheme: Replace memory pool macros with inlines AO_SCHEME_IS_CONST -> ao_scheme_is_const_addr AO_SCHEME_IS_POOL -> ao_scheme_is_pool_addr Provides better typechecking and avoids confusion with ao_scheme_is_const inline (which takes an ao_poly instead of a void *) Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 13 +++++++++++-- src/scheme/ao_scheme_frame.c | 5 ----- src/scheme/ao_scheme_mem.c | 18 +++++++++--------- src/scheme/ao_scheme_poly.c | 2 +- 4 files changed, 21 insertions(+), 17 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index b8e683fb..5cae0bda 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -155,8 +155,17 @@ ao_scheme_is_const(ao_poly poly) { return poly & AO_SCHEME_CONST; } -#define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) -#define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +static inline int +ao_scheme_is_const_addr(const void *addr) { + const uint8_t *a = addr; + return (ao_scheme_const <= a) && (a < ao_scheme_const + AO_SCHEME_POOL_CONST); +} + +static inline int +ao_scheme_is_pool_addr(const void *addr) { + const uint8_t *a = addr; + return (ao_scheme_pool <= a) && (a < ao_scheme_pool + AO_SCHEME_POOL); +} void * ao_scheme_ref(ao_poly poly); diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 46f941e6..a7e5153f 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -86,8 +86,6 @@ frame_mark(void *addr) struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!AO_SCHEME_IS_POOL(frame)) - break; if (!ao_scheme_mark_memory(&ao_scheme_frame_vals_type, vals)) frame_vals_mark(vals); frame = ao_scheme_poly_frame(frame->prev); @@ -110,9 +108,6 @@ frame_move(void *addr) int ret; MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - if (!AO_SCHEME_IS_POOL(frame)) - break; - vals = ao_scheme_poly_frame_vals(frame->vals); if (!ao_scheme_move_memory(&ao_scheme_frame_vals_type, (void **) &vals)) frame_vals_move(vals); diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index a336fdfe..55872b62 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -313,7 +313,7 @@ static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; /* Offset of an address within the pool. */ static inline uint16_t pool_offset(void *addr) { #if DBG_MEM - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) ao_scheme_abort(); #endif return ((uint8_t *) addr) - ao_scheme_pool; @@ -723,7 +723,7 @@ ao_scheme_cons_check(struct ao_scheme_cons *cons) reset_chunks(); walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); while (cons) { - if (!AO_SCHEME_IS_POOL(cons)) + if (!ao_scheme_is_pool_addr(cons)) break; offset = pool_offset(cons); if (busy(ao_scheme_busy, offset)) { @@ -752,7 +752,7 @@ int ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) { int offset; - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; offset = pool_offset(addr); @@ -804,7 +804,7 @@ ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) return 1; addr = ao_scheme_ref(p); - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; if (type == AO_SCHEME_CONS && do_note_cons) { @@ -864,7 +864,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) void *addr = *ref; uint16_t offset, orig_offset; - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; (void) type; @@ -874,7 +874,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) offset = move_map(orig_offset); if (offset != orig_offset) { MDBG_MOVE("update ref %d %d -> %d\n", - AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + ao_scheme_is_pool_addr(ref) ? MDBG_OFFSET(ref) : -1, orig_offset, offset); *ref = ao_scheme_pool + offset; } @@ -914,7 +914,7 @@ ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) return 1; addr = ao_scheme_ref(p); - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; orig_offset = pool_offset(addr); @@ -1060,7 +1060,7 @@ ao_scheme_print_mark_addr(void *addr) ao_scheme_abort(); #endif - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 0; if (!ao_scheme_print_cleared) { @@ -1084,7 +1084,7 @@ ao_scheme_print_clear_addr(void *addr) ao_scheme_abort(); #endif - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return; if (!ao_scheme_print_cleared) diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 25ac6d67..0cffc196 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -65,7 +65,7 @@ ao_scheme_poly(const void *addr, ao_poly type) { const uint8_t *a = addr; if (a == NULL) return AO_SCHEME_NIL; - if (AO_SCHEME_IS_CONST(a)) + if (ao_scheme_is_const_addr(a)) return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; return (a - ao_scheme_pool + 4) | type; } -- cgit v1.2.3 From ed1f7b79abc7400a54b35fbf62c9db6855f9129a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 12:39:20 -0800 Subject: altos/scheme: Replace per-type indexed stash with poly stash heap Instead of having a random set of stash arrays with explicit indices used by callers, just have a general heap. Less error prone, and less code. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 72 +++++++++++++++++++++++--------- src/scheme/ao_scheme_atom.c | 4 +- src/scheme/ao_scheme_builtin.c | 16 ++++---- src/scheme/ao_scheme_cons.c | 20 ++++----- src/scheme/ao_scheme_frame.c | 16 ++++---- src/scheme/ao_scheme_lambda.c | 8 ++-- src/scheme/ao_scheme_mem.c | 93 ++++++++++-------------------------------- src/scheme/ao_scheme_stack.c | 12 +++--- src/scheme/ao_scheme_string.c | 32 +++++++-------- src/scheme/ao_scheme_vector.c | 8 ++-- 10 files changed, 132 insertions(+), 149 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 5cae0bda..d4c9bc05 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -595,38 +595,72 @@ ao_scheme_cons_check(struct ao_scheme_cons *cons); #endif void -ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); +ao_scheme_poly_stash(ao_poly poly); -struct ao_scheme_cons * -ao_scheme_cons_fetch(int id); +ao_poly +ao_scheme_poly_fetch(void); -void -ao_scheme_poly_stash(int id, ao_poly poly); +static inline void +ao_scheme_cons_stash(struct ao_scheme_cons *cons) { + ao_scheme_poly_stash(ao_scheme_cons_poly(cons)); +} -ao_poly -ao_scheme_poly_fetch(int id); +static inline struct ao_scheme_cons * +ao_scheme_cons_fetch(void) { + return ao_scheme_poly_cons(ao_scheme_poly_fetch()); +} -void -ao_scheme_string_stash(int id, struct ao_scheme_string *string); +static inline void +ao_scheme_atom_stash(struct ao_scheme_atom *atom) { + ao_scheme_poly_stash(ao_scheme_atom_poly(atom)); +} -struct ao_scheme_string * -ao_scheme_string_fetch(int id); +static inline struct ao_scheme_atom * +ao_scheme_atom_fetch(void) { + return ao_scheme_poly_atom(ao_scheme_poly_fetch()); +} + +static inline void +ao_scheme_string_stash(struct ao_scheme_string *string) { + ao_scheme_poly_stash(ao_scheme_string_poly(string)); +} +static inline struct ao_scheme_string * +ao_scheme_string_fetch(void) { + return ao_scheme_poly_string(ao_scheme_poly_fetch()); +} + +#ifdef AO_SCHEME_FEATURE_VECTOR static inline void -ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { - ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +ao_scheme_vector_stash(struct ao_scheme_vector *vector) { + ao_scheme_poly_stash(ao_scheme_vector_poly(vector)); +} + +static inline struct ao_scheme_vector * +ao_scheme_vector_fetch(void) { + return ao_scheme_poly_vector(ao_scheme_poly_fetch()); +} +#endif + +static inline void +ao_scheme_stack_stash(struct ao_scheme_stack *stack) { + ao_scheme_poly_stash(ao_scheme_stack_poly(stack)); } static inline struct ao_scheme_stack * -ao_scheme_stack_fetch(int id) { - return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +ao_scheme_stack_fetch(void) { + return ao_scheme_poly_stack(ao_scheme_poly_fetch()); } -void -ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); +static inline void +ao_scheme_frame_stash(struct ao_scheme_frame *frame) { + ao_scheme_poly_stash(ao_scheme_frame_poly(frame)); +} -struct ao_scheme_frame * -ao_scheme_frame_fetch(int id); +static inline struct ao_scheme_frame * +ao_scheme_frame_fetch(void) { + return ao_scheme_poly_frame(ao_scheme_poly_fetch()); +} /* bool */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index 8989cefd..c72a2b27 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -107,9 +107,9 @@ ao_scheme_string_to_atom(struct ao_scheme_string *string) if (atom) return atom; - ao_scheme_string_stash(0, string); + ao_scheme_string_stash(string); atom = ao_scheme_alloc(name_size(string->val)); - string = ao_scheme_string_fetch(0); + string = ao_scheme_string_fetch(); ao_scheme_atom_init(atom, string->val); return atom; } diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 84382434..81fd9010 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -321,7 +321,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) if (cons == orig_cons) { ret = car; - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); if (cons->cdr == AO_SCHEME_NIL) { switch (op) { case builtin_minus: @@ -349,7 +349,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) break; } } - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { int32_t r = ao_scheme_poly_integer(ret, NULL); int32_t c = ao_scheme_poly_integer(car, NULL); @@ -413,9 +413,9 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); ret = ao_scheme_integer_poly(r); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); #ifdef AO_SCHEME_FEATURE_FLOAT } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { float r, c; @@ -442,16 +442,16 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); ret = ao_scheme_float_get(r); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); #endif } else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), ao_scheme_poly_string(car))); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); if (!ret) return ret; } diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 1a2de823..a9ff5acd 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -92,11 +92,11 @@ ao_scheme_cons_cons(ao_poly car, ao_poly cdr) cons = ao_scheme_cons_free_list; ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); } else { - ao_scheme_poly_stash(0, car); - ao_scheme_poly_stash(1, cdr); + ao_scheme_poly_stash(car); + ao_scheme_poly_stash(cdr); cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - cdr = ao_scheme_poly_fetch(1); - car = ao_scheme_poly_fetch(0); + cdr = ao_scheme_poly_fetch(); + car = ao_scheme_poly_fetch(); if (!cons) return NULL; } @@ -134,13 +134,13 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons) struct ao_scheme_cons *new; ao_poly cdr; - ao_scheme_cons_stash(0, cons); - ao_scheme_cons_stash(1, head); - ao_scheme_poly_stash(0, ao_scheme_cons_poly(tail)); + ao_scheme_cons_stash(cons); + ao_scheme_cons_stash(head); + ao_scheme_cons_stash(tail); new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - cons = ao_scheme_cons_fetch(0); - head = ao_scheme_cons_fetch(1); - tail = ao_scheme_poly_cons(ao_scheme_poly_fetch(0)); + tail = ao_scheme_cons_fetch(); + head = ao_scheme_cons_fetch(); + cons = ao_scheme_cons_fetch(); if (!new) return AO_SCHEME_NIL; new->car = cons->car; diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index a7e5153f..16da62fb 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -250,9 +250,9 @@ ao_scheme_frame_new(int num) frame->num = 0; frame->prev = AO_SCHEME_NIL; frame->vals = AO_SCHEME_NIL; - ao_scheme_frame_stash(0, frame); + ao_scheme_frame_stash(frame); vals = ao_scheme_frame_vals_new(num); - frame = ao_scheme_frame_fetch(0); + frame = ao_scheme_frame_fetch(); if (!vals) return NULL; frame->vals = ao_scheme_frame_vals_poly(vals); @@ -296,9 +296,9 @@ ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) if (new_num == frame->num) return frame; - ao_scheme_frame_stash(0, frame); + ao_scheme_frame_stash(frame); new_vals = ao_scheme_frame_vals_new(new_num); - frame = ao_scheme_frame_fetch(0); + frame = ao_scheme_frame_fetch(); if (!new_vals) return NULL; vals = ao_scheme_poly_frame_vals(frame->vals); @@ -331,11 +331,11 @@ ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) if (!ref) { int f = frame->num; - ao_scheme_poly_stash(0, atom); - ao_scheme_poly_stash(1, val); + ao_scheme_poly_stash(atom); + ao_scheme_poly_stash(val); frame = ao_scheme_frame_realloc(frame, f + 1); - val = ao_scheme_poly_fetch(1); - atom = ao_scheme_poly_fetch(0); + val = ao_scheme_poly_fetch(); + atom = ao_scheme_poly_fetch(); if (!frame) return AO_SCHEME_NIL; ao_scheme_frame_bind(frame, frame->num - 1, atom, val); diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c index e8ce0710..e818d7b0 100644 --- a/src/scheme/ao_scheme_lambda.c +++ b/src/scheme/ao_scheme_lambda.c @@ -89,9 +89,9 @@ ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) } } - ao_scheme_cons_stash(0, code); + ao_scheme_cons_stash(code); lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); - code = ao_scheme_cons_fetch(0); + code = ao_scheme_cons_fetch(); if (!lambda) return AO_SCHEME_NIL; @@ -160,9 +160,9 @@ ao_scheme_lambda_eval(void) return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); } - ao_scheme_poly_stash(1, varargs); + ao_scheme_poly_stash(varargs); next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); - varargs = ao_scheme_poly_fetch(1); + varargs = ao_scheme_poly_fetch(); if (!next_frame) return AO_SCHEME_NIL; diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 55872b62..c9215072 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -184,43 +184,34 @@ struct ao_scheme_root { void **addr; }; -static struct ao_scheme_cons *save_cons[2]; -static struct ao_scheme_string *save_string[2]; -static struct ao_scheme_frame *save_frame[1]; -static ao_poly save_poly[3]; +#define AO_SCHEME_NUM_STASH 6 +static ao_poly stash_poly[AO_SCHEME_NUM_STASH]; +static int stash_poly_ptr; static const struct ao_scheme_root ao_scheme_root[] = { { - .type = &ao_scheme_cons_type, - .addr = (void **) &save_cons[0], - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &save_cons[1], - }, - { - .type = &ao_scheme_string_type, - .addr = (void **) &save_string[0], + .type = NULL, + .addr = (void **) (void *) &stash_poly[0] }, { - .type = &ao_scheme_string_type, - .addr = (void **) &save_string[1], + .type = NULL, + .addr = (void **) (void *) &stash_poly[1] }, { - .type = &ao_scheme_frame_type, - .addr = (void **) &save_frame[0], + .type = NULL, + .addr = (void **) (void *) &stash_poly[2] }, { .type = NULL, - .addr = (void **) (void *) &save_poly[0] + .addr = (void **) (void *) &stash_poly[3] }, { .type = NULL, - .addr = (void **) (void *) &save_poly[1] + .addr = (void **) (void *) &stash_poly[4] }, { .type = NULL, - .addr = (void **) (void *) &save_poly[2] + .addr = (void **) (void *) &stash_poly[5] }, { .type = &ao_scheme_atom_type, @@ -991,63 +982,21 @@ ao_scheme_alloc(int size) } void -ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) -{ - assert(save_cons[id] == 0); - save_cons[id] = cons; -} - -struct ao_scheme_cons * -ao_scheme_cons_fetch(int id) -{ - struct ao_scheme_cons *cons = save_cons[id]; - save_cons[id] = NULL; - return cons; -} - -void -ao_scheme_poly_stash(int id, ao_poly poly) +ao_scheme_poly_stash(ao_poly p) { - assert(save_poly[id] == AO_SCHEME_NIL); - save_poly[id] = poly; + assert(stash_poly_ptr < AO_SCHEME_NUM_STASH); + stash_poly[stash_poly_ptr++] = p; } ao_poly -ao_scheme_poly_fetch(int id) -{ - ao_poly poly = save_poly[id]; - save_poly[id] = AO_SCHEME_NIL; - return poly; -} - -void -ao_scheme_string_stash(int id, struct ao_scheme_string *string) +ao_scheme_poly_fetch(void) { - assert(save_string[id] == NULL); - save_string[id] = string; -} + ao_poly p; -struct ao_scheme_string * -ao_scheme_string_fetch(int id) -{ - struct ao_scheme_string *string = save_string[id]; - save_string[id] = NULL; - return string; -} - -void -ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) -{ - assert(save_frame[id] == NULL); - save_frame[id] = frame; -} - -struct ao_scheme_frame * -ao_scheme_frame_fetch(int id) -{ - struct ao_scheme_frame *frame = save_frame[id]; - save_frame[id] = NULL; - return frame; + assert (stash_poly_ptr > 0); + p = stash_poly[--stash_poly_ptr]; + stash_poly[stash_poly_ptr] = AO_SCHEME_NIL; + return p; } int diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c index e29e2b68..863df3ca 100644 --- a/src/scheme/ao_scheme_stack.c +++ b/src/scheme/ao_scheme_stack.c @@ -199,13 +199,13 @@ ao_scheme_stack_copy(struct ao_scheme_stack *old) struct ao_scheme_stack *n, *prev = NULL; while (old) { - ao_scheme_stack_stash(0, old); - ao_scheme_stack_stash(1, new); - ao_scheme_stack_stash(2, prev); + ao_scheme_stack_stash(old); + ao_scheme_stack_stash(new); + ao_scheme_stack_stash(prev); n = ao_scheme_stack_new(); - prev = ao_scheme_stack_fetch(2); - new = ao_scheme_stack_fetch(1); - old = ao_scheme_stack_fetch(0); + prev = ao_scheme_stack_fetch(); + new = ao_scheme_stack_fetch(); + old = ao_scheme_stack_fetch(); if (!n) return NULL; diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index b00ef276..dfc74966 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -60,9 +60,9 @@ ao_scheme_string_copy(struct ao_scheme_string *a) int alen = strlen(a->val); struct ao_scheme_string *r; - ao_scheme_string_stash(0, a); + ao_scheme_string_stash(a); r = ao_scheme_string_alloc(alen); - a = ao_scheme_string_fetch(0); + a = ao_scheme_string_fetch(); if (!r) return NULL; strcpy(r->val, a->val); @@ -87,9 +87,9 @@ ao_scheme_atom_to_string(struct ao_scheme_atom *a) int alen = strlen(a->name); struct ao_scheme_string *r; - ao_scheme_poly_stash(0, ao_scheme_atom_poly(a)); + ao_scheme_atom_stash(a); r = ao_scheme_string_alloc(alen); - a = ao_scheme_poly_atom(ao_scheme_poly_fetch(0)); + a = ao_scheme_atom_fetch(); if (!r) return NULL; strcpy(r->val, a->name); @@ -103,11 +103,11 @@ ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) int blen = strlen(b->val); struct ao_scheme_string *r; - ao_scheme_string_stash(0, a); - ao_scheme_string_stash(1, b); + ao_scheme_string_stash(a); + ao_scheme_string_stash(b); r = ao_scheme_string_alloc(alen + blen); - a = ao_scheme_string_fetch(0); - b = ao_scheme_string_fetch(1); + b = ao_scheme_string_fetch(); + a = ao_scheme_string_fetch(); if (!r) return NULL; strcpy(r->val, a->val); @@ -123,9 +123,9 @@ ao_scheme_string_pack(struct ao_scheme_cons *cons) int len; len = ao_scheme_cons_length(cons); - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); r = ao_scheme_string_alloc(len); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); if (!r) return AO_SCHEME_NIL; rval = r->val; @@ -151,13 +151,13 @@ ao_scheme_string_unpack(struct ao_scheme_string *a) for (i = 0; (c = a->val[i]); i++) { struct ao_scheme_cons *n; - ao_scheme_cons_stash(0, cons); - ao_scheme_cons_stash(1, tail); - ao_scheme_string_stash(0, a); + ao_scheme_cons_stash(cons); + ao_scheme_cons_stash(tail); + ao_scheme_string_stash(a); n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); - a = ao_scheme_string_fetch(0); - cons = ao_scheme_cons_fetch(0); - tail = ao_scheme_cons_fetch(1); + a = ao_scheme_string_fetch(); + tail = ao_scheme_cons_fetch(); + cons = ao_scheme_cons_fetch(); if (!n) { cons = NULL; diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index 419d6765..afdc89a8 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -145,9 +145,9 @@ ao_scheme_list_to_vector(struct ao_scheme_cons *cons) if (ao_scheme_exception) return NULL; - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); if (!vector) return NULL; i = 0; @@ -166,9 +166,9 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector) struct ao_scheme_cons *cons = NULL; for (i = length; i-- > 0;) { - ao_scheme_poly_stash(2, ao_scheme_vector_poly(vector)); + ao_scheme_vector_stash(vector); cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons)); - vector = ao_scheme_poly_vector(ao_scheme_poly_fetch(2)); + vector = ao_scheme_vector_fetch(); if (!cons) return NULL; } -- cgit v1.2.3