From 8b336eecd891382c13e57d860673220a4c75379f Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Fri, 16 Dec 2022 15:38:41 +0100 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from c94f3404..d77214e9 d77214e9 a cleaning pass that removes some now dead code and fixes some comments. Also removed a pointless clearing of gc mark bit in allocate_cell and allocate_list 115b38f5 adding closing of read channel in case of errors while reading 9a0fb3ca added some gc tormenting tests that also uses the new list allocator a75c10a7 fix bug in heap_allocate_list and fix bug in reader (read channel not closed if reading fails) ad8243d2 rewrote fundamental_range using heap_allocate_list. b7320588 added lbm_heap_allocate_list and adapted fundamental_list to use it. 20906de7 Rearrangement of heap_allocate_cell. May make cons slightly more efficient git-subtree-dir: lispBM/lispBM git-subtree-split: d77214e93497506118add4ff6b3f63520239a445 --- include/env.h | 9 ------ include/heap.h | 5 ++++ include/lbm_version.h | 4 +++ src/env.c | 23 --------------- src/eval_cps.c | 42 +++++++++++++++++++------- src/fundamental.c | 44 ++++++++++++++++------------ src/heap.c | 65 +++++++++++++++++++++++++---------------- src/lbm_memory.c | 4 +-- tests/test_list_5.lisp | 1 + tests/test_range_5.lisp | 8 +++++ tests/test_range_6.lisp | 15 ++++++++++ tests/test_range_7.lisp | 27 +++++++++++++++++ tests/test_range_8.lisp | 8 +++++ 13 files changed, 167 insertions(+), 88 deletions(-) create mode 100644 tests/test_list_5.lisp create mode 100644 tests/test_range_5.lisp create mode 100644 tests/test_range_6.lisp create mode 100644 tests/test_range_7.lisp create mode 100644 tests/test_range_8.lisp diff --git a/include/env.h b/include/env.h index 1743dfc9..5c1af2bf 100644 --- a/include/env.h +++ b/include/env.h @@ -41,15 +41,6 @@ lbm_value *lbm_get_env_ptr(void); * \return the global environment */ lbm_value lbm_get_env(void); -/** Performs a shallow copy of a proper list. A shallow copy does - * not recurse into the elements of the list to copy - * those as well. So if the list contains complex elements, the - * original list and the copy will share these elements on the heap. - * - * \param env List to copy. - * \return Shallow copy of input list. - */ -lbm_value lbm_env_copy_shallow(lbm_value env); /** Lookup a value in from the global environment. * * \param sym The key to look for in the environment diff --git a/include/heap.h b/include/heap.h index b1ed3695..8e51ff29 100644 --- a/include/heap.h +++ b/include/heap.h @@ -303,6 +303,11 @@ lbm_uint lbm_heap_size_bytes(void); * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full. */ lbm_value lbm_heap_allocate_cell(lbm_type type); +/** Allocate a list of n heap-cells. + * \param n The number of heap-cells to allocate. + * \return A list of heap-cells of Memory error if unable to allocate. + */ +lbm_value lbm_heap_allocate_list(unsigned int n); /** Decode an lbm_value representing a string into a C string * * \param val Value diff --git a/include/lbm_version.h b/include/lbm_version.h index c4baaca5..70da8c3f 100644 --- a/include/lbm_version.h +++ b/include/lbm_version.h @@ -33,6 +33,10 @@ extern "C" { /*! \page changelog Changelog +Dec 11: Version 0.7.1 + - Changes to heap_allocate_cell for readability and perhaps performance. + - Added heap_allocate_list for allocation of multiple cells at once. + Nov 9: Version 0.7.1 - Bugfix: string literal lengths. - not-eq and != added. diff --git a/src/env.c b/src/env.c index 98c0329f..45b0671c 100644 --- a/src/env.c +++ b/src/env.c @@ -37,29 +37,6 @@ lbm_value lbm_get_env(void) { return env_global; } -// Copies just the skeleton structure of an environment -// The new "copy" will have pointers to the original key-val bindings. -lbm_value lbm_env_copy_shallow(lbm_value env) { - - lbm_value res = ENC_SYM_NIL; - lbm_value curr = env; - - while (lbm_type_of(curr) == LBM_TYPE_CONS) { - lbm_value key = lbm_car(lbm_car(curr)); - if (lbm_dec_sym(key) != SYM_NIL) { - res = lbm_cons(lbm_car(curr), res); - - // Check for "out of memory" - if (lbm_type_of(res) == LBM_TYPE_SYMBOL && - lbm_dec_sym(res) == SYM_MERROR) { - return res; - } - } - curr = lbm_cdr(curr); - } - return res; -} - // A less safe version of lookup. It should be fine unless env is corrupted. bool lbm_env_lookup_b(lbm_value *res, lbm_value sym, lbm_value env) { diff --git a/src/eval_cps.c b/src/eval_cps.c index 6ddb614c..95ebdcfc 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -187,7 +187,7 @@ typedef struct { } eval_context_queue_t; -/* Callbacks and task queue */ +/* Process queues */ static eval_context_queue_t blocked = {NULL, NULL}; static eval_context_queue_t sleeping = {NULL, NULL}; static eval_context_queue_t queue = {NULL, NULL}; @@ -587,7 +587,7 @@ int lbm_set_error_reason(char *error_str) { return r; } -// Not possible to CONS_WITH_GC ins error_ctx_base (potential loop) +// Not possible to CONS_WITH_GC in error_ctx_base (potential loop) static void error_ctx_base(lbm_value err_val, unsigned int row, unsigned int column) { ctx_running->r = err_val; @@ -2461,6 +2461,7 @@ static void read_process_token(eval_context_t *ctx, lbm_value stream, lbm_value ctx->app_cont = true; } else { /* Parsing failed */ + lbm_channel_reader_close(str); lbm_set_error_reason((char*)lbm_error_str_parse_eof); read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); done_reading(ctx->id); @@ -2540,6 +2541,12 @@ static void cont_read_start_array(eval_context_t *ctx) { lbm_pop(&ctx->K, &stream); + lbm_char_channel_t *str = lbm_dec_channel(stream); + if (str == NULL || str->state == NULL) { + error_ctx(ENC_SYM_FATAL_ERROR); + return; + } + lbm_uint num_free = lbm_memory_longest_free(); lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9); if (initial_size == 0) { @@ -2547,6 +2554,7 @@ static void cont_read_start_array(eval_context_t *ctx) { num_free = lbm_memory_longest_free(); initial_size = (lbm_uint)((float)num_free * 0.9); if (initial_size == 0) { + lbm_channel_reader_close(str); error_ctx(ENC_SYM_MERROR); return; } @@ -2565,6 +2573,7 @@ static void cont_read_start_array(eval_context_t *ctx) { case ENC_SYM_TYPE_FLOAT: t = LBM_TYPE_FLOAT; break; case ENC_SYM_TYPE_CHAR: t = LBM_TYPE_CHAR; break; default: + lbm_channel_reader_close(str); error_ctx(ENC_SYM_TERROR); return; } @@ -2575,6 +2584,7 @@ static void cont_read_start_array(eval_context_t *ctx) { lbm_value array; if (!lbm_heap_allocate_array(&array, initial_size, t)) { + lbm_channel_reader_close(str); error_ctx(ENC_SYM_FATAL_ERROR); return; } @@ -2586,6 +2596,7 @@ static void cont_read_start_array(eval_context_t *ctx) { lbm_value array; initial_size = sizeof(lbm_uint) * initial_size; if (!lbm_heap_allocate_array(&array, initial_size, LBM_TYPE_CHAR)) { + lbm_channel_reader_close(str); error_ctx(ENC_SYM_FATAL_ERROR); return; } @@ -2594,13 +2605,8 @@ static void cont_read_start_array(eval_context_t *ctx) { CHECK_STACK(lbm_push(&ctx->K, READ_APPEND_ARRAY)); ctx->app_cont = true; } else { - lbm_char_channel_t *str = lbm_dec_channel(stream); - if (str == NULL) { - error_ctx(ENC_SYM_FATAL_ERROR); - } else { - lbm_channel_reader_close(str); - read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); - } + lbm_channel_reader_close(str); + read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); } } @@ -2678,6 +2684,12 @@ static void cont_read_append_continue(eval_context_t *ctx) { lbm_value last_cell = sptr[1]; lbm_value stream = sptr[2]; + lbm_char_channel_t *str = lbm_dec_channel(stream); + if (str == NULL || str->state == NULL) { + error_ctx(ENC_SYM_FATAL_ERROR); + return; + } + if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) { switch(lbm_dec_sym(ctx->r)) { @@ -2699,8 +2711,12 @@ static void cont_read_append_continue(eval_context_t *ctx) { return; } } - lbm_value new_cell; - CONS_WITH_GC(new_cell, ctx->r, ENC_SYM_NIL, ENC_SYM_NIL); + lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL); + if (lbm_is_symbol_merror(new_cell)) { + lbm_channel_reader_close(str); + return; + } + if (lbm_type_of(last_cell) == LBM_TYPE_CONS) { lbm_set_cdr(last_cell, new_cell); last_cell = new_cell; @@ -2731,6 +2747,7 @@ static void cont_read_expect_closepar(eval_context_t *ctx) { ctx->r = res; ctx->app_cont = true; } else { + lbm_channel_reader_close(str); lbm_set_error_reason((char*)lbm_error_str_parse_close); read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); done_reading(ctx->id); @@ -2760,6 +2777,7 @@ static void cont_read_dot_terminate(eval_context_t *ctx) { if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL && (lbm_dec_sym(ctx->r) == SYM_CLOSEPAR || lbm_dec_sym(ctx->r) == SYM_DOT)) { + lbm_channel_reader_close(str); lbm_set_error_reason((char*)lbm_error_str_parse_dot); read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); done_reading(ctx->id); @@ -2775,6 +2793,7 @@ static void cont_read_dot_terminate(eval_context_t *ctx) { CHECK_STACK(lbm_push_2(&ctx->K, stream, READ_NEXT_TOKEN)); ctx->app_cont = true; } else { + lbm_channel_reader_close(str); lbm_set_error_reason((char*)lbm_error_str_parse_dot); read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); done_reading(ctx->id); @@ -2801,6 +2820,7 @@ static void cont_read_done(eval_context_t *ctx) { see if the tokenizer feels it is done here. */ lbm_channel_reader_close(str); if (tok != ENC_SYM_TOKENIZER_DONE) { + lbm_channel_reader_close(str); lbm_set_error_reason((char*)lbm_error_str_parse_eof); read_error_ctx(lbm_channel_row(str), lbm_channel_column(str)); } else { diff --git a/src/fundamental.c b/src/fundamental.c index 4ed38946..32a06f8f 100644 --- a/src/fundamental.c +++ b/src/fundamental.c @@ -913,11 +913,13 @@ static lbm_value fundamental_cdr(lbm_value *args, lbm_uint nargs, eval_context_t static lbm_value fundamental_list(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { (void) ctx; - lbm_value result = ENC_SYM_NIL; - for (lbm_uint i = 1; i <= nargs; i ++) { - result = lbm_cons(args[nargs-i], result); - if (lbm_type_of(result) == LBM_TYPE_SYMBOL) - break; + lbm_value result = lbm_heap_allocate_list(nargs); + if (lbm_is_cons(result)) { + lbm_value curr = result; + for (lbm_uint i = 0; i < nargs; i ++) { + lbm_set_car(curr, args[i]); + curr = lbm_cdr(curr); + } } return result; } @@ -1489,25 +1491,31 @@ static lbm_value fundamental_range(lbm_value *args, lbm_uint nargs, eval_context return result; } + int num; if (end == start) return ENC_SYM_NIL; else if (end < start) { - int32_t tmp = end; - end = start; - start = tmp; rev = true; + num = start - end; + } else { + num = end - start; } - int num = end - start; - - if ((unsigned int)num > lbm_heap_num_free()) { - return ENC_SYM_MERROR; + lbm_value r_list = lbm_heap_allocate_list((unsigned int)num); + if (lbm_is_cons(r_list)) { + lbm_value curr = r_list; + if (rev) { + for (int i = start-1; i >= end; i --) { + lbm_set_car(curr, lbm_enc_i(i)); + curr = lbm_cdr(curr); + } + } else { + for (int i = start; i < end; i ++) { + lbm_set_car(curr, lbm_enc_i(i)); + curr = lbm_cdr(curr); + } + } } - - lbm_value r_list = ENC_SYM_NIL; - for (int i = end - 1; i >= start; i --) { - r_list = lbm_cons(lbm_enc_i(i), r_list); - } - return rev ? lbm_list_destructive_reverse(r_list) : r_list; + return r_list; } const fundamental_fun fundamental_table[] = diff --git a/src/heap.c b/src/heap.c index 4709dfdb..76d83f17 100644 --- a/src/heap.c +++ b/src/heap.c @@ -517,38 +517,53 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) { lbm_value res; - if (!lbm_is_ptr(lbm_heap_state.freelist)) { - // Free list not a ptr (should be Symbol NIL) - if ((lbm_type_of(lbm_heap_state.freelist) == LBM_TYPE_SYMBOL) && - (lbm_dec_sym(lbm_heap_state.freelist) == SYM_NIL)) { - // all is as it should be (but no free cells) - return ENC_SYM_MERROR; - } else { - // something is most likely very wrong - return ENC_SYM_FATAL_ERROR; - } - } - // it is a ptr replace freelist with cdr of freelist; res = lbm_heap_state.freelist; - if (lbm_type_of(res) != LBM_TYPE_CONS) { + if (lbm_type_of(res) == LBM_TYPE_CONS) { + lbm_heap_state.freelist = lbm_cdr(lbm_heap_state.freelist); + + lbm_heap_state.num_alloc++; + + // set some ok initial values (nil . nil) + lbm_ref_cell(res)->car = ENC_SYM_NIL; + lbm_ref_cell(res)->cdr = ENC_SYM_NIL; + + res = res | ptr_type; + return res; + } + else if ((lbm_type_of(lbm_heap_state.freelist) == LBM_TYPE_SYMBOL) && + (lbm_dec_sym(lbm_heap_state.freelist) == SYM_NIL)) { + // all is as it should be (but no free cells) + return ENC_SYM_MERROR; + } + else { return ENC_SYM_FATAL_ERROR; } +} - lbm_heap_state.freelist = lbm_cdr(lbm_heap_state.freelist); +lbm_value lbm_heap_allocate_list(unsigned int n) { + if (n == 0) return ENC_SYM_NIL; + if (lbm_heap_num_free() < n) return ENC_SYM_MERROR; - lbm_heap_state.num_alloc++; + lbm_value res = lbm_heap_state.freelist; + if (lbm_type_of(res) == LBM_TYPE_CONS) { - // set some ok initial values (nil . nil) - lbm_ref_cell(res)->car = ENC_SYM_NIL; - lbm_ref_cell(res)->cdr = ENC_SYM_NIL; - - // clear GC bit on allocated cell - clr_gc_mark(lbm_ref_cell(res)); - - res = res | ptr_type; - return res; + lbm_value curr = res; + unsigned int count = 0; + while (lbm_type_of(curr) == LBM_TYPE_CONS && count < (n - 1)) { + lbm_ref_cell(curr)->car = ENC_SYM_NIL; + curr = lbm_cdr(curr); + count ++; + } + lbm_set_car(curr, ENC_SYM_NIL); + lbm_heap_state.freelist = lbm_cdr(curr); + lbm_set_cdr(curr, ENC_SYM_NIL); + lbm_heap_state.num_alloc+=count; + return res; + } else { + return ENC_SYM_FATAL_ERROR; + } } lbm_uint lbm_heap_num_allocated(void) { @@ -705,7 +720,7 @@ int lbm_gc_sweep_phase(void) { default: break; } - } + } // create pointer to use as new freelist lbm_uint addr = lbm_enc_cons_ptr(i); diff --git a/src/lbm_memory.c b/src/lbm_memory.c index e195bd70..4540f944 100644 --- a/src/lbm_memory.c +++ b/src/lbm_memory.c @@ -83,9 +83,9 @@ static inline lbm_uint address_to_bitmap_ix(lbm_uint *ptr) { } lbm_int lbm_memory_address_to_ix(lbm_uint *ptr) { - /* TODO: assuming that that index + /* TODO: assuming that index will have more then enough room in the - positive halv of a 28bit integer */ + positive half of a 28bit integer */ return (lbm_int)address_to_bitmap_ix(ptr); } diff --git a/tests/test_list_5.lisp b/tests/test_list_5.lisp new file mode 100644 index 00000000..d81d1530 --- /dev/null +++ b/tests/test_list_5.lisp @@ -0,0 +1 @@ +(eq (list) nil) diff --git a/tests/test_range_5.lisp b/tests/test_range_5.lisp new file mode 100644 index 00000000..f792d3bd --- /dev/null +++ b/tests/test_range_5.lisp @@ -0,0 +1,8 @@ +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(eq (range 10) '(0 1 2 3 4 5 6 7 8 9)) diff --git a/tests/test_range_6.lisp b/tests/test_range_6.lisp new file mode 100644 index 00000000..c5a7f790 --- /dev/null +++ b/tests/test_range_6.lisp @@ -0,0 +1,15 @@ +;; Force gc about twice in 512 element heap +;; and once in 1024 +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(eq (range 10) '(0 1 2 3 4 5 6 7 8 9)) diff --git a/tests/test_range_7.lisp b/tests/test_range_7.lisp new file mode 100644 index 00000000..735247f2 --- /dev/null +++ b/tests/test_range_7.lisp @@ -0,0 +1,27 @@ +;; Force gc about four times in 512 element heap +;; and twice in 1024 +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(range 100) +(eq (range 10) '(0 1 2 3 4 5 6 7 8 9)) diff --git a/tests/test_range_8.lisp b/tests/test_range_8.lisp new file mode 100644 index 00000000..4bc608a6 --- /dev/null +++ b/tests/test_range_8.lisp @@ -0,0 +1,8 @@ + +(defun f (n) (if (= n 0) + 0 + (progn (range 100) (f (- n 1))))) + +;; Trigger gc lots of times. +(f 100000) +(eq (range 10) '(0 1 2 3 4 5 6 7 8 9))