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 # 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 ## 20260226
The bug in `member` turned out to be because when a symbol is read by the reader, The bug in `member` turned out to be because when a symbol is read by the reader,

7
src/init.c
View file

@ -217,6 +217,8 @@ void print_options( FILE *stream ) {
L"\t-d\tDump memory to standard out at end of run (copious!);\n" ); 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-h\tPrint this message and exit;\n" );
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\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 #ifdef DEBUG
fwprintf( stream, fwprintf( stream,
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" ); 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 ); exit( 1 );
} }
while ( ( option = getopt( argc, argv, "phdv:i:" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
case 'd': case 'd':
dump_at_end = true; dump_at_end = true;
@ -265,6 +267,9 @@ int main( int argc, char *argv[] ) {
case 'p': case 'p':
show_prompt = true; show_prompt = true;
break; break;
case 's':
stack_limit = atoi( optarg );
break;
case 'v': case 'v':
verbosity = atoi( optarg ); verbosity = atoi( optarg );
break; 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] ) ) { if ( readp( frame->arg[0] ) ) {
result = result =
make_string( url_fgetwc make_string( url_fgetwc
( pointer2cell( frame->arg[0] ).payload.stream. ( pointer2cell( frame->arg[0] ).payload.
stream ), NIL ); stream.stream ), NIL );
} }
return result; return result;

4
src/memory/consspaceobject.h
View file

@ -207,7 +207,7 @@ extern struct cons_pointer privileged_keyword_cause;
#define READTV 1145128274 #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" #define REALTAG "REAL"
@ -239,7 +239,7 @@ extern struct cons_pointer privileged_keyword_cause;
#define STRINGTV 1196577875 #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" #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: case RATIOTV:
url_fwprintf( output, url_fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n", L"\t\tRational cell: value %ld/%ld, count %u\n",
pointer2cell( cell.payload.ratio.dividend ).payload. pointer2cell( cell.payload.ratio.dividend ).
integer.value, payload.integer.value,
pointer2cell( cell.payload.ratio.divisor ).payload. pointer2cell( cell.payload.ratio.divisor ).
integer.value, cell.count ); payload.integer.value, cell.count );
break; break;
case READTV: case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output ); url_fputws( L"\t\tInput stream; metadata: ", output );

66
src/memory/stack.c
View file

@ -26,6 +26,12 @@
#include "memory/vectorspace.h" #include "memory/vectorspace.h"
#include "ops/lispops.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, * set a register in a stack frame. Alwaye use this to do so,
* because that way we can be sure the inc_ref happens! * 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. * 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 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. * @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 ); debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result = struct cons_pointer result =
make_vso( STACKFRAMETV, sizeof( struct stack_frame ) ); make_vso( STACKFRAMETV, sizeof( struct stack_frame ) );
debug_dump_object( result, DEBUG_ALLOC );
if ( !nilp( result ) ) { if ( !nilp( result ) ) {
struct stack_frame *frame = get_stack_frame( 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->previous = previous;
frame->depth = depth;
/* /*
* clearing the frame with memset would probably be slightly quicker, but * 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->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_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC ); debug_dump_object( result, DEBUG_ALLOC );
@ -107,6 +116,37 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
return result; 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, * Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env. * 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 ); debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous ); struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) { if ( !exceptionp( result ) ) {
/* i.e. out of memory */
result =
make_exception( privileged_string_memory_exhausted, previous );
} else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && consp( args ) ) { 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 ); struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) { if ( !exceptionp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result ); struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && !nilp( args ) ) { 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 ) { if ( frame != NULL ) {
url_fwprintf( output, L"Stack frame %d with %d arguments:\n", url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
frame->depth; frame->depth, frame->args );
frame->args );
dump_frame_context( output, frame_pointer, 4 ); dump_frame_context( output, frame_pointer, 4 );
for ( int arg = 0; arg < frame->args; arg++ ) { for ( int arg = 0; arg < frame->args; arg++ ) {

4
src/memory/stack.h
View file

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

39
src/ops/intern.c
View file

@ -329,14 +329,15 @@ struct cons_pointer search_store( struct cons_pointer key,
cursor = pointer2cell( cursor ).payload.cons.cdr ) { cursor = pointer2cell( cursor ).payload.cons.cdr ) {
switch ( get_tag_value( cursor ) ) { switch ( get_tag_value( cursor ) ) {
case CONSTV: case CONSTV:
struct cons_pointer entry_ptr = c_car( cursor ); struct cons_pointer entry_ptr =
c_car( cursor );
switch ( get_tag_value( entry_ptr ) ) { switch ( get_tag_value( entry_ptr ) ) {
case CONSTV: case CONSTV:
if ( equal( key, c_car( entry_ptr ) ) ) { if ( equal( key, c_car( entry_ptr ) ) ) {
result = result =
return_key ? c_car( entry_ptr ) : return_key ? c_car( entry_ptr )
c_cdr( entry_ptr ); : c_cdr( entry_ptr );
} }
break; break;
case HASHTV: case HASHTV:
@ -352,10 +353,10 @@ struct cons_pointer search_store( struct cons_pointer key,
throw_exception throw_exception
( c_string_to_lisp_symbol ( c_string_to_lisp_symbol
( L"search-store (entry)" ), ( L"search-store (entry)" ),
make_cons( c_string_to_lisp_string make_cons
( c_string_to_lisp_string
( L"Unexpected store type: " ), ( L"Unexpected store type: " ),
c_type( c_car c_type( c_car( entry_ptr ) ) ),
( entry_ptr ) ) ),
NIL ); NIL );
} }
@ -365,7 +366,8 @@ struct cons_pointer search_store( struct cons_pointer key,
debug_print debug_print
( L"\n\tHashmap as top-level value in list", ( L"\n\tHashmap as top-level value in list",
DEBUG_BIND ); DEBUG_BIND );
result = hashmap_get( cursor, key, return_key ); result =
hashmap_get( cursor, key, return_key );
break; break;
default: default:
result = result =
@ -374,7 +376,8 @@ struct cons_pointer search_store( struct cons_pointer key,
make_cons make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( L"Unexpected store type: " ), ( L"Unexpected store type: " ),
c_type( cursor ) ), NIL ); c_type( cursor ) ),
NIL );
} }
} }
break; break;
@ -394,20 +397,20 @@ struct cons_pointer search_store( struct cons_pointer key,
break; break;
case EXCEPTIONTV: case EXCEPTIONTV:
result = result =
throw_exception( c_string_to_lisp_symbol( L"search-store (exception)" ), throw_exception( c_string_to_lisp_symbol
make_cons ( L"search-store (exception)" ),
( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ), c_type( key ) ), ( L"Unexpected key type: " ),
NIL ); c_type( key ) ), NIL );
break; break;
default: default:
result = result =
throw_exception( c_string_to_lisp_symbol( L"search-store (key)" ), throw_exception( c_string_to_lisp_symbol
make_cons ( L"search-store (key)" ),
( c_string_to_lisp_string make_cons( c_string_to_lisp_string
( L"Unexpected key type: " ), c_type( key ) ), ( L"Unexpected key type: " ),
NIL ); c_type( key ) ), NIL );
} }
debug_print( L"search-store: returning `", DEBUG_BIND ); debug_print( L"search-store: returning `", DEBUG_BIND );

