simon/post-scarcity
1
0
Fork 0
Code Issues 7 Pull requests Projects Releases Packages Wiki Activity Actions

This is broken, but the stack limit feature works. Some debugging needed.

Browse source
This commit is contained in:
Simon Brooke 2026-03-13 23:42:57 +00:00
parent 2536e76617
commit d1ce893633
12 changed files with 164 additions and 111 deletions
Download patch file Download diff file Expand all files Collapse all files

11
docs/State-of-play.md
View file

@ -1,5 +1,16 @@
# State of Play
## 20260311
I've still been having trouble with runaway recursion — in `member`, but
due to a primitive bug I haven't identified — so this morning I've tried
to implement a stack limit feature. This has been a real fail at this stage.
Many more tests are breaking.
However, I think having a configurable stack limit would be a good thing, so
I'm not yet ready to abandon this feature. I need to work out why it's breaking
things.
## 20260226
The bug in `member` turned out to be because when a symbol is read by the reader,

11
src/init.c
View file

@ -96,8 +96,8 @@ void maybe_bind_init_symbols( ) {
if ( nilp( privileged_keyword_payload ) ) {
privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" );
}
if ( nilp( privileged_keyword_cause)) {
privileged_keyword_cause = c_string_to_lisp_keyword(L"cause");
if ( nilp( privileged_keyword_cause ) ) {
privileged_keyword_cause = c_string_to_lisp_keyword( L"cause" );
}
}
@ -217,6 +217,8 @@ void print_options( FILE *stream ) {
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
fwprintf( stream,
L"\t-s LIMIT\n\t\tSet the maximum stack depth to this LIMIT (int)\n" );
#ifdef DEBUG
fwprintf( stream,
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
@ -249,7 +251,7 @@ int main( int argc, char *argv[] ) {
exit( 1 );
}
while ( ( option = getopt( argc, argv, "phdv:i:" ) ) != -1 ) {
while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
switch ( option ) {
case 'd':
dump_at_end = true;
@ -265,6 +267,9 @@ int main( int argc, char *argv[] ) {
case 'p':
show_prompt = true;
break;
case 's':
stack_limit = atoi( optarg );
break;
case 'v':
verbosity = atoi( optarg );
break;

4
src/io/io.c
View file

@ -508,8 +508,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) {
result =
make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.stream.
stream ), NIL );
( pointer2cell( frame->arg[0] ).payload.
stream.stream ), NIL );
}
return result;

4
src/memory/consspaceobject.h
View file

@ -207,7 +207,7 @@ extern struct cons_pointer privileged_keyword_cause;
#define READTV 1145128274
/**
* A real number, represented internally as an IEEE 754-2008 `binary64`.
* A real number, represented internally as an IEEE 754-2008 `binary128`.
*/
#define REALTAG "REAL"
@ -239,7 +239,7 @@ extern struct cons_pointer privileged_keyword_cause;
#define STRINGTV 1196577875
/**
* A symbol is just like a string except not self-evaluating.
* A symbol is just like a keyword except not self-evaluating.
*/
#define SYMBOLTAG "SYMB"

8
src/memory/dump.c
View file

@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
case RATIOTV:
url_fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ).payload.
integer.value,
pointer2cell( cell.payload.ratio.divisor ).payload.
integer.value, cell.count );
pointer2cell( cell.payload.ratio.dividend ).
payload.integer.value,
pointer2cell( cell.payload.ratio.divisor ).
payload.integer.value, cell.count );
break;
case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output );

66
src/memory/stack.c
View file

