From 351ca5bd17e935db71c48bcf66fa7aec3ed56dbb Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 4 Feb 2026 22:57:10 +0000 Subject: [PATCH 1/3] Work on reducing allocation leaks in read_number(). This is now improved, but not yet satisfactory. --- lisp/fact.lisp | 4 +- lisp/slurp.lisp | 2 +- src/arith/integer.c | 1 + src/init.c | 15 +- src/io/read.c | 33 ++-- state-of-play.md | 159 ++++++++++++++++++ .../allocation-tests/allocation-tester.sh | 22 +++ .../allocation-tests/allocation-tests.csv | 28 +++ unit-tests/allocation-tests/test-forms | 28 +++ 9 files changed, 275 insertions(+), 17 deletions(-) create mode 100755 unit-tests/allocation-tests/allocation-tester.sh create mode 100644 unit-tests/allocation-tests/allocation-tests.csv create mode 100644 unit-tests/allocation-tests/test-forms diff --git a/lisp/fact.lisp b/lisp/fact.lisp index 17a7288..1ad4c19 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -4,4 +4,6 @@ (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) -(fact 1000) +; (fact 1000) + + diff --git a/lisp/slurp.lisp b/lisp/slurp.lisp index e927bcb..2223bbd 100644 --- a/lisp/slurp.lisp +++ b/lisp/slurp.lisp @@ -1 +1 @@ -(slurp (set! f (open "http://www.journeyman.cc/"))) +(slurp (open "http://www.journeyman.cc/")) diff --git a/src/arith/integer.c b/src/arith/integer.c index 3bb58bd..41c46ef 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -86,6 +86,7 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; cell->payload.integer.more = more; + inc_ref(result); } debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); diff --git a/src/init.c b/src/init.c index 4443469..2d0d2d2 100644 --- a/src/init.c +++ b/src/init.c @@ -28,6 +28,7 @@ #include "memory/hashmap.h" #include "ops/intern.h" #include "io/io.h" +#include "io/fopen.h" #include "ops/lispops.h" #include "ops/meta.h" #include "arith/peano.h" @@ -124,6 +125,7 @@ int main( int argc, char *argv[] ) { int option; bool dump_at_end = false; bool show_prompt = false; + char * infilename = NULL; setlocale( LC_ALL, "" ); if ( io_init( ) != 0 ) { @@ -131,7 +133,7 @@ int main( int argc, char *argv[] ) { exit( 1 ); } - while ( ( option = getopt( argc, argv, "phdv:" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "phdv:i:" ) ) != -1 ) { switch ( option ) { case 'd': dump_at_end = true; @@ -141,6 +143,9 @@ int main( int argc, char *argv[] ) { print_options( stdout ); exit( 0 ); break; + case 'i' : + infilename = optarg; + break; case 'p': show_prompt = true; break; @@ -191,8 +196,12 @@ int main( int argc, char *argv[] ) { fwide( stdout, 1 ); fwide( stderr, 1 ); fwide( sink->handle.file, 1 ); - bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ), - make_cons( make_cons + + FILE *infile = infilename == NULL ? stdin : fopen( infilename, "r"); + + + bind_value( L"*in*", make_read_stream( file_to_url_file(infile), + make_cons( make_cons ( c_string_to_lisp_keyword ( L"url" ), c_string_to_lisp_string diff --git a/src/io/read.c b/src/io/read.c index 50f469e..13b0942 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -330,17 +330,20 @@ struct cons_pointer read_number( struct stack_frame *frame, debug_print( L"read_number: ratio slash seen\n", DEBUG_IO ); dividend = result; - - result = make_integer( 0, NIL ); } break; case LCOMMA: // silently ignore comma. break; default: - result = add_integers( multiply_integers( result, base ), - make_integer( ( int ) c - ( int ) '0', - NIL ) ); + { + struct cons_pointer digit = make_integer( ( int ) c - ( int ) '0', + NIL ); + struct cons_pointer new_result = add_integers( multiply_integers( result, base ), + digit ); + dec_ref( result); + dec_ref( digit); + result = new_result; debug_printf( DEBUG_IO, L"read_number: added character %c, result now ", @@ -351,6 +354,7 @@ struct cons_pointer read_number( struct stack_frame *frame, if ( seen_period ) { places_of_decimals++; } + } } } @@ -360,13 +364,14 @@ struct cons_pointer read_number( struct stack_frame *frame, url_ungetwc( c, input ); if ( seen_period ) { - debug_print( L"read_number: converting result to real\n", DEBUG_IO ); - struct cons_pointer div = make_ratio( result, - make_integer( powl - ( to_long_double - ( base ), + struct cons_pointer divisor = make_integer( powl( to_long_double( base ), places_of_decimals ), - NIL ) ); + NIL ); + debug_print( L"read_number: converting result to real\n", DEBUG_IO ); + + struct cons_pointer div = make_ratio( result, + divisor); + dec_ref( divisor); inc_ref( div ); result = make_real( to_long_double( div ) ); @@ -378,15 +383,19 @@ struct cons_pointer read_number( struct stack_frame *frame, } if ( neg ) { + struct cons_pointer negt = negative( result ); debug_print( L"read_number: converting result to negative\n", DEBUG_IO ); - result = negative( result ); + dec_ref( result); + result = negt; } debug_print( L"read_number returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + dec_ref( base); + return result; } diff --git a/state-of-play.md b/state-of-play.md index 0855715..18fca93 100644 --- a/state-of-play.md +++ b/state-of-play.md @@ -1,5 +1,162 @@ # State of Play +## 20260204 + +### Testing what is leaking memory + +#### Analysis + +If you just start up and immediately abort the current build of psse, you get: + +> Allocation summary: allocated 19986; deallocated 245; not deallocated 19741. + +Allocation summaries from the current unit tests give the following ranges of values: + +| | Min | Max | | +| --------------- | ----- | ----- | ---- | +| Allocated | 19991 | 39009 | | +| Deallocated | 238 | 1952 | | +| Not deallocated | 19741 | 37057 | | + +The numbers go up broadly in sinc with one another — that is to say, broadly, as the number allocated rises, so do both the numbers deallocated and the numbers not deallocated. But not exactly. + +#### Strategy: what doesn't get cleaned up? + +Write a test wrapper which reads a file of forms, one per line, from standard input, and passes each in turn to a fresh invocation of psse, reporting the form and the allocation summary. + +```bash +#1/bin/bash + +while IFS= read -r form; do + allocation=`echo ${form} | ../../target/psse 2>&1 | grep Allocation` + echo "* ${allocation}: ${form}" +done +``` + +So, from this: + +* Allocation summary: allocated 19986; deallocated 245; not deallocated 19741.: +* Allocation summary: allocated 19990; deallocated 249; not deallocated 19741.: () +* Allocation summary: allocated 20019; deallocated 253; not deallocated 19766.: nil + +Allocating an empty list allocates four additional cells, all of which are deallocated. Allocating 'nil' allocates a further **29** cells, 25 of which are not deallocated. WTF? + +Following further work I have this, showing the difference added to the base case of cells allocated, cells deallocated, and, most critically, cells not deallocated. + +From this we see that reading and printing `nil` allocates an additional 33 cells, of which eight are not cleaned up. That's startling, and worrying. + +But the next row shows us that reading and printing an empty list costs only four cells, each of which is cleaned up. Further down the table we see that an empty map is also correctly cleaned up. Where we're leaking memory is in reading (or printing, although I doubt this) symbols, either atoms, numbers, or keywords (I haven't yet tried strings, but I expect they're similar.) + +| **Case** | **Delta Allocated** | **Delta Deallocated** | **Delta Not Deallocated** | +| --------------------------------- | ------------------- | --------------------- | ------------------------- | +| **Basecase** | 0 | 0 | 0 | +| **nil** | 33 | 8 | 25 | +| **()** | 4 | 4 | 0 | +| **(quote ())** | 39 | 2 | 37 | +| **(list )** | 37 | 12 | 25 | +| **(list 1)** | 47 | 14 | 33 | +| **(list 1 1)** | 57 | 16 | 41 | +| **(list 1 1 1)** | 67 | 18 | 49 | +| **(list 1 2 3)** | 67 | 18 | 49 | +| **(+)** | 36 | 10 | 26 | +| **(+ 1)** | 44 | 12 | 32 | +| **(+ 1 1)** | 53 | 14 | 39 | +| **(+ 1 1 1)** | 62 | 16 | 46 | +| **(+ 1 2 3)** | 62 | 16 | 46 | +| **(list 'a 'a 'a)** | 151 | 33 | 118 | +| **(list 'a 'b 'c)** | 151 | 33 | 118 | +| **(list :a :b :c)** | 121 | 15 | 106 | +| **(list :alpha :bravo :charlie)** | 485 | 15 | 470 | +| **{}** | 6 | 6 | 0 | +| **{:z 0}** | 43 | 10 | 33 | +| **{:zero 0}** | 121 | 10 | 111 | +| **{:z 0 :o 1}** | 80 | 11 | 69 | +| **{:zero 0 :one 1}** | 210 | 14 | 196 | +| **{:z 0 :o 1 :t 2}** | 117 | 12 | 105 | + +Looking at the entries, we see that + +1. each number read costs ten allocations, of which only two are successfully deallocated; +2. the symbol `list` costs 33 cells, of which 25 are not deallocated, whereas the symbol `+` costs only one cell fewer, and an additional cell is not deallocated. So it doesn't seem that cell allocation scales with the length of the symbol; +3. Keyword allocation does scale with the length of the keyword, apparently, since `(list :a :b :c)` allocates 121 and deallocates 15, while `(list :alpha :bravo :charlie)` allocates 485 and deallocates the same 15; +4. The fact that both those two deallocate 15, and a addition of three numbers `(+ 1 2 3)` or `(+ 1 1 1)` deallocates 16 suggest to me that the list structure is being fully reclaimed but atoms are not being. +5. The atom `'a` costs more to read than the keyword `:a` because the reader macro is expanding `'a` to `(quote a)` behind the scenes. + +### The integer allocation bug + +Looking at what happens when we read a single digit number, we get the following: + +``` +2 +Entering make_integer +Allocated cell of type 'INTR' at 19, 507 +make_integer: returning + INTR (1381256777) at page 19, offset 507 count 0 + Integer cell: value 0, count 0 +Entering make_integer +Allocated cell of type 'INTR' at 19, 508 +make_integer: returning + INTR (1381256777) at page 19, offset 508 count 0 + Integer cell: value 10, count 0 +Entering make_integer +Allocated cell of type 'INTR' at 19, 509 +make_integer: returning + INTR (1381256777) at page 19, offset 509 count 0 + Integer cell: value 2, count 0 +Entering make_integer +Allocated cell of type 'INTR' at 19, 510 +make_integer: returning + INTR (1381256777) at page 19, offset 510 count 0 + Integer cell: value 0, count 0 +Entering make_integer +Allocated cell of type 'INTR' at 19, 506 +make_integer: returning + INTR (1381256777) at page 19, offset 506 count 0 + Integer cell: value 0, count 0 +Entering make_integer +Allocated cell of type 'INTR' at 19, 505 +make_integer: returning + INTR (1381256777) at page 19, offset 505 count 0 + Integer cell: value 0, count 0 +Entering make_integer +Allocated cell of type 'INTR' at 19, 504 +make_integer: returning + INTR (1381256777) at page 19, offset 504 count 0 + Integer cell: value 0, count 0 + +Allocated cell of type 'STRG' at 19, 503 +Freeing cell STRG (1196577875) at page 19, offset 503 count 0 + String cell: character '2' (50) with hash 0; next at page 0 offset 0, count 0 + value: "2" +Freeing cell INTR (1381256777) at page 19, offset 504 count 0 + Integer cell: value 2, count 0 +2 +Allocated cell of type 'SYMB' at 19, 504 +Allocated cell of type 'SYMB' at 19, 503 +Allocated cell of type 'SYMB' at 19, 502 +Allocated cell of type 'SYMB' at 19, 501 +Freeing cell SYMB (1112365395) at page 19, offset 501 count 0 + Symbol cell: character '*' (42) with hash 485100; next at page 19 offset 502, count 0 + value: *in* +Freeing cell SYMB (1112365395) at page 19, offset 502 count 0 + Symbol cell: character 'i' (105) with hash 11550; next at page 19 offset 503, count 0 + value: in* +Freeing cell SYMB (1112365395) at page 19, offset 503 count 0 + Symbol cell: character 'n' (110) with hash 110; next at page 19 offset 504, count 0 + value: n* +Freeing cell SYMB (1112365395) at page 19, offset 504 count 0 + Symbol cell: character '*' (42) with hash 0; next at page 0 offset 0, count 0 + value: * +``` + +Many things are worrying here. + +1. The only thing being freed here is the symbol to which the read stream is bound — and I didn't see where that got allocated, but we shouldn't be allocating and tearing down a symbol for every read! This implies that when I create a string with `c_string_to_lisp_string`, I need to make damn sure that that string is deallocated as soon as I'm done with it — and wherever I'm dealing with symbols which will be referred to repeatedly in `C` code, I need either + 1. to bind a global on the C side of the world, which will become messy; + 2. or else write a hash function which returns, for a `C` string, the same value that the standard hashing function will return for the lexically equivalent `Lisp` string, so that I can search hashmap structures from C without having to allocate and deallocate a fresh copy of the `Lisp` string; + 3. In reading numbers, I'm generating a fresh instance of `Lisp zero` and `Lisp ten`, each time `read_integer` is called, and I'm not deallocating them. + 4. I am correctly deallocating the number I did read, though! + ## 20260203 I'm consciously avoiding the bignum issue for now. My current thinking is that if the C code only handles 64 bit integers, and bignums have to be done in Lisp code, that's perfectly fine with me. @@ -53,6 +210,8 @@ In other words, all failures are in bignum arithmetic **except** that I still ha ### Zig +I've also experimented with autotranslating my C into Zig, but this failed. Although I don't think C is the right language for implementing my base Lisp in, it's what I've got; and until I can get some form of autotranslate to bootstrap me into some more modern systems language, I think I need to stick with it. + ## 20250704 Right, I'm getting second and subsequent integer cells with negative values, which should not happen. This is probably the cause of (at least some of) the bignum problems. I need to find out why. This is (probably) fixable. diff --git a/unit-tests/allocation-tests/allocation-tester.sh b/unit-tests/allocation-tests/allocation-tester.sh new file mode 100755 index 0000000..5605075 --- /dev/null +++ b/unit-tests/allocation-tests/allocation-tester.sh @@ -0,0 +1,22 @@ +#1/bin/bash + +echo "Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated" +basecase=`echo '' | ../../target/psse 2>&1 | grep Allocation | tr -d '[:punct:]'` +bca=`echo ${basecase} | awk '{print $4}'` +bcd=`echo ${basecase} | awk '{print $6}'` +bcn=`echo ${basecase} | awk '{print $9}'` + +echo "\"Basecase\", \"${basecase}\", ${bca}, ${bcd}, ${bcn}" + +while IFS= read -r form; do + allocation=`echo ${form} | ../../target/psse 2>&1 | grep Allocation | tr -d '[:punct:]'` + tca=`echo ${allocation} | awk '{print $4}'` + tcd=`echo ${allocation} | awk '{print $6}'` + tcn=`echo ${allocation} | awk '{print $9}'` + + dca=`echo "${tca} - ${bca}" | bc` + dcd=`echo "${tcd} - ${bcd}" | bc` + dcn=`echo "${tcn} - ${bcn}" | bc` + + echo "\"${form}\", \"${allocation}\", ${tca}, ${tcd}, ${tcn}, ${dca}, ${dcd}, ${dcn}" +done diff --git a/unit-tests/allocation-tests/allocation-tests.csv b/unit-tests/allocation-tests/allocation-tests.csv new file mode 100644 index 0000000..902577b --- /dev/null +++ b/unit-tests/allocation-tests/allocation-tests.csv @@ -0,0 +1,28 @@ +Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated +"Basecase", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741 +"", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741, 0, 0, 0 +"nil", "Allocation summary allocated 20019 deallocated 253 not deallocated 19766", 20019, 253, 19766, 33, 8, 25 +"()", "Allocation summary allocated 19990 deallocated 249 not deallocated 19741", 19990, 249, 19741, 4, 4, 0 +"(quote ())", "Allocation summary allocated 20025 deallocated 247 not deallocated 19778", 20025, 247, 19778, 39, 2, 37 +"(list)", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25 +"(list )", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25 +"(list 1)", "Allocation summary allocated 20033 deallocated 259 not deallocated 19774", 20033, 259, 19774, 47, 14, 33 +"(list 1 1)", "Allocation summary allocated 20043 deallocated 261 not deallocated 19782", 20043, 261, 19782, 57, 16, 41 +"(list 1 1 1)", "Allocation summary allocated 20053 deallocated 263 not deallocated 19790", 20053, 263, 19790, 67, 18, 49 +"(list 1 2 3)", "Allocation summary allocated 20053 deallocated 263 not deallocated 19790", 20053, 263, 19790, 67, 18, 49 +"(+)", "Allocation summary allocated 20022 deallocated 255 not deallocated 19767", 20022, 255, 19767, 36, 10, 26 +"(+ 1)", "Allocation summary allocated 20030 deallocated 257 not deallocated 19773", 20030, 257, 19773, 44, 12, 32 +"(+ 1 1)", "Allocation summary allocated 20039 deallocated 259 not deallocated 19780", 20039, 259, 19780, 53, 14, 39 +"(+ 1 1 1)", "Allocation summary allocated 20048 deallocated 261 not deallocated 19787", 20048, 261, 19787, 62, 16, 46 +"(+ 1 2 3)", "Allocation summary allocated 20048 deallocated 261 not deallocated 19787", 20048, 261, 19787, 62, 16, 46 +"(list 'a 'a 'a)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118 +"(list 'a 'b 'c)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118 +"(list :a :b :c)", "Allocation summary allocated 20107 deallocated 260 not deallocated 19847", 20107, 260, 19847, 121, 15, 106 +"(list :alpha :bravo :charlie)", "Allocation summary allocated 20471 deallocated 260 not deallocated 20211", 20471, 260, 20211, 485, 15, 470 +"{}", "Allocation summary allocated 19992 deallocated 251 not deallocated 19741", 19992, 251, 19741, 6, 6, 0 +"{:z 0}", "Allocation summary allocated 20029 deallocated 255 not deallocated 19774", 20029, 255, 19774, 43, 10, 33 +"{:zero 0}", "Allocation summary allocated 20107 deallocated 255 not deallocated 19852", 20107, 255, 19852, 121, 10, 111 +"{:z 0 :o 1}", "Allocation summary allocated 20066 deallocated 256 not deallocated 19810", 20066, 256, 19810, 80, 11, 69 +"{:zero 0 :one 1}", "Allocation summary allocated 20196 deallocated 259 not deallocated 19937", 20196, 259, 19937, 210, 14, 196 +"{:z 0 :o 1 :t 2}", "Allocation summary allocated 20103 deallocated 257 not deallocated 19846", 20103, 257, 19846, 117, 12, 105 +"{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9}", "Allocation summary allocated 21164 deallocated 286 not deallocated 20878", 21164, 286, 20878, 1178, 41, 1137 diff --git a/unit-tests/allocation-tests/test-forms b/unit-tests/allocation-tests/test-forms new file mode 100644 index 0000000..6f63893 --- /dev/null +++ b/unit-tests/allocation-tests/test-forms @@ -0,0 +1,28 @@ + +nil +() +(quote ()) +(list) +(list ) +(list 1) +(list 1 1) +(list 1 1 1) +(list 1 2 3) +(+) +(+ 1) +(+ 1 1) +(+ 1 1 1) +(+ 1 2 3) +(list 'a 'a 'a) +(list 'a 'b 'c) +(list :a :b :c) +(list :aa :bb :cc) +(list :aaa :bbb :ccc) +(list :alpha :bravo :charlie) +{} +{:z 0} +{:zero 0} +{:z 0 :o 1} +{:zero 0 :one 1} +{:z 0 :o 1 :t 2} +{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9} From 004ff6737c3def1f21cebb855b9f058379b6aa0f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 12 Feb 2026 10:17:11 +0000 Subject: [PATCH 2/3] feature-2: allocating cells with count = 1; 7 unit tests (all bignums) fail. --- src/arith/integer.c | 172 ++++++++++++++++++++++++++++++------------ src/arith/integer.h | 7 ++ src/arith/peano.h | 3 +- src/arith/ratio.c | 38 +++++----- src/init.c | 25 +++--- src/io/io.c | 19 ++++- src/io/io.h | 8 +- src/io/read.c | 38 ++++------ src/memory/conspage.c | 4 +- src/ops/intern.c | 9 +-- 10 files changed, 209 insertions(+), 114 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 41c46ef..e9d9b79 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -19,12 +19,13 @@ #include #include +#include "arith/integer.h" +#include "arith/peano.h" +#include "debug.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" -#include "debug.h" #include "ops/equal.h" #include "ops/lispops.h" -#include "arith/peano.h" /** * hexadecimal digits for printing numbers. @@ -34,19 +35,33 @@ const char *hex_digits = "0123456789ABCDEF"; /* * Doctrine from here on in is that ALL integers are bignums, it's just * that integers less than 61 bits are bignums of one cell only. + * that integers less than 61 bits are bignums of one cell only. + * TODO: why do I not have confidence to make this 64 bits? */ + /* + * A small_int_cache array of pointers to the integers 0...23, + * used only by functions `acquire_integer(int64) => cons_pointer` and + * `release_integer(cons_pointer) => NULL` which, if the value desired is + * in the cache, supplies it from the cache, and, otherwise, calls + * make_integer() and dec_ref() respectively. + */ + +#define SMALL_INT_LIMIT 24 +bool small_int_cache_initialised = false; +struct cons_pointer small_int_cache[SMALL_INT_LIMIT]; + /** - * Low level integer arithmetic, do not use elsewhere. - * - * @param c a pointer to a cell, assumed to be an integer cell; - * @param op a character representing the operation: expectedto be either - * '+' or '*'; behaviour with other values is undefined. - * @param is_first_cell true if this is the first cell in a bignum - * chain, else false. - * \see multiply_integers - * \see add_integers - */ + * Low level integer arithmetic, do not use elsewhere. + * + * @param c a pointer to a cell, assumed to be an integer cell; + * @param op a character representing the operation: expectedto be either + * '+' or '*'; behaviour with other values is undefined. + * @param is_first_cell true if this is the first cell in a bignum + * chain, else false. + * \see multiply_integers + * \see add_integers + */ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; @@ -86,7 +101,6 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; cell->payload.integer.more = more; - inc_ref(result); } debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); @@ -95,11 +109,74 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { } /** - * Overwrite the value field of the integer indicated by `new` with + * @brief Supply small valued integers from the small integer cache, if available. + * + * The pattern here is intended to be that, at least within this file, instead of + * calling make_integer when an integer is required and dec_ref when it's no longer + * required, we call acquire_integer and release_integer respectively, in order to + * reduce allocation churn. + * + * In the initial implementation, acquire_integer supplies the integer from the + * small integer cache if available, else calls make_integer. Later, more + * sophisticated caching of integers which are currently in play may be enabled. + * + * @param value the value of the integer desired. + * @param more if this value is a bignum, the rest (less significant bits) of the + * value. + * @return struct cons_pointer a pointer to the integer acquired. + */ +struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) { + struct cons_pointer result; + + if ( !nilp( more) || value >= SMALL_INT_LIMIT) { + debug_print( L"acquire_integer passing to make_integer (too large)\n", DEBUG_ALLOC ); + result = make_integer( value, more); + } else { + if ( !small_int_cache_initialised) { + for (int64_t i = 0; i < SMALL_INT_LIMIT; i++) { + small_int_cache[i] = make_integer( i, NIL); + pointer2cell(small_int_cache[i]).count = UINT32_MAX; // lock it in so it can't be GC'd + } + small_int_cache_initialised = true; + debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC ); + } + + debug_printf( DEBUG_ALLOC, L"acquire_integer: returning %" PRId64 "\n", value); + result = small_int_cache[value]; + } + return result; +} + +/** + * @brief if the value of p is less than the size of the small integer cache + * (and thus it was presumably supplied from there), suppress dec_ref. + * + * **NOTE THAT** at this stage it's still safe to dec_ref an arbitrary integer, + * because those in the cache are locked and can't be dec_refed. + * + * @param p a pointer, expected to be to an integer. + */ +void release_integer( struct cons_pointer p) { + struct cons_space_object o = pointer2cell( p); + if ( !integerp( p) || // what I've been passed isn't an integer; + !nilp( o.payload.integer.more) || // or it's a bignum; + o.payload.integer.value >= SMALL_INT_LIMIT || // or it's bigger than the small int cache limit; + !eq( p, small_int_cache[ o.payload.integer.value]) // or it's simply not the copy in the cache... + ) { dec_ref( p); } else { + debug_printf( DEBUG_ALLOC, L"release_integer: releasing %" PRId64 "\n", + o.payload.integer.value); + } +} + + +/** + * @brief Overwrite the value field of the integer indicated by `new` with * the least significant INTEGER_BITS bits of `val`, and return the - * more significant bits (if any) right-shifted by INTEGER_BITS places. - * Destructive, primitive, do not use in any context except primitive - * operations on integers. + * more significant bits (if any) right-shifted by INTEGER_BITS places. + * + * Destructive, primitive, DO NOT USE in any context except primitive + * operations on integers. The value passed as `new` MUST be constructed + * with `make_integer`, NOT acquired with `acquire_integer`. * * @param val the value to represent; * @param less_significant the less significant words of this bignum, if any, @@ -134,25 +211,6 @@ __int128_t int128_to_integer( __int128_t val, return carry; } -struct cons_pointer make_integer_128( __int128_t val, - struct cons_pointer less_significant ) { - struct cons_pointer result = NIL; - - do { - if ( MAX_INTEGER >= val ) { - result = make_integer( ( long int ) val, less_significant ); - } else { - less_significant = - make_integer( ( long int ) val & MAX_INTEGER, - less_significant ); - val = val * INT_CELL_BASE; - } - - } while ( nilp( result ) ); - - return result; -} - /** * Return a pointer to an integer representing the sum of the integers * pointed to by `a` and `b`. If either isn't an integer, will return nil. @@ -218,28 +276,38 @@ struct cons_pointer base_partial( int depth ) { struct cons_pointer result = NIL; for ( int i = 0; i < depth; i++ ) { - result = make_integer( 0, result ); + result = acquire_integer( 0, result ); } return result; } /** - * destructively modify this `partial` by appending this `digit`. + * @brief Return a copy of this `partial` with this `digit` appended. + * + * @param partial the more significant bits of a possible bignum. + * @param digit the less significant bits of that possible bignum. NOTE: the + * name `digit` is technically correct but possibly misleading, because the + * numbering system here is base INT_CELL_BASE, currently x0fffffffffffffffL */ -struct cons_pointer append_digit( struct cons_pointer partial, +struct cons_pointer append_cell( struct cons_pointer partial, struct cons_pointer digit ) { - struct cons_pointer c = partial; + struct cons_space_object cell = pointer2cell( partial); + // TODO: I should recursively copy the whole bignum chain, because + // we're still destructively modifying the end of it. + struct cons_pointer c = make_integer( cell.payload.integer.value, + cell.payload.integer.more); struct cons_pointer result = partial; - if ( nilp( partial ) ) { + if ( nilp( partial)) { result = digit; } else { + // find the last digit in the chain... while ( !nilp( pointer2cell( c ).payload.integer.more ) ) { c = pointer2cell( c ).payload.integer.more; } - ( &pointer2cell( c ) )->payload.integer.more = digit; + ( pointer2cell( c ) ).payload.integer.more = digit; } return result; } @@ -259,7 +327,7 @@ struct cons_pointer append_digit( struct cons_pointer partial, */ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer b ) { - struct cons_pointer result = make_integer( 0, NIL ); + struct cons_pointer result = acquire_integer( 0, NIL ); bool neg = is_negative( a ) != is_negative( b ); bool is_first_b = true; int i = 0; @@ -300,16 +368,18 @@ struct cons_pointer multiply_integers( struct cons_pointer a, /* if xj exceeds one digit, break it into the digit dj and * the carry */ carry = xj >> INTEGER_BIT_SHIFT; - struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL ); + struct cons_pointer dj = acquire_integer( xj & MAX_INTEGER, NIL ); - /* destructively modify ri by appending dj */ - ri = append_digit( ri, dj ); + replace_integer_p( ri, append_cell( ri, dj )); + // struct cons_pointer new_ri = append_cell( ri, dj ); + // release_integer( ri); + // ri = new_ri; } /* end for bj */ - /* if carry is not equal to zero, append it as a final digit + /* if carry is not equal to zero, append it as a final cell * to ri */ if ( carry != 0 ) { - ri = append_digit( ri, make_integer( carry, NIL ) ); + replace_integer_i( ri, carry) } /* add ri to result */ @@ -341,6 +411,9 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, } /** + * @brief return a string representation of this integer, which may be a + * bignum. + * * The general principle of printing a bignum is that you print the least * significant digit in whatever base you're dealing with, divide through * by the base, print the next, and carry on until you've none left. @@ -350,6 +423,9 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * object to the next. 64 bit integers don't align with decimal numbers, so * when we get to the last digit from one integer cell, we have potentially * to be looking to the next. H'mmmm. + * + * @param int_pointer cons_pointer to the integer to print, + * @param base the base to print it in. */ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ) { diff --git a/src/arith/integer.h b/src/arith/integer.h index 09a7a83..d0b4b71 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -14,8 +14,15 @@ #include #include +#define replace_integer_i(p,i) {struct cons_pointer __p = acquire_integer(i,NIL); release_integer(p); p = __p;} +#define replace_integer_p(p,q) {struct cons_pointer __p = p; release_integer( p); p = q;} + struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); +struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ); + +void release_integer( struct cons_pointer p); + struct cons_pointer add_integers( struct cons_pointer a, struct cons_pointer b ); diff --git a/src/arith/peano.h b/src/arith/peano.h index 95c5013..5e83f0c 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -7,11 +7,12 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "consspaceobject.h" #ifndef PEANO_H #define PEANO_H +#include "memory/consspaceobject.h" + /** * The maximum value we will allow in an integer cell: one less than 2^60: * (let ((s (make-string-output-stream))) diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 5135d6b..f0095b1 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -61,11 +61,11 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) { if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd, NIL ); + result = acquire_integer( ddrv / gcd, NIL ); } else { result = - make_ratio( make_integer( ddrv / gcd, NIL ), - make_integer( drrv / gcd, NIL ) ); + make_ratio( acquire_integer( ddrv / gcd, NIL ), + acquire_integer( drrv / gcd, NIL ) ); } } } @@ -110,23 +110,24 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, m1, m2 ); if ( dr1v == dr2v ) { - r = make_ratio( make_integer( dd1v + dd2v, NIL ), + r = make_ratio( acquire_integer( dd1v + dd2v, NIL ), cell1.payload.ratio.divisor ); } else { - struct cons_pointer dd1vm = make_integer( dd1v * m1, NIL ), - dr1vm = make_integer( dr1v * m1, NIL ), - dd2vm = make_integer( dd2v * m2, NIL ), - dr2vm = make_integer( dr2v * m2, NIL ), + struct cons_pointer dd1vm = acquire_integer( dd1v * m1, NIL ), + dr1vm = acquire_integer( dr1v * m1, NIL ), + dd2vm = acquire_integer( dd2v * m2, NIL ), + dr2vm = acquire_integer( dr2v * m2, NIL ), r1 = make_ratio( dd1vm, dr1vm ), r2 = make_ratio( dd2vm, dr2vm ); r = add_ratio_ratio( r1, r2 ); + if (!eq( r, r1)) { dec_ref( r1);} + if (!eq( r, r2)) { dec_ref( r2);} + /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were * never incremented except when making r1 and r2, decrementing * r1 and r2 should be enought to garbage collect them. */ - dec_ref( r1 ); - dec_ref( r2 ); } result = simplify_ratio( r ); @@ -162,12 +163,12 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, if ( integerp( intarg ) && ratiop( ratarg ) ) { // TODO: not longer works - struct cons_pointer one = make_integer( 1, NIL ), + struct cons_pointer one = acquire_integer( 1, NIL ), ratio = make_ratio( intarg, one ); result = add_ratio_ratio( ratio, ratarg ); - dec_ref( one ); + release_integer( one ); dec_ref( ratio ); } else { result = @@ -231,11 +232,15 @@ struct cons_pointer multiply_ratio_ratio( struct pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, ddrv = dd1v * dd2v, drrv = dr1v * dr2v; + struct cons_pointer dividend = acquire_integer( ddrv, NIL ); + struct cons_pointer divisor = acquire_integer( drrv, NIL ); struct cons_pointer unsimplified = - make_ratio( make_integer( ddrv, NIL ), - make_integer( drrv, NIL ) ); + make_ratio( dividend, divisor); result = simplify_ratio( unsimplified ); + release_integer( dividend); + release_integer( divisor); + if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } @@ -261,12 +266,11 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, if ( integerp( intarg ) && ratiop( ratarg ) ) { // TODO: no longer works; fix - struct cons_pointer one = make_integer( 1, NIL ), + struct cons_pointer one = acquire_integer( 1, NIL ), ratio = make_ratio( intarg, one ); result = multiply_ratio_ratio( ratio, ratarg ); - dec_ref( one ); - dec_ref( ratio ); + release_integer( one ); } else { result = throw_exception( c_string_to_lisp_string diff --git a/src/init.c b/src/init.c index 2d0d2d2..45b534f 100644 --- a/src/init.c +++ b/src/init.c @@ -78,13 +78,8 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) /** * Bind this `value` to this `name` in the `oblist`. */ -void bind_value( wchar_t *name, struct cons_pointer value ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref( n ); - - deep_bind( n, value ); - - dec_ref( n ); +struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value ) { + return deep_bind( c_string_to_lisp_symbol( name ), value ); } void print_banner( ) { @@ -200,14 +195,14 @@ int main( int argc, char *argv[] ) { FILE *infile = infilename == NULL ? stdin : fopen( infilename, "r"); - bind_value( L"*in*", make_read_stream( file_to_url_file(infile), - make_cons( make_cons - ( c_string_to_lisp_keyword - ( L"url" ), - c_string_to_lisp_string - ( L"system:standard input" ) ), - NIL ) ) ); - bind_value( L"*out*", + lisp_io_in = bind_value( C_IO_IN, make_read_stream( file_to_url_file(infile), + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard input" ) ), + NIL ) ) ); + lisp_io_out = bind_value( C_IO_OUT, make_write_stream( file_to_url_file( stdout ), make_cons( make_cons ( c_string_to_lisp_keyword diff --git a/src/io/io.c b/src/io/io.c index d01f788..2db9492 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -28,11 +28,12 @@ #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "arith/integer.h" #include "debug.h" #include "io/fopen.h" -#include "arith/integer.h" +#include "io/io.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "ops/intern.h" #include "ops/lispops.h" #include "utils.h" @@ -44,6 +45,16 @@ */ CURLSH *io_share; +/** + * @brief bound to the Lisp string representing C_IO_IN in initialisation. + */ +struct cons_pointer lisp_io_in = NIL; +/** + * @brief bound to the Lisp string representing C_IO_OUT in initialisation. + */ +struct cons_pointer lisp_io_out = NIL; + + /** * Allow a one-character unget facility. This may not be enough - we may need * to allocate a buffer. @@ -400,7 +411,7 @@ void collect_meta( struct cons_pointer stream, char *url ) { struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_pointer stream_name = - c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); + inputp ? lisp_io_in : lisp_io_out; inc_ref( stream_name ); diff --git a/src/io/io.h b/src/io/io.h index dc9e8de..0f971a3 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -11,12 +11,18 @@ #ifndef __psse_io_h #define __psse_io_h #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" extern CURLSH *io_share; int io_init( ); +#define C_IO_IN L"*in*" +#define C_IO_OUT L"*out*" + +extern struct cons_pointer lisp_io_in; +extern struct cons_pointer lisp_io_out; + URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); wint_t url_ungetwc( wint_t wc, URL_FILE * input ); diff --git a/src/io/read.c b/src/io/read.c index 13b0942..bf0b389 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -291,10 +291,10 @@ struct cons_pointer read_number( struct stack_frame *frame, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = make_integer( 0, NIL ); + struct cons_pointer result = acquire_integer( 0, NIL ); /* \todo we really need to be getting `base` from a privileged Lisp name - * and it should be the same privileged name we use when writing numbers */ - struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer base = acquire_integer( 10, NIL ); struct cons_pointer dividend = NIL; int places_of_decimals = 0; wint_t c; @@ -330,20 +330,20 @@ struct cons_pointer read_number( struct stack_frame *frame, debug_print( L"read_number: ratio slash seen\n", DEBUG_IO ); dividend = result; + + result = acquire_integer( 0, NIL ); + // If I do replace_integer_p here instead of acquire_integer, + // and thus reclaim the garbage, I get a regression. Dom't yet + // know why. } break; case LCOMMA: // silently ignore comma. break; default: - { - struct cons_pointer digit = make_integer( ( int ) c - ( int ) '0', - NIL ); - struct cons_pointer new_result = add_integers( multiply_integers( result, base ), - digit ); - dec_ref( result); - dec_ref( digit); - result = new_result; + result = add_integers( multiply_integers( result, base ), + acquire_integer( ( int ) c - ( int ) '0', + NIL ) ); debug_printf( DEBUG_IO, L"read_number: added character %c, result now ", @@ -354,7 +354,6 @@ struct cons_pointer read_number( struct stack_frame *frame, if ( seen_period ) { places_of_decimals++; } - } } } @@ -364,14 +363,13 @@ struct cons_pointer read_number( struct stack_frame *frame, url_ungetwc( c, input ); if ( seen_period ) { - struct cons_pointer divisor = make_integer( powl( to_long_double( base ), - places_of_decimals ), - NIL ); debug_print( L"read_number: converting result to real\n", DEBUG_IO ); - struct cons_pointer div = make_ratio( result, - divisor); - dec_ref( divisor); + acquire_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); inc_ref( div ); result = make_real( to_long_double( div ) ); @@ -383,19 +381,15 @@ struct cons_pointer read_number( struct stack_frame *frame, } if ( neg ) { - struct cons_pointer negt = negative( result ); debug_print( L"read_number: converting result to negative\n", DEBUG_IO ); - dec_ref( result); - result = negt; + result = negative( result ); } debug_print( L"read_number returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); - dec_ref( base); - return result; } diff --git a/src/memory/conspage.c b/src/memory/conspage.c index b30ee53..42c0ad1 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -187,6 +187,8 @@ void free_cell( struct cons_pointer pointer ) { case VECTORPOINTTV: free_vso( pointer ); break; + default: + fprintf( stderr, "WARNING: Freeing object of type %s!", (char *) &(cell->tag.bytes)); } strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); @@ -231,7 +233,7 @@ struct cons_pointer allocate_cell( uint32_t tag ) { cell->tag.value = tag; - cell->count = 0; + cell->count = 1; cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; diff --git a/src/ops/intern.c b/src/ops/intern.c index 1f6585b..cafc294 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -424,9 +424,8 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, } /** - * Binds this key to this value in the global oblist, but doesn't affect the - * current environment. May not be useful except in bootstrapping (and even - * there it may not be especially useful). + * @brief Binds this key to this value in the global oblist. + */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { @@ -448,10 +447,10 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { } debug_print( L"deep_bind returning ", DEBUG_BIND ); - debug_print_object( oblist, DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); debug_println( DEBUG_BIND ); - return oblist; + return key; } /** From f6d7fcea1ea83689700b77cc891dfbf025e6ddfe Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 13 Feb 2026 12:50:02 +0000 Subject: [PATCH 3/3] Woohoo! Huge decrease in cells not cleaned up, with fixing one stupid bug. --- post-scarcity.cbp | 157 --------------------------------- post-scarcity.cscope_file_list | 58 ------------ post-scarcity.layout | 15 ---- src/arith/integer.c | 3 + src/init.c | 40 ++++++++- src/io/print.c | 8 +- src/memory/consspaceobject.c | 8 -- src/memory/hashmap.c | 4 +- src/ops/intern.c | 17 ++-- src/ops/lispops.c | 72 ++++++++------- src/ops/lispops.h | 2 + src/repl.c | 2 - 12 files changed, 93 insertions(+), 293 deletions(-) delete mode 100644 post-scarcity.cbp delete mode 100644 post-scarcity.cscope_file_list delete mode 100644 post-scarcity.layout diff --git a/post-scarcity.cbp b/post-scarcity.cbp deleted file mode 100644 index a1f42e0..0000000 --- a/post-scarcity.cbp +++ /dev/null @@ -1,157 +0,0 @@ - - - - - - diff --git a/post-scarcity.cscope_file_list b/post-scarcity.cscope_file_list deleted file mode 100644 index 6fbf5ec..0000000 --- a/post-scarcity.cscope_file_list +++ /dev/null @@ -1,58 +0,0 @@ -"/home/simon/workspace/post-scarcity/utils_src/readprintwc/readprintwc.c" -"/home/simon/workspace/post-scarcity/src/memory/vectorspace.c" -"/home/simon/workspace/post-scarcity/src/arith/peano.c" -"/home/simon/workspace/post-scarcity/src/init.c" -"/home/simon/workspace/post-scarcity/src/utils.h" -"/home/simon/workspace/post-scarcity/src/ops/intern.h" -"/home/simon/workspace/post-scarcity/src/arith/ratio.h" -"/home/simon/workspace/post-scarcity/src/io/io.c" -"/home/simon/workspace/post-scarcity/src/memory/conspage.h" -"/home/simon/workspace/post-scarcity/src/time/psse_time.h" -"/home/simon/workspace/post-scarcity/src/memory/cursor.h" -"/home/simon/workspace/post-scarcity/src/memory/dump.h" -"/home/simon/workspace/post-scarcity/src/ops/intern.c" -"/home/simon/workspace/post-scarcity/src/memory/lookup3.c" -"/home/simon/workspace/post-scarcity/src/io/fopen.h" -"/home/simon/workspace/post-scarcity/src/version.h" -"/home/simon/workspace/post-scarcity/src/memory/consspaceobject.h" -"/home/simon/workspace/post-scarcity/src/ops/meta.h" -"/home/simon/workspace/post-scarcity/src/arith/real.c" -"/home/simon/workspace/post-scarcity/src/ops/loop.c" -"/home/simon/workspace/post-scarcity/src/arith/integer.h" -"/home/simon/workspace/post-scarcity/src/time/psse_time.c" -"/home/simon/workspace/post-scarcity/src/memory/vectorspace.h" -"/home/simon/workspace/post-scarcity/src/memory/hashmap.c" -"/home/simon/workspace/post-scarcity/src/io/read.c" -"/home/simon/workspace/post-scarcity/src/ops/lispops.h" -"/home/simon/workspace/post-scarcity/src/ops/loop.h" -"/home/simon/workspace/post-scarcity/src/memory/stack.h" -"/home/simon/workspace/post-scarcity/utils_src/tagvalcalc/tagvalcalc.c" -"/home/simon/workspace/post-scarcity/src/debug.c" -"/home/simon/workspace/post-scarcity/src/io/read.h" -"/home/simon/workspace/post-scarcity/src/ops/meta.c" -"/home/simon/workspace/post-scarcity/src/memory/dump.c" -"/home/simon/workspace/post-scarcity/src/repl.c" -"/home/simon/workspace/post-scarcity/src/io/print.c" -"/home/simon/workspace/post-scarcity/src/memory/hashmap.h" -"/home/simon/workspace/post-scarcity/src/utils.c" -"/home/simon/workspace/post-scarcity/src/io/io.h" -"/home/simon/workspace/post-scarcity/src/memory/stack.c" -"/home/simon/workspace/post-scarcity/utils_src/debugflags/debugflags.c" -"/home/simon/workspace/post-scarcity/src/memory/consspaceobject.c" -"/home/simon/workspace/post-scarcity/src/memory/conspage.c" -"/home/simon/workspace/post-scarcity/src/memory/cursor.c" -"/home/simon/workspace/post-scarcity/src/arith/ratio.c" -"/home/simon/workspace/post-scarcity/Makefile" -"/home/simon/workspace/post-scarcity/src/arith/peano.h" -"/home/simon/workspace/post-scarcity/src/memory/lookup3.h" -"/home/simon/workspace/post-scarcity/src/arith/real.h" -"/home/simon/workspace/post-scarcity/src/ops/equal.c" -"/home/simon/workspace/post-scarcity/src/ops/lispops.c" -"/home/simon/workspace/post-scarcity/src/authorise.h" -"/home/simon/workspace/post-scarcity/src/io/print.h" -"/home/simon/workspace/post-scarcity/src/authorise.c" -"/home/simon/workspace/post-scarcity/src/debug.h" -"/home/simon/workspace/post-scarcity/src/arith/integer.c" -"/home/simon/workspace/post-scarcity/src/ops/equal.h" -"/home/simon/workspace/post-scarcity/src/repl.h" -"/home/simon/workspace/post-scarcity/src/io/fopen.c" diff --git a/post-scarcity.layout b/post-scarcity.layout deleted file mode 100644 index 98bd2b3..0000000 --- a/post-scarcity.layout +++ /dev/null @@ -1,15 +0,0 @@ - - - - - - - - - - - - - - - diff --git a/src/arith/integer.c b/src/arith/integer.c index e9d9b79..821b476 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -272,9 +272,12 @@ struct cons_pointer add_integers( struct cons_pointer a, return result; } +// TODO: I have really no idea what I was trying to do here, or why it could possibly be a good idea. struct cons_pointer base_partial( int depth ) { struct cons_pointer result = NIL; + debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth); + for ( int i = 0; i < depth; i++ ) { result = acquire_integer( 0, result ); } diff --git a/src/init.c b/src/init.c index 45b534f..17f8d36 100644 --- a/src/init.c +++ b/src/init.c @@ -37,6 +37,34 @@ #include "io/fopen.h" #include "time/psse_time.h" +/** + * @brief If `pointer` is an exception, display that exception to stderr, + * decrement that exception, and return NIL; else return the pointer. + * + * @param pointer a cons pointer. + * @param location_descriptor a description of where the pointer was caught. + * @return struct cons_pointer + */ +struct cons_pointer check_exception( struct cons_pointer pointer, char * location_descriptor) { + struct cons_pointer result = NIL; + + struct cons_space_object * object = &pointer2cell( pointer); + + if ( exceptionp( pointer)) { + fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor); + URL_FILE *ustderr = file_to_url_file( stderr ); + fwide( stderr, 1 ); + print( ustderr, object->payload.exception.payload ); + free( ustderr ); + + dec_ref( pointer); + } else { + result = pointer; + } + + return result; +} + /** * Bind this compiled `executable` function, as a Lisp function, to @@ -55,7 +83,8 @@ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) n ), NIL ) ); - deep_bind( n, make_function( meta, executable ) ); + check_exception( deep_bind( n, make_function( meta, executable ) ), + "bind_function"); } /** @@ -72,14 +101,17 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) n ), NIL ) ); - deep_bind( n, make_special( meta, executable ) ); + check_exception(deep_bind( n, make_special( meta, executable ) ), + "bind_special"); } /** * Bind this `value` to this `name` in the `oblist`. */ struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value ) { - return deep_bind( c_string_to_lisp_symbol( name ), value ); + return check_exception( + deep_bind( c_string_to_lisp_symbol( name ), value ), + "bind_value"); } void print_banner( ) { @@ -227,7 +259,7 @@ int main( int argc, char *argv[] ) { /* * the default prompt */ - bind_value( L"*prompt*", + prompt_name = bind_value( L"*prompt*", show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); /* * primitive function operations diff --git a/src/io/print.c b/src/io/print.c index 8f4b88e..f4aab9f 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -169,9 +169,11 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print( output, cell.payload.function.meta ); url_fputwc( L'>', output ); break; - case INTEGERTV:{ + case INTEGERTV: + if ( nilp( cell.payload.integer.more)) { + url_fwprintf( output, L"%ld", cell.payload.integer.value); + } else { struct cons_pointer s = integer_to_string( pointer, 10 ); - inc_ref( s ); print_string_contents( output, s ); dec_ref( s ); } @@ -186,7 +188,6 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { make_cons( c_string_to_lisp_symbol( L"\u03bb" ), make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); - inc_ref( to_print ); print( output, to_print ); @@ -203,7 +204,6 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { make_cons( c_string_to_lisp_symbol( L"n\u03bb" ), make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); - inc_ref( to_print ); print( output, to_print ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 8f9e2a8..81836f8 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -201,7 +201,6 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer pointer = allocate_cell( EXCEPTIONTV ); struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( message ); inc_ref( frame_pointer ); cell->payload.exception.payload = message; cell->payload.exception.frame = frame_pointer; @@ -237,9 +236,6 @@ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer pointer = allocate_cell( LAMBDATV ); struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do - this, but if I don't the cell gets freed */ - inc_ref( args ); inc_ref( body ); cell->payload.lambda.args = args; @@ -256,9 +252,6 @@ struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ) { struct cons_pointer pointer = allocate_cell( NLAMBDATV ); - inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do - this, but if I don't the cell gets freed */ - struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( args ); inc_ref( body ); @@ -312,7 +305,6 @@ struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, pointer = allocate_cell( tag ); struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( tail ); cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; /* \todo There's a problem here. Sometimes the offsets on diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index f2911e5..15b5550 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -87,9 +87,9 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, &( map->payload ) )->n_buckets; map->payload.hashmap.buckets[bucket_no] = - inc_ref( make_cons( make_cons( key, val ), + make_cons( make_cons( key, val ), map->payload.hashmap. - buckets[bucket_no] ) ); + buckets[bucket_no] ); } } } diff --git a/src/ops/intern.c b/src/ops/intern.c index cafc294..3fb38d3 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -292,7 +292,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { // if ( equal( key, entry.payload.cons.car ) ) { // result = entry.payload.cons.car; // } - if (!nilp( c_assoc( store, key))) { + if (!nilp( c_assoc( key, store))) { result = key; } } else { @@ -340,18 +340,23 @@ struct cons_pointer c_assoc( struct cons_pointer key, result = hashmap_get( entry_ptr, key ); break; default: - throw_exception( c_string_to_lisp_string - ( L"Store entry is of unknown type" ), - NIL ); + throw_exception( c_append( + c_string_to_lisp_string( L"Store entry is of unknown type: " ), + c_type( entry_ptr)), NIL); } } } } else if ( hashmapp( store ) ) { result = hashmap_get( store, key ); } else if ( !nilp( store ) ) { + debug_print( L"c_assoc; store is of unknown type `", DEBUG_BIND ); + debug_print_object( c_type( store), DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); result = - throw_exception( c_string_to_lisp_string - ( L"Store is of unknown type" ), NIL ); + throw_exception( + c_append( + c_string_to_lisp_string( L"Store is of unknown type: " ), + c_type( store)), NIL ); } debug_print( L"c_assoc returning ", DEBUG_BIND ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 236a290..2f549e4 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -38,6 +38,13 @@ #include "memory/stack.h" #include "memory/vectorspace.h" +/** + * @brief the name of the symbol to which the prompt is bound; + * + * Set in init to `*prompt*` + */ +struct cons_pointer prompt_name; + /* * also to create in this section: * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, @@ -46,7 +53,6 @@ * and others I haven't thought of yet. */ - /** * Useful building block; evaluate this single form in the context of this * parent stack frame and this environment. @@ -1263,7 +1269,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer input = get_default_stream( true, env ); struct cons_pointer output = get_default_stream( false, env ); - struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); +// struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; @@ -1558,43 +1564,35 @@ struct cons_pointer lisp_let( struct stack_frame *frame, } -// /** -// * Function; print the internal representation of the object indicated by `frame->arg[0]` to the -// * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. -// * -// * * (inspect expression) -// * * (inspect expression ) -// * -// * @param frame my stack frame. -// * @param frame_pointer a pointer to my stack_frame. -// * @param env the environment. -// * @return the value of the first argument - `expression`. -// */ -// struct cons_pointer lisp_inspect( struct stack_frame *frame, -// struct cons_pointer frame_pointer, -// struct cons_pointer env ) { -// debug_print( L"Entering print\n", DEBUG_IO ); -// URL_FILE *output; -// struct cons_pointer out_stream = writep( frame->arg[1] ) ? -// frame->arg[1] : get_default_stream( false, env ); +// struct cons_pointer c_concat( struct cons_pointer a, struct cons_pointer b) { +// struct cons_pointer result = b; -// if ( writep( out_stream ) ) { -// debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); -// debug_dump_object( out_stream, DEBUG_IO ); -// output = pointer2cell( out_stream ).payload.stream.stream; -// inc_ref( out_stream ); +// if ( nilp( b.tag.value)) { +// result = make_cons( a, b); // } else { -// output = file_to_url_file( stdout ); +// if ( ! nilp( a)) { +// if (a.tag.value == b.tag.value) { + +// struct cons_pointer tail = c_concat( c_cdr( a), b); + +// switch ( a.tag.value) { +// case CONSTV: +// result = make_cons( c_car( a), tail); +// break; +// case KEYTV: +// case STRINGTV: +// case SYMBOLTV: +// result = make_string_like_thing() + +// } + +// } else { +// // throw an exception +// } +// } // } + -// dump_object( output, frame->arg[0] ); -// url_fputws( L"\n", output ); -// if ( writep( out_stream ) ) { -// dec_ref( out_stream ); -// } else { -// free( output ); -// } - -// return frame->arg[0]; -// } +// return result; +// } \ No newline at end of file diff --git a/src/ops/lispops.h b/src/ops/lispops.h index da1f27e..ec84d61 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -22,6 +22,8 @@ #ifndef __psse_lispops_h #define __psse_lispops_h +extern struct cons_pointer prompt_name; + /* * utilities */ diff --git a/src/repl.c b/src/repl.c index b68fa1c..5295465 100644 --- a/src/repl.c +++ b/src/repl.c @@ -41,8 +41,6 @@ void repl( ) { struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env ); if ( !nilp( frame_pointer ) ) { - inc_ref( frame_pointer ); - lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); dec_ref( frame_pointer );