45
src/ops/lispops.c
View file

@ -92,7 +92,9 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer next_pointer = struct cons_pointer next_pointer =
make_empty_frame( parent_pointer ); make_empty_frame( parent_pointer );
// inc_ref( next_pointer ); // inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next = get_stack_frame( next_pointer ); struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form ); set_reg( next, 0, form );
next->args = 1; next->args = 1;
@ -106,6 +108,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
dec_ref( next_pointer ); dec_ref( next_pointer );
} }
} }
}
break; break;
} }
@ -365,8 +368,8 @@ struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
pointer2cell( result ).payload.exception.payload = pointer2cell( result ).payload.exception.payload =
make_cons( make_cons( privileged_keyword_location, make_cons( make_cons( privileged_keyword_location,
c_assoc( name_key, c_assoc( name_key,
fn_cell->payload. fn_cell->payload.function.
function.meta ) ), meta ) ),
make_cons( make_cons make_cons( make_cons
( privileged_keyword_payload, ( privileged_keyword_payload,
payload ), NIL ) ); payload ), NIL ) );
@ -420,10 +423,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
get_stack_frame( next_pointer ); get_stack_frame( next_pointer );
result = maybe_fixup_exception_location( ( * result = maybe_fixup_exception_location( ( *
( fn_cell-> ( fn_cell->payload.function.executable ) )
payload.
function.
executable ) )
( next, ( next,
next_pointer, next_pointer,
env ), env ),
@ -497,10 +497,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = next_pointer; result = next_pointer;
} else { } else {
result = maybe_fixup_exception_location( ( * result = maybe_fixup_exception_location( ( *
( fn_cell-> ( fn_cell->payload.special.executable ) )
payload.
special.
executable ) )
( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer ); ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL );
@ -1341,7 +1338,8 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer throw_exception_with_cause( struct cons_pointer location, struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
struct cons_pointer message, struct cons_pointer message,
struct cons_pointer cause, struct cons_pointer cause,
struct cons_pointer frame_pointer ) { struct cons_pointer
frame_pointer ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
#ifdef DEBUG #ifdef DEBUG
@ -1351,8 +1349,7 @@ struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
debug_print_object( location, 511 ); debug_print_object( location, 511 );
debug_print( L"`\n", 511 ); debug_print( L"`\n", 511 );
if ( !nilp( cause ) ) { if ( !nilp( cause ) ) {
debug_print( L"\tCaused by: ", 511) debug_print( L"\tCaused by: ", 511 );
;
debug_print_object( cause, 511 ); debug_print_object( cause, 511 );
debug_print( L"`\n", 511 ); debug_print( L"`\n", 511 );
} }
@ -1370,8 +1367,10 @@ struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
( privileged_keyword_payload, ( privileged_keyword_payload,
message ), message ),
( nilp( cause ) ? NIL : ( nilp( cause ) ? NIL :
make_cons( make_cons( privileged_keyword_cause, make_cons( make_cons
cause), NIL)) ) ), frame_pointer ); ( privileged_keyword_cause,
cause ), NIL ) ) ) ),
frame_pointer );
} }
return result; return result;
@ -1418,9 +1417,8 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0]; struct cons_pointer message = frame->arg[0];
return exceptionp( message ) ? message : throw_exception_with_cause( message, return exceptionp( message ) ? message :
frame->arg[1], throw_exception_with_cause( message, frame->arg[1], frame->arg[2],
frame->arg[2],
frame->previous ); 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 ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) { if ( nilp( c_cdr( l1 ) ) ) {
return return
make_string_like_thing( ( pointer2cell( l1 ).payload. make_string_like_thing( ( pointer2cell( l1 ).
string.character ), l2, payload.string.character ),
l2,
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} else { } else {
return return
make_string_like_thing( ( pointer2cell( l1 ).payload. make_string_like_thing( ( pointer2cell( l1 ).
string.character ), payload.string.character ),
c_append( c_cdr( l1 ), l2 ), c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value ); pointer2cell( l1 ).tag.value );
} }

3
src/ops/lispops.h
View file

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

2
unit-tests/try.sh
View file

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