@ -26,6 +26,12 @@
#include "memory/vectorspace.h"
#include "ops/lispops.h"
/**
* @brief If non-zero, maximum depth of stack.
*
*/
uint32_t stack_limit = 0;
/**
* set a register in a stack frame. Alwaye use this to do so,
* because that way we can be sure the inc_ref happens!
@ -68,17 +74,19 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
/**
* Make an empty stack frame, and return it.
*
* This function does the actual meat of making the frame.
*
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @param depth the depth of the new frame.
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
uint32_t depth ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETV, sizeof( struct stack_frame ) );
debug_dump_object( result, DEBUG_ALLOC );
if ( !nilp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
/*
@ -86,6 +94,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
*/
frame->previous = previous;
frame->depth = depth;
/*
* clearing the frame with memset would probably be slightly quicker, but
@ -99,7 +108,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->arg[i] = NIL;
}
frame->depth = (nilp(previous)) ? 0 : (get_stack_frame(previous))->depth + 1;
debug_dump_object( result, DEBUG_ALLOC );
}
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC );
@ -107,6 +116,37 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
return result;
}
/**
* @brief Make an empty stack frame, and return it.
*
* This function does the error checking around actual construction.
*
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer result = NIL;
uint32_t depth =
( nilp( previous ) ) ? 0 : ( get_stack_frame( previous ) )->depth + 1;
if ( stack_limit > 0 && stack_limit > depth ) {
result = in_make_empty_frame( previous, depth );
} else {
result =
make_exception( c_string_to_lisp_string
( L"Stack limit exceeded." ), previous );
}
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( privileged_string_memory_exhausted, previous );
}
return result;
}
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
@ -121,11 +161,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( privileged_string_memory_exhausted, previous );
} else {
if ( !exceptionp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && consp( args ) ) {
@ -191,12 +227,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
if ( !exceptionp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && !nilp( args ) ) {
@ -288,8 +319,7 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) {
if ( frame != NULL ) {
url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
frame->depth;
frame->args );
frame->depth, frame->args );
dump_frame_context( output, frame_pointer, 4 );
for ( int arg = 0; arg < frame->args; arg++ ) {

4
src/memory/stack.h
View file

@ -21,6 +21,8 @@
#ifndef __psse_stack_h
#define __psse_stack_h
#include <stdint.h>
#include "consspaceobject.h"
#include "conspage.h"
@ -35,6 +37,8 @@
*/
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
extern uint32_t stack_limit;
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
struct stack_frame *get_stack_frame( struct cons_pointer pointer );

75
src/ops/intern.c
View file

@ -316,7 +316,7 @@ struct cons_pointer search_store( struct cons_pointer key,
return_key ? "key" : "value" );
#endif
switch ( get_tag_value( key) ) {
switch ( get_tag_value( key ) ) {
case SYMBOLTV:
case KEYTV:
struct cons_space_object *store_cell = &pointer2cell( store );
@ -324,19 +324,20 @@ struct cons_pointer search_store( struct cons_pointer key,
switch ( get_tag_value( store ) ) {
case CONSTV:
for ( struct cons_pointer cursor = store;
nilp( result ) && ( consp( cursor )
|| hashmapp( cursor ) );
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
nilp( result ) && ( consp( cursor )
|| hashmapp( cursor ) );
cursor = pointer2cell( cursor ).payload.cons.cdr ) {
switch ( get_tag_value( cursor ) ) {
case CONSTV:
struct cons_pointer entry_ptr = c_car( cursor );
struct cons_pointer entry_ptr =
c_car( cursor );
switch ( get_tag_value( entry_ptr ) ) {
case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) {
result =
return_key ? c_car( entry_ptr ) :
c_cdr( entry_ptr );
return_key ? c_car( entry_ptr )
: c_cdr( entry_ptr );
}
break;
case HASHTV:
@ -345,18 +346,18 @@ struct cons_pointer search_store( struct cons_pointer key,
// throw an exception.
result =
hashmap_get( entry_ptr, key,
return_key );
return_key );
break;
default:
result =
throw_exception
( c_string_to_lisp_symbol
( L"search-store (entry)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( c_car
( entry_ptr ) ) ),
NIL );
( L"search-store (entry)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( c_car( entry_ptr ) ) ),
NIL );
}
break;
@ -364,17 +365,19 @@ struct cons_pointer search_store( struct cons_pointer key,
case NAMESPACETV:
debug_print
( L"\n\tHashmap as top-level value in list",
DEBUG_BIND );
result = hashmap_get( cursor, key, return_key );
DEBUG_BIND );
result =
hashmap_get( cursor, key, return_key );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (cursor)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( cursor ) ), NIL );
( L"search-store (cursor)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( cursor ) ),
NIL );
}
}
break;
@ -385,29 +388,29 @@ struct cons_pointer search_store( struct cons_pointer key,
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (store)" ),
make_cons( c_string_to_lisp_string
( L"search-store (store)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected store type: " ),
c_type( store ) ), NIL );
break;
}
break;
case EXCEPTIONTV:
case EXCEPTIONTV:
result =
throw_exception( c_string_to_lisp_symbol( L"search-store (exception)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected key type: " ), c_type( key ) ),
NIL );
throw_exception( c_string_to_lisp_symbol
( L"search-store (exception)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
break;
default:
result =
throw_exception( c_string_to_lisp_symbol( L"search-store (key)" ),
make_cons
( c_string_to_lisp_string
( L"Unexpected key type: " ), c_type( key ) ),
NIL );
default:
result =
throw_exception( c_string_to_lisp_symbol
( L"search-store (key)" ),
make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ),
c_type( key ) ), NIL );
}
debug_print( L"search-store: returning `", DEBUG_BIND );

79
src/ops/lispops.c
View file

