diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 61cfa0c..1d8bbfd 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -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, diff --git a/src/init.c b/src/init.c index a2da5e9..baca2b7 100644 --- a/src/init.c +++ b/src/init.c @@ -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; diff --git a/src/io/io.c b/src/io/io.c index 51a05cc..cf0894f 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -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; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index b456097..9653402 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -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" diff --git a/src/memory/dump.c b/src/memory/dump.c index b065661..3a83866 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -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 ); diff --git a/src/memory/stack.c b/src/memory/stack.c index 7a85f3d..cff1ece 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -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++ ) { diff --git a/src/memory/stack.h b/src/memory/stack.h index f132c69..111df48 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -21,6 +21,8 @@ #ifndef __psse_stack_h #define __psse_stack_h +#include + #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 ); diff --git a/src/ops/intern.c b/src/ops/intern.c index f5f1e63..bba5ee5 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -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 ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index fe264e8..57b2f8e 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -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 ); } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 630592f..66f46c8 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -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 diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh index 6b5be2d..e3aa586 100755 --- a/unit-tests/recursion.sh +++ b/unit-tests/recursion.sh @@ -5,8 +5,8 @@ output=`target/psse 2>/dev/null <&1 | grep Exception` if [ "${expected}" = "${actual}" ]