From 195cbeec19a6a44f309a9040d727d37fe4e2ec97 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:29:13 -0800 Subject: altos/scheme: Rename to 'scheme', clean up build Constant block is now built in a subdir to avoid messing up source directory. Renamed to ao_scheme to reflect language target. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_mem.c | 968 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 968 insertions(+) create mode 100644 src/scheme/ao_scheme_mem.c (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include +#include + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_scheme_record { + struct ao_scheme_record *next; + const struct ao_scheme_type *type; + void *addr; + int size; +}; + +static struct ao_scheme_record *record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ + while (record) { + struct ao_scheme_record *next = record->next; + free(record); + record = next; + } +} + +static void +ao_scheme_record_reset(void) +{ + ao_scheme_record_free(record_head); + record_head = NULL; + record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type *type, + void *addr, + int size) +{ + struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record)); + + r->next = NULL; + r->type = type; + r->addr = addr; + r->size = size; + *record_tail = r; + record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ + struct ao_scheme_record *r = record_head; + + record_head = NULL; + record_tail = &record_head; + return r; +} + +static void +ao_scheme_record_compare(char *where, + struct ao_scheme_record *a, + struct ao_scheme_record *b) +{ + while (a && b) { + if (a->type != b->type || a->size != b->size) { + printf("%s record difers %d %s %d -> %d %s %d\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } + a = a->next; + b = b->next; + } + if (a) { + printf("%s record differs %d %s %d -> NULL\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size); + ao_scheme_abort(); + } + if (b) { + printf("%s record differs NULL -> %d %s %d\n", + where, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t ao_scheme_exception; + +struct ao_scheme_root { + const struct ao_scheme_type *type; + void **addr; +}; + +static struct ao_scheme_cons *save_cons[2]; +static char *save_string[2]; +static struct ao_scheme_frame *save_frame[1]; +static ao_poly save_poly[3]; + +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 = &ao_scheme_string_type, + .addr = (void **) &save_string[1], + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &save_frame[0], + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[1] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[2] + }, + { + .type = &ao_scheme_atom_type, + .addr = (void **) &ao_scheme_atoms + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_global, + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_current, + }, + { + .type = &ao_scheme_stack_type, + .addr = (void **) &ao_scheme_stack, + }, + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_v, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons_tail, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_stack, + }, +#ifdef AO_SCHEME_MAKE_CONST + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_false, + }, + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_true, + }, +#endif +}; + +#define AO_SCHEME_ROOT (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { + (const void **) &ao_scheme_cons_free_list, + (const void **) &ao_scheme_stack_free_list, + (const void **) &ao_scheme_frame_free_list[0], + (const void **) &ao_scheme_frame_free_list[1], + (const void **) &ao_scheme_frame_free_list[2], + (const void **) &ao_scheme_frame_free_list[3], + (const void **) &ao_scheme_frame_free_list[4], + (const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) + +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]; +static uint8_t ao_scheme_cons_noted; + +uint16_t ao_scheme_top; + +struct ao_scheme_chunk { + uint16_t old_offset; + union { + uint16_t size; + uint16_t new_offset; + }; +}; + +#define AO_SCHEME_NCHUNK 64 + +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)) + ao_scheme_abort(); +#endif + return ((uint8_t *) addr) - ao_scheme_pool; +} + +static inline void mark(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { + return min(AO_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ + MDBG_MOVE("note cons %d\n", offset); + ao_scheme_cons_noted = 1; + mark(ao_scheme_cons_note, offset); +} + +static uint16_t chunk_low, chunk_high; +static uint16_t chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ + int l, r; + /* Binary search for the location */ + l = chunk_first; + r = chunk_last - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (ao_scheme_chunk[m].old_offset < offset) + l = m + 1; + else + r = m - 1; + } + return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return; + + l = find_chunk(offset); + + /* + * The correct location is always in 'l', with r = l-1 being + * the entry before the right one + */ + +#if DBG_MEM + /* Off the right side */ + if (l >= AO_SCHEME_NCHUNK) + ao_scheme_abort(); + + /* Off the left side */ + if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) + ao_scheme_abort(); +#endif + + /* Shuffle existing entries right */ + int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + + memmove(&ao_scheme_chunk[l+1], + &ao_scheme_chunk[l], + (end - (l+1)) * sizeof (struct ao_scheme_chunk)); + + /* Add new entry */ + ao_scheme_chunk[l].old_offset = offset; + ao_scheme_chunk[l].size = size; + + /* Increment the number of elements up to the size of the array */ + if (chunk_last < AO_SCHEME_NCHUNK) + chunk_last++; + + /* Set the top address if the array is full */ + if (chunk_last == AO_SCHEME_NCHUNK) + chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + + ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ + chunk_high = ao_scheme_top; + chunk_last = 0; + chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), + int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ + int i; + + ao_scheme_record_reset(); + memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { + if (ao_scheme_root[i].type) { + void **a = ao_scheme_root[i].addr, *v; + if (a && (v = *a)) { + MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); + visit_addr(ao_scheme_root[i].type, a); + } + } else { + ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; + if (a && (p = *a)) { + MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); + visit_poly(a, 0); + } + } + } + while (ao_scheme_cons_noted) { + memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < AO_SCHEME_POOL; i += 4) { + if (busy(ao_scheme_cons_last, i)) { + void *v = ao_scheme_pool + i; + MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); + visit_addr(&ao_scheme_cons_type, &v); + } + } + } +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ + int i; + MDBG_MOVE("busy:"); + for (i = 0; i < ao_scheme_top; i += 4) { + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } + else if ((i & 0x1f) == 0) + MDBG_MORE(" "); + if (busy(ao_scheme_busy, i)) + MDBG_MORE("*"); + else + MDBG_MORE("-"); + } + MDBG_MORE ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +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, + [AO_SCHEME_OTHER] = (void *) 0x1, + [AO_SCHEME_ATOM] = &ao_scheme_atom_type, + [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, + [AO_SCHEME_FRAME] = &ao_scheme_frame_type, + [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, + [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, + [AO_SCHEME_STACK] = &ao_scheme_stack_type, + [AO_SCHEME_BOOL] = &ao_scheme_bool_type, + [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, + [AO_SCHEME_FLOAT] = &ao_scheme_float_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ + return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ + return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ + int i; + int top; +#if DBG_MEM_STATS + int loops = 0; +#endif +#if DBG_MEM + struct ao_scheme_record *mark_record = NULL, *move_record = NULL; + + MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + + /* The first time through, we're doing a full collect */ + if (ao_scheme_last_top == 0) + style = AO_SCHEME_COLLECT_FULL; + + /* Clear references to all caches */ + for (i = 0; i < (int) AO_SCHEME_CACHE; i++) + *ao_scheme_cache[i] = NULL; + if (style == AO_SCHEME_COLLECT_FULL) { + chunk_low = top = 0; + } else { + 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 + + ao_scheme_record_free(mark_record); + mark_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("mark", move_record, mark_record); +#endif + + DUMP_BUSY(); + + /* 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(); +#endif + + if (ao_scheme_chunk[i].old_offset > top) + break; + + MDBG_MOVE("chunk %d %d not moving\n", + ao_scheme_chunk[i].old_offset, + ao_scheme_chunk[i].size); +#if DBG_MEM + if (ao_scheme_chunk[i].old_offset != top) + ao_scheme_abort(); +#endif + top += size; + } + + /* + * Limit amount of chunk array used in mapping moves + * to the active region + */ + chunk_first = i; + chunk_low = ao_scheme_chunk[i].old_offset; + + /* Copy all of the objects */ + for (; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + MDBG_MOVE("chunk %d %d -> %d\n", + ao_scheme_chunk[i].old_offset, + size, + top); + ao_scheme_chunk[i].new_offset = top; + + memmove(&ao_scheme_pool[top], + &ao_scheme_pool[ao_scheme_chunk[i].old_offset], + size); + + top += size; + } + + if (chunk_first < chunk_last) { + /* Relocate all references to the objects */ + walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM + ao_scheme_record_free(move_record); + move_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("move", mark_record, move_record); +#endif + } + + /* If we ran into the end of the heap, then + * there's no need to keep walking + */ + if (chunk_last != AO_SCHEME_NCHUNK) + break; + + /* Next loop starts right above this loop */ + chunk_low = chunk_high; + } + +#if DBG_MEM_STATS + /* Collect stats */ + ++ao_scheme_collects[style]; + ao_scheme_freed[style] += ao_scheme_top - top; + ao_scheme_loops[style] += loops; +#endif + + ao_scheme_top = top; + if (style == AO_SCHEME_COLLECT_FULL) + ao_scheme_last_top = top; + + MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + + return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ + ao_poly cdr; + int offset; + + chunk_low = 0; + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); + while (cons) { + if (!AO_SCHEME_IS_POOL(cons)) + break; + offset = pool_offset(cons); + if (busy(ao_scheme_busy, offset)) { + ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); + abort(); + } + cdr = cons->cdr; + if (!ao_scheme_is_pair(cdr)) + break; + cons = ao_scheme_poly_cons(cdr); + } +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * 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 + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ + 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, ao_scheme_size(type, addr)); + return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ + int ret; + MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_mark_memory(type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + type->mark(addr); + } + MDBG_MOVE_OUT(); + return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ + uint8_t type; + void *addr; + + type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(pool_offset(addr)); + return 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(addr); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + return ao_scheme_mark(lisp_type, addr); + } +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return offset; + + l = find_chunk(offset); + +#if DBG_MEM + if (ao_scheme_chunk[l].old_offset != offset) + ao_scheme_abort(); +#endif + return ao_scheme_chunk[l].new_offset; +} + +int +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)) + return 1; + + (void) type; + + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); + orig_offset = pool_offset(addr); + 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, + orig_offset, offset); + *ref = ao_scheme_pool + offset; + } + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already moved\n"); + return 1; + } + mark(ao_scheme_busy, offset); + MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ + int ret; + MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); + MDBG_MOVE_IN(); + ret = ao_scheme_move_memory(type, ref); + if (!ret) { + MDBG_MOVE("move recurse\n"); + type->move(*ref); + } + MDBG_MOVE_OUT(); + return ret; +} + +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) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(orig_offset); + ret = 1; + } else { + 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]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + ret = ao_scheme_move(lisp_type, &addr); + } + + /* Re-write the poly value */ + if (offset != orig_offset) { + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, orig_offset, offset); + *ref = np; + } + return ret; +} + +#if DBG_MEM +void +ao_scheme_validate(void) +{ + chunk_low = 0; + memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ + void *addr; + + MDBG_DO(++dbg_allocs); + MDBG_DO(if (dbg_validate) ao_scheme_validate()); + size = ao_scheme_size_round(size); + if (AO_SCHEME_POOL - ao_scheme_top < size && + ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && + ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) + { + ao_scheme_error(AO_SCHEME_OOM, "out of memory"); + return NULL; + } + addr = ao_scheme_pool + ao_scheme_top; + ao_scheme_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); + return addr; +} + +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) +{ + assert(save_poly[id] == AO_SCHEME_NIL); + save_poly[id] = poly; +} + +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, char *string) +{ + assert(save_string[id] == NULL); + save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ + char *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; +} -- cgit v1.2.3 From 17fe6de833cccb6d43d0ac0ed84a4faaa3463a09 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:02:00 -0800 Subject: altos/scheme: Add vectors Constant time and smaller can be a feature. Signed-off-by: Keith Packard --- src/scheme/Makefile-inc | 3 +- src/scheme/README | 2 +- src/scheme/ao_scheme.h | 48 ++- src/scheme/ao_scheme_builtin.c | 65 +++- src/scheme/ao_scheme_builtin.txt | 7 + src/scheme/ao_scheme_const.lisp | 813 --------------------------------------- src/scheme/ao_scheme_eval.c | 8 +- src/scheme/ao_scheme_mem.c | 1 + src/scheme/ao_scheme_poly.c | 4 + src/scheme/ao_scheme_read.c | 14 +- src/scheme/ao_scheme_read.h | 1 + 11 files changed, 139 insertions(+), 827 deletions(-) delete mode 100644 src/scheme/ao_scheme_const.lisp (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc index d23ee3d7..1a080a4e 100644 --- a/src/scheme/Makefile-inc +++ b/src/scheme/Makefile-inc @@ -15,7 +15,8 @@ SCHEME_SRCS=\ ao_scheme_rep.c \ ao_scheme_save.c \ ao_scheme_stack.c \ - ao_scheme_error.c + ao_scheme_error.c \ + ao_scheme_vector.c SCHEME_HDRS=\ ao_scheme.h \ diff --git a/src/scheme/README b/src/scheme/README index 98932b44..a18457fd 100644 --- a/src/scheme/README +++ b/src/scheme/README @@ -5,6 +5,6 @@ This follows the R7RS with the following known exceptions: * No dynamic-wind or exceptions * No environments * No ports -* No syntax-rules; (have classic macros) +* No syntax-rules * No record types * No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 10518716..89616617 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -104,7 +104,8 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_BOOL 10 #define AO_SCHEME_BIGINT 11 #define AO_SCHEME_FLOAT 12 -#define AO_SCHEME_NUM_TYPE 13 +#define AO_SCHEME_VECTOR 13 +#define AO_SCHEME_NUM_TYPE 14 /* Leave two bits for types to use as they please */ #define AO_SCHEME_OTHER_TYPE_MASK 0x3f @@ -192,6 +193,13 @@ struct ao_scheme_float { float value; }; +struct ao_scheme_vector { + uint8_t type; + uint8_t pad1; + uint16_t length; + ao_poly vals[]; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_scheme_int_bigint(int32_t i) { @@ -500,6 +508,18 @@ ao_scheme_poly_float(ao_poly poly) float ao_scheme_poly_number(ao_poly p); +static inline ao_poly +ao_scheme_vector_poly(struct ao_scheme_vector *v) +{ + return ao_scheme_poly(v, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_vector * +ao_scheme_poly_vector(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + /* memory functions */ extern int ao_scheme_collects[2]; @@ -680,6 +700,32 @@ void ao_scheme_bigint_write(ao_poly i); extern const struct ao_scheme_type ao_scheme_bigint_type; + +/* vector */ + +void +ao_scheme_vector_write(ao_poly v); + +void +ao_scheme_vector_display(ao_poly v); + +struct ao_scheme_vector * +ao_scheme_vector_alloc(uint16_t length, ao_poly fill); + +ao_poly +ao_scheme_vector_get(ao_poly v, ao_poly i); + +ao_poly +ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p); + +struct ao_scheme_vector * +ao_scheme_list_to_vector(struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +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(ao_poly p); diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index aa818646..ae96df7f 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -267,7 +267,6 @@ ao_scheme_do_write(struct ao_scheme_cons *cons) if (cons) printf(" "); } - printf("\n"); return _ao_scheme_bool_true; } @@ -751,7 +750,7 @@ ao_poly ao_scheme_do_listp(struct ao_scheme_cons *cons) { ao_poly v; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); for (;;) { @@ -864,5 +863,67 @@ ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); } +ao_poly +ao_scheme_do_vector(struct ao_scheme_cons *cons) +{ + return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); +} + +ao_poly +ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_vector_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2)); +} + +ao_poly +ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length); +} + +ao_poly +ao_scheme_do_vectorp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); +} + #define AO_SCHEME_BUILTIN_FUNCS #include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index cb65e252..e7b3d75c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -66,3 +66,10 @@ f_lambda finitep finite? f_lambda infinitep infinite? f_lambda inexactp inexact? f_lambda sqrt +f_lambda vector_ref vector-ref +f_lambda vector_set vector-set! +f_lambda vector +f_lambda list_to_vector list->vector +f_lambda vector_to_list vector->list +f_lambda vector_length vector-length +f_lambda vectorp vector? diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp deleted file mode 100644 index 422bdd63..00000000 --- a/src/scheme/ao_scheme_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(or #f #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(and #t #f) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((list? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - - ; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) `(> ,value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) `(< ,value 0))) - -(negative? 12) -(negative? -12) - -(define (abs x) (if (>= x 0) x (- x))) - -(abs 12) -(abs -12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? x) (zero? (% x 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? x) (not (even? x))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - -(define (list-ref x k) - (car (list-tail x k)) - ) - - ; define a set of local - ; variables all at once and - ; then evaluate a list of - ; sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(let ((x 1) (y)) (set! y 2) (+ x y)) - - ; define a set of local - ; variables one at a time and - ; then evaluate a list of - ; sexprs - ; - ; (let* (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define let* - (macro (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(let* ((x 1) (y x)) (+ x y)) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (write 'when)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (write 'unless)) - -(define (reverse list) - (let ((result ())) - (while (not (null? list)) - (set! result (cons (car list) result)) - (set! list (cdr list)) - ) - result) - ) - -(reverse '(1 2 3)) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref x k) (car (list-tail x k))) - -(list-ref '(1 2 3) 2) - - ; recursive equality - -(define (equal? a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - (else #f) - ) - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj list) (member obj list eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (memv obj list) (member obj list eqv?)) - -(memv 2 '(1 2 3)) - -(memv 4 '(1 2 3)) - -(memv '(2) '((1) (2) (3))) - -(define (_assoc obj list test?) - (if (null? list) - #f - (if (test? obj (caar list)) - (car list) - (_assoc obj (cdr list) test?) - ) - ) - ) - -(define (assq obj list) (_assoc obj list eq?)) -(define (assv obj list) (_assoc obj list eqv?)) -(define (assoc obj list) (_assoc obj list equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assv 'b '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define (char->integer c) c) -(define (integer->char c) char-integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define string (lambda chars (list->string chars))) - -(display "apply\n") -(apply cons '(a b)) - -(define map - (lambda (proc . lists) - (define (args lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (args (cdr lists))) - ) - ) - ) - (define (next lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (next (cdr lists))) - ) - ) - ) - (define (domap lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (args lists)) (domap (next lists))) - ) - ) - ) - (domap lists) - ) - ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (proc . lists) - (apply map proc lists) - #t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (_string-ml strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings))) - ) - ) - -(define string-map (lambda (proc . strings) - (list->string (apply map proc (_string-ml strings)))))) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-for-each (lambda (proc . strings) - (apply for-each proc (_string-ml strings)))) - -(string-for-each write-char "IBM\n") - -(define (newline) (write-char #\newline)) - -(newline) - -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (write "test" x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - -(define repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write 'goodbye x)) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 9b3cf63e..907ecf0b 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -108,13 +108,7 @@ ao_scheme_eval_sexpr(void) DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); /* fall through */ - case AO_SCHEME_BOOL: - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - case AO_SCHEME_FLOAT: - case AO_SCHEME_STRING: - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: + default: ao_scheme_stack->state = eval_val; break; } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index acc726c8..fe4bc4f5 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -467,6 +467,7 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_BOOL] = &ao_scheme_bool_type, [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, [AO_SCHEME_FLOAT] = &ao_scheme_float_type, + [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, }; static int diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index d726321c..553585db 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -68,6 +68,10 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_float_write, .display = ao_scheme_float_write, }, + [AO_SCHEME_VECTOR] = { + .write = ao_scheme_vector_write, + .display = ao_scheme_vector_display + }, }; static const struct ao_scheme_funcs * diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 30e29441..9ed54b9f 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -340,6 +340,8 @@ _lex(void) add_token(c); end_token(); return BOOL; + case '(': + return OPEN_VECTOR; case '\\': for (;;) { int alphabetic; @@ -474,10 +476,12 @@ int ao_scheme_read_list; struct ao_scheme_cons *ao_scheme_read_cons; struct ao_scheme_cons *ao_scheme_read_cons_tail; struct ao_scheme_cons *ao_scheme_read_stack; +static int ao_scheme_read_state; #define READ_IN_QUOTE 0x01 #define READ_SAW_DOT 0x02 #define READ_DONE_DOT 0x04 +#define READ_SAW_VECTOR 0x08 static int push_read_stack(int read_state) @@ -490,7 +494,8 @@ push_read_stack(int read_state) ao_scheme_cons_poly(ao_scheme_read_stack))); if (!ao_scheme_read_stack) return 0; - } + } else + ao_scheme_read_state = read_state; ao_scheme_read_cons = NULL; ao_scheme_read_cons_tail = NULL; return 1; @@ -513,6 +518,7 @@ pop_read_stack(void) ao_scheme_read_cons = 0; ao_scheme_read_cons_tail = 0; ao_scheme_read_stack = 0; + read_state = ao_scheme_read_state; } RDBG_OUT(); RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); @@ -532,7 +538,9 @@ ao_scheme_read(void) ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); - while (parse_token == OPEN) { + while (parse_token == OPEN || parse_token == OPEN_VECTOR) { + if (parse_token == OPEN_VECTOR) + read_state |= READ_SAW_VECTOR; if (!push_read_stack(read_state)) return AO_SCHEME_NIL; ao_scheme_read_list++; @@ -604,6 +612,8 @@ ao_scheme_read(void) v = ao_scheme_cons_poly(ao_scheme_read_cons); --ao_scheme_read_list; read_state = pop_read_stack(); + if (read_state & READ_SAW_VECTOR) + v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); break; case DOT: if (!ao_scheme_read_list) { diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index e9508835..e10a7d05 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -32,6 +32,7 @@ # define FLOAT 10 # define DOT 11 # define BOOL 12 +# define OPEN_VECTOR 13 /* * character classes -- cgit v1.2.3 From 7517da1646fc30faaa9ee1c969cfa35ae1a17423 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:50:06 -0800 Subject: altos/scheme: Use 64-bit ints to track memory allocation stats These are only collected for debug purposes, but can get quite large if the interpreter runs for a while. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 6 +++--- src/scheme/ao_scheme_mem.c | 6 +++--- src/scheme/test/ao_scheme_test.c | 6 +++--- 3 files changed, 9 insertions(+), 9 deletions(-) (limited to 'src/scheme/ao_scheme_mem.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 89616617..4655b2a9 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -522,9 +522,9 @@ ao_scheme_poly_vector(ao_poly poly) /* memory functions */ -extern int ao_scheme_collects[2]; -extern int ao_scheme_freed[2]; -extern int ao_scheme_loops[2]; +extern uint64_t ao_scheme_collects[2]; +extern uint64_t ao_scheme_freed[2]; +extern uint64_t ao_scheme_loops[2]; /* returns 1 if the object was already marked */ int diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index fe4bc4f5..45d4de98 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -483,9 +483,9 @@ ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) } #if DBG_MEM_STATS -int ao_scheme_collects[2]; -int ao_scheme_freed[2]; -int ao_scheme_loops[2]; +uint64_t ao_scheme_collects[2]; +uint64_t ao_scheme_freed[2]; +uint64_t ao_scheme_loops[2]; #endif int ao_scheme_last_top; diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 686e7169..0c77d8d5 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -107,15 +107,15 @@ main (int argc, char **argv) } ao_scheme_read_eval_print(); - printf ("collects: full: %d incremental %d\n", + printf ("collects: full: %lu incremental %lu\n", ao_scheme_collects[AO_SCHEME_COLLECT_FULL], ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - printf ("freed: full %d incremental %d\n", + printf ("freed: full %lu incremental %lu\n", ao_scheme_freed[AO_SCHEME_COLLECT_FULL], ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); - printf("loops: full %d incremental %d\n", + printf("loops: full %lu incremental %lu\n", ao_scheme_loops[AO_SCHEME_COLLECT_FULL], ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); -- cgit v1.2.3