@ -92,18 +92,21 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer next_pointer =
make_empty_frame( parent_pointer );
// inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
next->args = 1;
struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
next->args = 1;
result = lisp_eval( next, next_pointer, env );
result = lisp_eval( next, next_pointer, env );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
dec_ref( next_pointer );
if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
dec_ref( next_pointer );
}
}
}
break;
@ -365,8 +368,8 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
pointer2cell( result ).payload.exception.payload =
make_cons( make_cons( privileged_keyword_location,
c_assoc( name_key,
fn_cell->payload.
function.meta ) ),
fn_cell->payload.function.
meta ) ),
make_cons( make_cons
( privileged_keyword_payload,
payload ), NIL ) );
@ -420,10 +423,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
get_stack_frame( next_pointer );
result = maybe_fixup_exception_location( ( *
( fn_cell->
payload.
function.
executable ) )
( fn_cell->payload.function.executable ) )
( next,
next_pointer,
env ),
@ -497,10 +497,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer;
} else {
result = maybe_fixup_exception_location( ( *
( fn_cell->
payload.
special.
executable ) )
( fn_cell->payload.special.executable ) )
( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
@ -1339,9 +1336,10 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
* pointer to the frame in which the exception occurred.
*/
struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer cause,
struct cons_pointer frame_pointer ) {
struct cons_pointer message,
struct cons_pointer cause,
struct cons_pointer
frame_pointer ) {
struct cons_pointer result = NIL;
#ifdef DEBUG
@ -1350,10 +1348,9 @@ struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
debug_print( L"` at `", 511 );
debug_print_object( location, 511 );
debug_print( L"`\n", 511 );
if (!nilp( cause)) {
debug_print( L"\tCaused by: ", 511)
;
debug_print_object( cause, 511);
if ( !nilp( cause ) ) {
debug_print( L"\tCaused by: ", 511 );
debug_print_object( cause, 511 );
debug_print( L"`\n", 511 );
}
#endif
@ -1368,10 +1365,12 @@ struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
location ),
make_cons( make_cons
( privileged_keyword_payload,
message ),
(nilp( cause) ? NIL :
make_cons( make_cons( privileged_keyword_cause,
cause), NIL)) ) ), frame_pointer );
message ),
( nilp( cause ) ? NIL :
make_cons( make_cons
( privileged_keyword_cause,
cause ), NIL ) ) ) ),
frame_pointer );
}
return result;
@ -1392,7 +1391,7 @@ struct cons_pointer
throw_exception( struct cons_pointer location,
struct cons_pointer payload,
struct cons_pointer frame_pointer ) {
return throw_exception_with_cause( location, payload, NIL, frame_pointer);
return throw_exception_with_cause( location, payload, NIL, frame_pointer );
}
/**
@ -1418,10 +1417,9 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : throw_exception_with_cause( message,
frame->arg[1],
frame->arg[2],
frame->previous );
return exceptionp( message ) ? message :
throw_exception_with_cause( message, frame->arg[1], frame->arg[2],
frame->previous );
}
/**
@ -1623,13 +1621,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) {
return
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ), l2,
make_string_like_thing( ( pointer2cell( l1 ).
payload.string.character ),
l2,
pointer2cell( l1 ).tag.value );
} else {
return
make_string_like_thing( ( pointer2cell( l1 ).payload.
string.character ),
make_string_like_thing( ( pointer2cell( l1 ).
payload.string.character ),
c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value );
}

7
src/ops/lispops.h
View file

@ -191,9 +191,10 @@ struct cons_pointer lisp_cond( struct stack_frame *frame,
struct cons_pointer env );
struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
struct cons_pointer message,
struct cons_pointer cause,
struct cons_pointer frame_pointer );
struct cons_pointer message,
struct cons_pointer cause,
struct cons_pointer
frame_pointer );
/**
* Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling

4
unit-tests/recursion.sh
View file

@ -5,8 +5,8 @@ output=`target/psse 2>/dev/null <<EOF
(progn
(set! fact
(lambda (n)
(cond ((= n 1) 1)
(t (* n (fact (- n 1)))))))
(cond ((= n 1) 1)
(t (* n (fact (- n 1)))))))
nil)
(fact 10)
EOF`

2
unit-tests/try.sh
View file

@ -40,7 +40,7 @@ else
fi
echo -n "$0: the exception is bound to the symbol \`*exception*\` in the catch environment... "
expected='Exception: "Cannot divide: not a number"'
expected='Exception: ((:location . /) (:payload . "Cannot divide: not a number"))'
actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse 2>&1 | grep Exception`
if [ "${expected}" = "${actual}" ]