diff --git a/docs/State-of-play.md b/docs/State-of-play.md index 6796248..eba1311 100644 --- a/docs/State-of-play.md +++ b/docs/State-of-play.md @@ -1,5 +1,68 @@ # State of Play +## 20260424 + +### To have `c_` functions or not to have `c_` functions, revisited + +Right, I was hugely pleased with my 'make everything a Lisp, function, and then call it from C' idea. I wrote things like: + +```c + print( make_frame( 2, base_of_stack, + eval( make_frame( 1, base_of_stack, + read( make_frame( 1, base_of_stack, input_stream ) ) ) ), + output_stream ) ); +``` + +Isn't it beautiful? Isn't it elegant? Isn't it clear? Yes, it is. Does it work? Yes, actually, it does. Is it a total crock? Unfortunately, dear reader, it is. In this pattern, we don't have a handle on any of the stack frames made with make_frame, so we can't `dec_ref` them, so they don't get garbage collected. And while during bootstrap it's inevitable that there's a little crud left over because it was created before we have enough infrastructure set up, what I'm seeing at present from a 'start up and shut down run' is + +| Size class | Allocated | Deallocated | Remaining | +| ------------ | ------------ | ------------ | ------------ | +| 2 | 453 | 1 | 452 | +| 3 | 1 | 0 | 1 | +| 4 | 49 | 4 | 45 | +| 5 | 0 | 0 | 0 | +| 6 | 0 | 0 | 0 | + +The 452 unfreed objects in size class two are cons cells and string fragments, and they mostly represent the metadata on the streams `*in*`, `*out*`, `*log*` and `*sink*`, all of which are deliberately protected from garbage collection because, frankly, you don't want those things going away under you; so that's kind of OK. The one in size class three is an exception, and I'm quite pleased I'm only throwing one exception during bootstrap (although it would be nice it it got cleaned up). + +But the 45 unfreed objects in size class four are stackframes, and the reason they're unfreed is the coding pattern you see above. + +So, how to get around this? + +The code snippet above could be rewritten: + +```c + struct pso_pointer next = inc_ref( make_frame(1, base_of_stack, input_stream)); + struct pso_pointer read_value = inc_ref(read(next)); + dec_ref( next); + + next = inc_ref( make_frame(1, base_of_stack, read_value)); + struct pso_pointer eval_value = inc_ref( eval( next)); + dec_ref( next); + dec_ref( read_value); + + next = inc_ref( make_frame(2, base_of_stack, eval_value, output_stream)); + print( next); + dec_ref( next); + dec_ref( eval_value); +``` +This is much more prolix and, to me, less elegant; but it does get the garbage collected. In each stanza we're first setting up a frame with the arguments for the function we're about to call, then calling that function with the frame we've set up, and then `dec_ref`ing the frame. We shouldn't need to `dec_ref` the value returned by `print`, since we don't use it and the only thing holding a reference to it is the frame in which it was created, which we do `dec_ref`. + +I could `dec_ref` `read_value`, for instance, as soon as I've put it into the frame for `eval` rather than after `eval` has actually been invoked, since the frame is now protecting it from garbage collection; but I've delayed doing so until afterwards out of caution. + +Once we have `eval`/`apply` working, we won't need to do all this bureaucratic incrementing and decrementing of reference counts explicitly, since `eval`/`apply` *should* take care of it automatically. + +I'm still not 100% confident I can make the reference counting garbage collector work reliably, irrespective of whether it's actually efficient. + +### To recode or not to recode? + +There are 55 calls to `make_frame` in existing C code, and they're almost all written in the 'elegant but insanitary' pattern. Could they be rewritten more cleanly? Yes, they could. But my hope is most of this code will be replaced with code written in Lisp, once we have Lisp sufficiently bootstrapped to make that possible. + +So I think I'm going to put up with the uncollected garbage until we get to that point, at which point I'll audit the C code to see what is actually still in use, sanitise that, and delete the rest. + +However, any new C code (and there is going to have to be some) *must* be written in the sanitary but bureaucratic pattern. + + ## 20260421 ### To have `c_` functions or not to have `c_` functions? diff --git a/src/c/debug.c b/src/c/debug.c index a494358..6c4796d 100644 --- a/src/c/debug.c +++ b/src/c/debug.c @@ -19,7 +19,7 @@ #include "io/io.h" #include "io/print.h" -#include "memory/dump.h" +// #include "memory/dump.h" int verbosity = 0; diff --git a/src/c/io/io.c b/src/c/io/io.c index 7a8aacd..8865a0d 100644 --- a/src/c/io/io.c +++ b/src/c/io/io.c @@ -114,7 +114,8 @@ struct pso_pointer lisp_io_readbase; /** * @brief bound to the Lisp symbol representing C_IO_READTABLE in initialisation */ -struct pso_pointer lisp_io_readtable; +struct pso_pointer lisp_io_read_table; + /** * Allow a one-character unget facility. This may not be enough - we may need @@ -175,7 +176,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer lisp_io_log = c_string_to_lisp_symbol( frame_pointer, C_IO_LOG ); lisp_io_prompt = c_string_to_lisp_symbol( frame_pointer, C_IO_PROMPT ); lisp_io_readbase = c_string_to_lisp_symbol( frame_pointer, C_IO_READBASE ); - lisp_io_readtable = + lisp_io_read_table = c_string_to_lisp_symbol( frame_pointer, C_IO_READTABLE ); debug_print( L"In initialise_default_streams; environment is: ", DEBUG_IO, @@ -192,7 +193,7 @@ struct pso_pointer initialise_default_streams( struct pso_pointer 10 ), lisp_bind( make_frame ( 3, frame_pointer, - lisp_io_readtable, + lisp_io_read_table, nil, env ) ) ) ) ) ); lisp_stdin = @@ -451,48 +452,51 @@ struct pso_pointer add_meta_time( struct pso_pointer frame_pointer, * Callback to assemble metadata for a URL stream. This is naughty because * it modifies data, but it's really the only way to create metadata. */ -static size_t write_meta_callback( struct pso_pointer frame_pointer, char *string, size_t size, size_t nmemb, +static size_t write_meta_callback( struct pso_pointer frame_pointer, + char *string, size_t size, size_t nmemb, struct pso_pointer stream ) { struct pso2 *object = pointer_to_object( stream ); // TODO: reimplement /* make a copy of the string that we can destructively change */ - char *s = calloc( strlen( string ), sizeof( char ) ); - strcpy( s, string ); - if ( readp(stream) || - writep(stream) ) { - int offset = index_of( ':', s ); - if ( offset != -1 ) { - s[offset] = ( char ) 0; - char *name = trim( s ); - char *value = trim( &s[++offset] ); - char32_t wname[strlen( name )]; - mbstowcs( wname, name, strlen( name ) + 1 ); - object->payload.stream.meta = - add_meta_string( frame_pointer, object->payload.stream.meta, wname, value ); - debug_printf( DEBUG_IO, 0, - L"write_meta_callback: added header '%s': value '%s'\n", name, value ); - } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { - int offset = index_of( ' ', s ); - char *value = trim( &s[offset] ); - object->payload.stream.meta = - add_meta_integer( frame_pointer, add_meta_string - (frame_pointer, object->payload.stream.meta, L"status", - value ), L"status-code", strtol( value, - NULL, - 10 ) ); - debug_printf( DEBUG_IO, 0, - L"write_meta_callback: added header 'status': value '%s'\n", value ); - } else { - debug_printf( DEBUG_IO, 0, - L"write_meta_callback: header passed with no colon: '%s'\n", s ); - } - } else { - debug_print - ( L"Pointer passed to write_meta_callback did not point to a stream: ", - DEBUG_IO, 0 ); - debug_dump_object( stream, DEBUG_IO, 0 ); - } - free( s ); + char *s = calloc( strlen( string ), sizeof( char ) ); + strcpy( s, string ); + if ( readp( stream ) || writep( stream ) ) { + int offset = index_of( ':', s ); + if ( offset != -1 ) { + s[offset] = ( char ) 0; + char *name = trim( s ); + char *value = trim( &s[++offset] ); + char32_t wname[strlen( name )]; + mbstowcs( wname, name, strlen( name ) + 1 ); + object->payload.stream.meta = + add_meta_string( frame_pointer, object->payload.stream.meta, + wname, value ); + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: added header '%s': value '%s'\n", + name, value ); + } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { + int offset = index_of( ' ', s ); + char *value = trim( &s[offset] ); + object->payload.stream.meta = + add_meta_integer( frame_pointer, add_meta_string + ( frame_pointer, object->payload.stream.meta, + L"status", value ), L"status-code", + strtol( value, NULL, 10 ) ); + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: added header 'status': value '%s'\n", + value ); + } else { + debug_printf( DEBUG_IO, 0, + L"write_meta_callback: header passed with no colon: '%s'\n", + s ); + } + } else { + debug_print + ( L"Pointer passed to write_meta_callback did not point to a stream: ", + DEBUG_IO, 0 ); + debug_dump_object( stream, DEBUG_IO, 0 ); + } + free( s ); return 0; // strlen( string ); } diff --git a/src/c/io/print.c b/src/c/io/print.c index 7a158d1..1ca8a35 100644 --- a/src/c/io/print.c +++ b/src/c/io/print.c @@ -120,7 +120,8 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, default: url_fputws( L" . ", output ); result = - in_write( object->payload.cons.cdr, output, escape, 0 ); + in_write( object->payload.cons.cdr, output, escape, + 0 ); } } } else { @@ -130,11 +131,11 @@ struct pso_pointer write_list_content( struct pso_pointer p, URL_FILE *output, return result; } -void in_write_nl (URL_FILE *output, int indent) { - write_char( L'\n', output, false); - for (int i = 0; i < indent; i++) { - write_char( L'\t', output, false); - } +void in_write_nl( URL_FILE *output, int indent ) { + write_char( L'\n', output, false ); + for ( int i = 0; i < indent; i++ ) { + write_char( L'\t', output, false ); + } } /** @@ -160,26 +161,36 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, escape ); break; case CONSTV: - write_char( L'(', output, escape); + write_char( L'(', output, escape ); result = write_list_content( p, output, escape ); - write_char( L')', output, escape); + write_char( L')', output, escape ); + break; + case EXCEPTIONTV:{ + struct pso3 *exception = pointer_to_pso3( p ); + + if ( exception != NULL ) { + url_fputws( L"payload.exception.message, output, + escape, indent ); + if ( !c_nilp( exception->payload.exception.meta ) ) { + in_write_nl( output, indent + 1 ); + url_fputws( L"metadata: ", output ); + in_write( exception->payload.exception.meta, + output, escape, indent ); + } + + if ( !c_nilp( exception->payload.exception.cause ) ) { + in_write_nl( output, indent + 1 ); + url_fputws( L"cause: ", output ); + in_write( exception->payload.exception.cause, + output, escape, indent ); + } + write_char( L'>', output, escape ); + } else { + url_fputws( L"", output ); + } + } break; - case EXCEPTIONTV : - struct pso3* exception = pointer_to_pso3(p); - url_fputws( L"payload.exception.message, output, escape, indent); - if (!c_nilp( exception->payload.exception.meta)) { - in_write_nl( output, indent+1); - url_fputws( L"metadata: ", output); - in_write( exception->payload.exception.meta, output, escape, indent); - } - if (!c_nilp( exception->payload.exception.cause)) { - in_write_nl( output, indent+1); - url_fputws( L"cause: ", output); - in_write( exception->payload.exception.cause, output, escape, indent); - } - write_char( L'>', output, escape); - break; case INTEGERTV: url_fwprintf( output, L"%d", ( int64_t ) ( object->payload.integer.value ) ); @@ -196,7 +207,8 @@ struct pso_pointer in_write( struct pso_pointer p, URL_FILE *output, case WRITETV: url_fwprintf( output, L"<%s stream: ", v == READTV ? "read" : "write" ); - in_write( object->payload.stream.meta, output, escape, indent ); + in_write( object->payload.stream.meta, output, escape, + indent ); write_char( L'>', output, escape ); break; case TRUETV: @@ -234,15 +246,15 @@ struct pso_pointer write( struct pso_pointer frame_pointer ) { bool nl_before = c_truep( fetch_arg( frame, 3 ) ); bool nl_after = c_truep( fetch_arg( frame, 4 ) ); struct pso_pointer result = object; - struct pso2* stream_obj = pointer_to_object( stream ); + struct pso2 *stream_obj = pointer_to_object( stream ); if ( writep( stream ) ) { - URL_FILE *output = stream_obj->payload.stream.stream; + URL_FILE *output = stream_obj->payload.stream.stream; if ( nl_before ) url_fputwc( L'\n', output ); - result = in_write( object, output, true, 0); + result = in_write( object, output, escape, 0 ); url_fputwc( nl_after ? L'\n' : L' ', output ); } else { @@ -267,12 +279,13 @@ struct pso_pointer print( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, - fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), t, - t, nil )); + fetch_arg( frame, 0 ), + fetch_arg( frame, 1 ), t, + t, nil ) ); struct pso_pointer result = write( next ); - dec_ref( next); + dec_ref( next ); return result; } @@ -284,12 +297,13 @@ struct pso_pointer princ( struct pso_pointer frame_pointer ) { struct pso4 *frame = pointer_to_pso4( frame_pointer ); struct pso_pointer next = inc_ref( make_frame( 5, frame_pointer, - fetch_arg( frame, 0 ), fetch_arg( frame, 1 ), - nil, t, nil )); + fetch_arg( frame, 0 ), + fetch_arg( frame, 1 ), + nil, t, nil ) ); - struct pso_pointer result = write( next ); + struct pso_pointer result = write( next ); - dec_ref( next); + dec_ref( next ); return result; } diff --git a/src/c/io/read.c b/src/c/io/read.c index 2b44d55..336311f 100644 --- a/src/c/io/read.c +++ b/src/c/io/read.c @@ -32,6 +32,7 @@ #include "memory/pso2.h" #include "memory/tags.h" +#include "payloads/character.h" #include "payloads/exception.h" #include "payloads/function.h" #include "payloads/integer.h" @@ -101,9 +102,12 @@ struct pso_pointer read_character( struct pso_pointer frame_pointer ) { struct pso_pointer result = nil; struct pso_pointer stream_pointer = fetch_arg( frame, 0 ); if ( readp( stream_pointer ) ) { - result = make_string( frame_pointer, - url_fgetwc( stream_get_url_file - ( stream_pointer ) ), nil ); + wint_t chr = url_fgetwc( stream_get_url_file( stream_pointer ) ); + result = make_character( frame_pointer, chr ); + +#ifdef DEBUG + debug_printf( DEBUG_IO, 0, L"\nRead character %lc\n", chr ); +#endif } return result; @@ -204,8 +208,7 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { } if ( c_nilp( readtable ) ) { - // TODO: check for the value of `*read-table*` in the environment and - // use that. + readtable = c_assoc( lisp_io_read_table, fetch_env( frame_pointer ) ); } if ( c_nilp( character ) ) { @@ -240,9 +243,9 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { ( frame_pointer, c ) ); inc_ref( next ); if ( iswdigit( c ) ) { - result = read_number( next ); + result = push_local( frame_pointer, read_number( next ) ); } else if ( iswalpha( c ) ) { - result = read_symbol( next ); + result = push_local( frame_pointer, read_symbol( next ) ); } else { // result = // throw_exception( @@ -260,10 +263,15 @@ struct pso_pointer read( struct pso_pointer frame_pointer ) { // ), // frame_pointer ); } - dec_ref( next ); +// dec_ref( next ); break; } } +#ifdef DEBUG + debug_print( L"Read object: ", DEBUG_IO, 0 ); + debug_print_object( result, DEBUG_IO, 0 ); + debug_println( DEBUG_IO ); +#endif return result; } diff --git a/src/c/memory/memory.c b/src/c/memory/memory.c index 658f649..bc1e722 100644 --- a/src/c/memory/memory.c +++ b/src/c/memory/memory.c @@ -76,9 +76,14 @@ struct pso_pointer initialise_memory( uint32_t node ) { /** * @brief Pop an object off the freelist for the specified `size_class`. + * + * There is no conventional way this function can signal an error. Any pointer + * it returns is potentially valid. However, every valid object must have an + * even numbered offset, so possibly {:node 0, :page 0, :offset 1} could be + * used as a magic marker to indicate total exhaustion of store for this size + * class. TODO: think about this. */ struct pso_pointer pop_freelist( uint8_t size_class ) { - // `t`, because if `allocate_page` fails it will be set to `nil`. struct pso_pointer result = t; if ( size_class <= MAX_SIZE_CLASS ) { @@ -103,16 +108,16 @@ struct pso_pointer pop_freelist( uint8_t size_class ) { /* the object ought already to have the right size class in its tag * because it was popped off the freelist for that size class. */ if ( object->header.tag.bytes.size_class != size_class ) { - // TODO: return an exception instead? Or warn, set it, and continue? + fwprintf( stderr, + L"WARNING: Unexpected size class %x. on free list for class %x while allocating.\n", + object->header.tag.bytes.size_class, size_class ); } /* the objext ought to have a reference count ot zero, because it's * on the freelist, but again we should sanity check. */ if ( object->header.count != 0 ) { fwprintf( stderr, - L"WARNING: Count of %d in newly allocated object at %d, %d, should be 0\n", - result.page, - result.offset, - object->header.count ); + L"\nWARNING: Count of %u in newly allocated object at %u, %u, should be 0\n", + object->header.count, result.page, result.offset ); object->header.count = 0; } } diff --git a/src/c/memory/page.c b/src/c/memory/page.c index 1d9eebd..b22846a 100644 --- a/src/c/memory/page.c +++ b/src/c/memory/page.c @@ -286,8 +286,9 @@ struct pso_pointer initialise_page( union page *page_addr, uint16_t page_index, result = nil; } - debug_print( (c_nilp( result ) && (page_index != 0)) ? L"fail.\n" : L"success.\n", DEBUG_ALLOC, - 0 ); + debug_print( ( c_nilp( result ) + && ( page_index != 0 ) ) ? L"fail.\n" : L"success.\n", + DEBUG_ALLOC, 0 ); return result; } @@ -311,7 +312,7 @@ struct pso_pointer allocate_page( uint8_t size_class ) { if ( npages_allocated < NPAGES ) { if ( size_class >= 2 && size_class <= MAX_SIZE_CLASS ) { - void *pg = malloc( sizeof( union page ) ); + void *pg = calloc( sizeof( union page ), 1 ); if ( pg != NULL ) { memset( pg, 0, sizeof( union page ) ); diff --git a/src/c/memory/pso.c b/src/c/memory/pso.c index 93696d7..c5fa2b8 100644 --- a/src/c/memory/pso.c +++ b/src/c/memory/pso.c @@ -4,9 +4,9 @@ * Paged space objects. * * Broadly, it should be save to cast any paged space object to a pso2, since - * that is the smallest actually used size class. This should work to extract - * the tag and size class fields from the header, for example. I'm not - * confident enough of my understanding of C to know whether it is similarly + * that is the smallest actually used size class. This should work to extract + * the tag and size class fields from the header, for example. I'm not + * confident enough of my understanding of C to know whether it is similarly * safe to cast something passed to you as a pso2 up to something larger, even * if you know from the size class field that it actually is something larger. * @@ -41,19 +41,22 @@ int allocation_table_allocated = 0; int allocation_table_freed = 1; -long int allocation_table[MAX_SIZE_CLASS +1][2]; +long int allocation_table[MAX_SIZE_CLASS + 1][2]; -void print_allocation_table() { - fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", stderr); - fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); - - for ( int s = 2; s<= MAX_SIZE_CLASS; s++) { - long int a = allocation_table[s][allocation_table_allocated]; - long int d = allocation_table[s][allocation_table_freed]; - long int r = a - d; - fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r); - } - fputws( L"| ============ | ============ | ============ | ============ |\n", stderr ); +void print_allocation_table( ) { + fputws( L"| Size class | Allocated | Deallocated | Remaining |\n", + stderr ); + fputws( L"| ============ | ============ | ============ | ============ |\n", + stderr ); + + for ( int s = 2; s <= MAX_SIZE_CLASS; s++ ) { + long int a = allocation_table[s][allocation_table_allocated]; + long int d = allocation_table[s][allocation_table_freed]; + long int r = a - d; + fwprintf( stderr, L"| %12d | %12ld | %12ld | %12ld |\n", s, a, d, r ); + } + fputws( L"| ============ | ============ | ============ | ============ |\n", + stderr ); } #endif @@ -77,64 +80,53 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car, return result; } - /** - * @brief Allocate an object of this `size_class` with this `tag`. - * - * All objects that are allocated (after completion of init)) should be linked - * onto the `locals` slot of a stack frame. This guarantees - * 1. that they do get `inc_ref`ed; and that, - * 2. if nothing else hangs onto them they will be reclaimed when that stack - * frame is reclaimed. - * for some objects (e.g. those cons cells on the locals list) this isn't - * possible due to infinite recursion, but those special cases need to be - * audited carefully. - * - * @param frame_pointer pointer to an active stack frame (or - * nil, but only during initialisation). - * @param tag The tag. Only the first three bytes will be used; - * @param size_class The size class for the object to be allocated; - * @return struct pso_pointer a pointer to the newly allocated object - */ +/** + * @brief Allocate an object of this `size_class` with this `tag`. + * + * All objects that are allocated (after completion of init)) should be linked + * onto the `locals` slot of a stack frame. This guarantees + * 1. that they do get `inc_ref`ed; and that, + * 2. if nothing else hangs onto them they will be reclaimed when that stack + * frame is reclaimed. + * for some objects (e.g. those cons cells on the locals list) this isn't + * possible due to infinite recursion, but those special cases need to be + * audited carefully. + * + * @param frame_pointer pointer to an active stack frame (or + * nil, but only during initialisation). + * @param tag The tag. Only the first three bytes will be used; + * @param size_class The size class for the object to be allocated; + * @return struct pso_pointer a pointer to the newly allocated object + */ struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, uint8_t size_class ) { - // todo: issue #21: must have stack frame passed in. + struct pso_pointer result = pop_freelist( size_class ); + if ( memory_initialised && c_nilp( frame_pointer ) ) { + fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr ); + } #ifdef DEBUG debug_printf( DEBUG_ALLOC, 0, - L"Allocating object of size class %d with tag `%s`... ", + L"\nAllocating object of size class %d with tag `%s`... ", size_class, tag ); #endif - struct pso_pointer result = pop_freelist( size_class ); - struct pso4 *frame = pointer_to_pso4( frame_pointer ); + struct pso2 *obj = pointer_to_object( result ); + strncpy( ( char * ) ( obj->header.tag.bytes.mnemonic ), tag, TAGLENGTH ); - if ( memory_initialised && c_nilp(frame_pointer)) { - fputws( L"WARNING: No stack frame passed to `allocate`.\n", - stderr ); - } - - if ( !c_nilp( result ) ) { - struct pso2 *obj = pointer_to_object(result); - strncpy((char*) (obj->header.tag.bytes. - mnemonic ), tag, TAGLENGTH ); - - debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", - result.page, result.offset ); - if ( stackp( frame_pointer ) ) { - // You can't make a stack frame in the middle of making a stack - // frame. Infinite recursion. So we have to cheat. - struct pso_pointer locals = cheaty_make_cons( result, - frame-> - payload.stack_frame. - locals ); - frame->payload.stack_frame.locals = locals; - } -#ifdef DEBUG - allocation_table[size_class][allocation_table_allocated]++; -#endif - } else { - // TODO: throw exception + debug_printf( DEBUG_ALLOC, 0, L"at page %d, offset %d... ", result.page, + result.offset ); + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + // You can't make a stack frame in the middle of making a stack + // frame. Infinite recursion. So we have to cheat. + struct pso_pointer locals = + cheaty_make_cons( result, frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = locals; } +#ifdef DEBUG + allocation_table[size_class][allocation_table_allocated]++; +#endif #ifdef DEBUG debug_print( exceptionp( result ) ? L"fail\n" : L"success\n", DEBUG_ALLOC, @@ -164,25 +156,40 @@ int payload_size( struct pso2 *object ) { * Returns the `pointer`. */ struct pso_pointer inc_ref( struct pso_pointer pointer ) { - struct pso2 *object = pointer_to_object( pointer ); + if ( c_nilp( pointer ) || c_truep( pointer ) ) { + /* You can't do this and there's no point trying or cluttering the + logs. */ + return pointer; + } else if ( freep( pointer ) ) { + fwprintf( stderr, + L"\nWARNING: Attempt to inc_ref a FREE object at %u, %u blocked\n", + pointer.page, pointer.offset ); + } else { + struct pso2 *object = pointer_to_object( pointer ); - if ( object->header.count < MAXREFERENCE ) { - object->header.count++; + if ( object->header.count < MAXREFERENCE ) { + object->header.count++; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nIncremented object of type %3.3s, size class %d, at page %u, offset %u to count %u", - ( ( char * ) &(object->header.tag.bytes.mnemonic[0] )), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count ); - if ( vectorpointp( pointer ) ) { debug_printf( DEBUG_ALLOC, 0, - L"; pointer to vector object of type %3.3s.\n", - ( ( char * ) - &( object->payload.vectorp.tag.bytes[0] ) ) ); - } else { - debug_println( DEBUG_ALLOC ); - } + L"\nIncremented object of type %3.3s, size class %d, " + L"at page %u, offset %u to count %u", ( ( char * ) + &( object-> + header. + tag.bytes. + mnemonic + [0] ) ), + ( int ) object->header.tag.bytes.size_class, + pointer.page, pointer.offset, object->header.count ); + if ( vectorpointp( pointer ) ) { + debug_printf( DEBUG_ALLOC, 0, + L"; pointer to vector object of type %3.3s.\n", + ( ( char * ) + &( object->payload.vectorp.tag.bytes[0] ) ) ); + } else { + debug_println( DEBUG_ALLOC ); + } #endif + } } return pointer; @@ -197,42 +204,48 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) { * Returns the `pointer`, or, if the object has been freed, a pointer to `nil`. */ struct pso_pointer dec_ref( struct pso_pointer pointer ) { - struct pso2 *object = pointer_to_object( pointer ); - - if (freep(pointer)) { - fputws( L"WARNING: SHOULDN'T: Decrementing free object?\n", stderr); - } + if ( c_nilp( pointer ) || c_truep( pointer ) ) { + /* You can't do this and there's no point trying or cluttering the + logs. */ + return pointer; + } else if ( freep( pointer ) ) { + fwprintf( stderr, + L"\nWARNING: Attempt to dec_ref a FREE object at %u, %u blocked\n", + pointer.page, pointer.offset ); + } else { + struct pso2 *object = pointer_to_object( pointer ); - if ( !c_nilp( pointer ) && object->header.count > 0 - && object->header.count != MAXREFERENCE ) { - object->header.count--; + if ( object->header.count > 0 && object->header.count != MAXREFERENCE ) { + object->header.count--; #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"\nDecremented object of type %3.3s, size class %d, at page %d, offset %d to count %d", - ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count ); - if ( vectorpointp( pointer ) ) { debug_printf( DEBUG_ALLOC, 0, - L"; pointer to vector object of type %3.3s.\n", - ( ( char * ) - &( object->payload.vectorp.tag.bytes ) ) ); - } else { - debug_println( DEBUG_ALLOC ); - } + L"\nDecremented object of type %3.3s, size class %d, " + L"at page %d, offset %d to count %d", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + ( int ) object->header.tag.bytes.size_class, + pointer.page, pointer.offset, object->header.count ); + if ( vectorpointp( pointer ) ) { + debug_printf( DEBUG_ALLOC, 0, + L"; pointer to vector object of type %3.3s.\n", + ( ( char * ) + &( object->payload.vectorp.tag.bytes ) ) ); + } else { + debug_println( DEBUG_ALLOC ); + } #endif + } + if ( object->header.count == 0 ) { + free_object( pointer ); + pointer = nil; + } } - if ( object->header.count == 0 ) { - free_object( pointer ); - pointer = nil; - } return pointer; } /** * @brief Prevent an object ever being dereferenced. - * + * * @param pointer pointer to an object to lock. * * @return the `pointer` @@ -257,24 +270,27 @@ struct pso_pointer free_object( struct pso_pointer pointer ) { result = destroy( pointer ); - /* will C just let me cheerfully walk off the end of the array I've declared? */ + /* will C just let me cheerfully walk off the end of the array I've + * declared? */ for ( int i = 0; i < array_size; i++ ) { object->payload.words[i] = 0; } - #ifdef DEBUG - debug_printf( DEBUG_ALLOC, 0, - L"Freeing object of type %3.3s, size class %d, at page %d, offset %d.\n", - ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), - (int)object->header.tag.bytes.size_class, - pointer.page, pointer.offset, object->header.count - ); - - allocation_table[size_class][allocation_table_freed]++; - #endif - - strncpy((char*) (object->header.tag.bytes. - mnemonic ), FREETAG, TAGLENGTH ); +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, 0, + L"Freeing object of type %3.3s, size class %d, at page %d, " + L"offset %d.\n", + ( ( char * ) ( object->header.tag.bytes.mnemonic ) ), + ( int ) object->header.tag.bytes.size_class, pointer.page, + pointer.offset, object->header.count ); + + allocation_table[size_class][allocation_table_freed]++; +#endif + + strncpy( ( char * ) ( object->header.tag.bytes.mnemonic ), FREETAG, + TAGLENGTH ); + object->header.count = ( uint8_t ) 0; + object->header.access = nil; push_freelist( pointer ); return result; diff --git a/src/c/memory/pso.h b/src/c/memory/pso.h index 45bfdce..8643163 100644 --- a/src/c/memory/pso.h +++ b/src/c/memory/pso.h @@ -28,6 +28,6 @@ struct pso_pointer lock_object( struct pso_pointer pointer ); struct pso_pointer free_object( struct pso_pointer p ); #ifdef DEBUG -void print_allocation_table(); +void print_allocation_table( ); #endif #endif diff --git a/src/c/ops/assoc.c b/src/c/ops/assoc.c index d61f6e8..aa425ea 100644 --- a/src/c/ops/assoc.c +++ b/src/c/ops/assoc.c @@ -11,6 +11,7 @@ #include +#include "debug.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso2.h" @@ -40,15 +41,31 @@ struct pso_pointer search( struct pso_pointer key, struct pso_pointer result = nil; bool found = false; +#ifdef DEBUG + debug_print( L"In search; key is: ", DEBUG_BIND, 0 ); + debug_print_object( key, DEBUG_BIND, 0 ); + debug_println( DEBUG_BIND ); +#endif + if ( consp( store ) ) { for ( struct pso_pointer cursor = store; consp( cursor ) && found == false; cursor = c_cdr( cursor ) ) { struct pso_pointer pair = c_car( cursor ); +#ifdef DEBUG + debug_print( L"Checking ", DEBUG_BIND, 2 ); + debug_print_object( pair, DEBUG_BIND, 0 ); +#endif if ( consp( pair ) && c_equal( c_car( pair ), key ) ) { found = true; result = return_key ? c_car( pair ) : c_cdr( pair ); +#ifdef DEBUG + debug_print( L" ...found!", DEBUG_BIND, 0 ); +#endif } +#ifdef DEBUG + debug_println( DEBUG_BIND ); +#endif } } diff --git a/src/c/ops/eq.c b/src/c/ops/eq.c index 60c5316..f350d5a 100644 --- a/src/c/ops/eq.c +++ b/src/c/ops/eq.c @@ -41,7 +41,7 @@ bool c_eq( struct pso_pointer a, struct pso_pointer b ) { } bool c_equal( struct pso_pointer a, struct pso_pointer b ) { - bool result = true; + bool result = false; if ( c_eq( a, b ) ) { result = true; @@ -73,6 +73,7 @@ bool c_equal( struct pso_pointer a, struct pso_pointer b ) { b = c_cdr( b ); } else { result = false; + break; } } result = result && c_nilp( a ) && c_nilp( b ); diff --git a/src/c/ops/eval_apply.c b/src/c/ops/eval_apply.c index c95513c..0c8d2a7 100644 --- a/src/c/ops/eval_apply.c +++ b/src/c/ops/eval_apply.c @@ -10,9 +10,11 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include "debug.h" #include "memory/node.h" #include "memory/pointer.h" #include "memory/pso.h" +#include "memory/pso2.h" #include "memory/pso3.h" #include "memory/pso4.h" #include "memory/tags.h" @@ -48,57 +50,67 @@ struct pso_pointer eval( struct pso_pointer frame_pointer ) { struct pso_pointer arg = fetch_arg( frame, 0 ); struct pso_pointer result = nil; - switch ( get_tag_value( arg ) ) { - // case CONSTV: - // result = eval_cons( frame, frame_pointer, env); - // break; - case INTEGERTV: - case KEYTV: - case STRINGTV: - // self evaluating - result = nil; - break; - case SYMBOLTV: - arg = c_assoc( arg, fetch_env( frame_pointer ) ); - break; - // case LAMBDATV: - // result = eval_lambda( frame, frame_pointer, env); - // break; - // case NLAMBDATV: - // result = eval_nlambda( frame, frame_pointer, env); - // break; - // case SPECIALTV: - // result = eval_special( frame, frame_pointer, env); - // break; - default: - arg = - make_exception( make_frame( 1, frame_pointer, - make_cons( frame_pointer, - c_string_to_lisp_string - ( frame_pointer, - L"Can't yet evaluate things of this type: " ), - arg ), - make_cons( frame_pointer, - make_cons - ( frame_pointer, - c_string_to_lisp_keyword - ( frame_pointer, - L"tag" ), - get_tag_string - ( frame_pointer, - arg ) ), nil ), - nil ) ); - } - - if ( exceptionp( arg ) ) { - struct pso3 *x = - ( struct pso3 * ) pointer_to_object_with_tag_value( arg, - EXCEPTIONTV ); - - if ( c_nilp( x->payload.exception.stack ) ) { - + if ( !c_nilp( arg ) ) { + switch ( get_tag_value( arg ) ) { + // case CONSTV: + // result = eval_cons( frame, frame_pointer, env); + // break; + case INTEGERTV: + case KEYTV: + case NILTV: + case STRINGTV: + // self evaluating + result = nil; + break; + case SYMBOLTV: + result = c_assoc( arg, fetch_env( frame_pointer ) ); + break; + // case LAMBDATV: + // result = eval_lambda( frame, frame_pointer, env); + // break; + // case NLAMBDATV: + // result = eval_nlambda( frame, frame_pointer, env); + // break; + // case SPECIALTV: + // result = eval_special( frame, frame_pointer, env); + // break; + default: +#ifdef DEBUG + struct pso2 *object = pointer_to_object( arg ); + debug_printf( DEBUG_EVAL, 0, + L"Can't yet evaluate objects of type %3.3s\n", + object->header.tag.bytes.mnemonic[0] ); + debug_print_object( arg, DEBUG_EVAL, 2 ); + debug_println( DEBUG_EVAL ); +#endif + result = make_exception( make_frame( 1, frame_pointer, + make_cons( frame_pointer, + c_string_to_lisp_string + ( frame_pointer, + L"Can't yet evaluate things of this type: " ), + arg ), + make_cons( frame_pointer, + make_cons + ( frame_pointer, + c_string_to_lisp_keyword + ( frame_pointer, + L"tag" ), + get_tag_string + ( frame_pointer, + arg ) ), + nil ), nil ) ); } } - return arg; + if ( exceptionp( result ) ) { + struct pso3 *x = + ( struct pso3 * ) pointer_to_object_with_tag_value( result, + EXCEPTIONTV ); + + if ( c_nilp( x->payload.exception.stack ) ) { + x->payload.exception.stack = frame_pointer; + } + } + + return result; } diff --git a/src/c/ops/repl.c b/src/c/ops/repl.c index a427a2b..4e8e5f1 100644 --- a/src/c/ops/repl.c +++ b/src/c/ops/repl.c @@ -72,10 +72,11 @@ void repl( struct pso_pointer frame_pointer ) { while ( readp( input_stream ) && !url_feof( stream_get_url_file( input_stream ) ) ) { - if ( show_prompt ) + if ( show_prompt ) { princ( make_frame( 2, frame_pointer, c_assoc( lisp_io_prompt, env ), output_stream ) ); + } /* the reason for initialising a new stack for each REPL input is to * be sure the old stack is fully torn down and reclaimed. Once I'm @@ -86,13 +87,21 @@ void repl( struct pso_pointer frame_pointer ) { consp( oblist ) ? oblist : make_cons( nil, oblist, nil ) ) ); - print( make_frame - ( 2, base_of_stack, - eval( make_frame - ( 1, base_of_stack, - read( make_frame - ( 1, base_of_stack, input_stream ) ) ) ), - output_stream ) ); + struct pso_pointer next = + inc_ref( make_frame( 1, base_of_stack, input_stream ) ); + struct pso_pointer read_value = inc_ref( read( next ) ); + dec_ref( next ); + + next = inc_ref( make_frame( 1, base_of_stack, read_value ) ); + struct pso_pointer eval_value = inc_ref( eval( next ) ); + dec_ref( next ); + dec_ref( read_value ); + + next = + inc_ref( make_frame + ( 2, base_of_stack, eval_value, output_stream ) ); + print( next ); + dec_ref( next ); dec_ref( base_of_stack ); } diff --git a/src/c/ops/stack_ops.c b/src/c/ops/stack_ops.c index 4d566cf..cd7fac1 100644 --- a/src/c/ops/stack_ops.c +++ b/src/c/ops/stack_ops.c @@ -8,9 +8,12 @@ */ #include "memory/node.h" +#include "memory/pointer.h" #include "memory/pso2.h" #include "memory/pso4.h" #include "memory/tags.h" + +#include "payloads/cons.h" #include "payloads/stack.h" /** @@ -54,3 +57,25 @@ struct pso_pointer fetch_env( struct pso_pointer frame_pointer ) { return stackp( frame_pointer ) ? pointer_to_pso4( frame_pointer )->payload.stack_frame.env : nil; } + +/** + * Push a binding (and therefore a reference) for this `local` onto the + * stack_frame indicated by this `frame_pointer`, thereby protecting the + * `local` from garbage collection until the frame itself is disposed of. + * + * This is a hack. For Lisp functions, where the stack frames are set up + * and torn down by eval/apply, it shouldn't be necessary. + */ +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ) { + if ( stackp( frame_pointer ) ) { + struct pso4 *frame = pointer_to_pso4( frame_pointer ); + + struct pso_pointer l = + make_cons( frame_pointer, local, + frame->payload.stack_frame.locals ); + frame->payload.stack_frame.locals = l; + } + + return local; +} diff --git a/src/c/ops/stack_ops.h b/src/c/ops/stack_ops.h index fb1c4cc..059f61e 100644 --- a/src/c/ops/stack_ops.h +++ b/src/c/ops/stack_ops.h @@ -29,4 +29,7 @@ struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ); struct pso_pointer fetch_env( struct pso_pointer frame_pointer ); +struct pso_pointer push_local( struct pso_pointer frame_pointer, + struct pso_pointer local ); + #endif diff --git a/src/c/payloads/exception.c b/src/c/payloads/exception.c index 33a0e4b..729e1f9 100644 --- a/src/c/payloads/exception.c +++ b/src/c/payloads/exception.c @@ -56,15 +56,17 @@ struct pso_pointer make_exception( struct pso_pointer frame_pointer ) { struct pso_pointer result = allocate( frame_pointer, EXCEPTIONTAG, 3 ); - if ( !c_nilp( result ) && !exceptionp( result ) ) { + if ( exceptionp( result ) ) { struct pso3 *object = ( struct pso3 * ) pointer_to_object( result ); - object->payload.exception.message = inc_ref(message); + object->payload.exception.message = inc_ref( message ); object->payload.exception.stack = - stackp( frame_pointer ) ? inc_ref(frame_pointer) : nil; + stackp( frame_pointer ) ? inc_ref( frame_pointer ) : nil; object->payload.exception.meta = ( consp( meta ) - || hashtabp( meta ) ) ? inc_ref(meta) : nil; - object->payload.exception.cause = exceptionp( cause ) ? inc_ref(cause) : nil; + || hashtabp( meta ) ) ? + inc_ref( meta ) : nil; + object->payload.exception.cause = + exceptionp( cause ) ? inc_ref( cause ) : nil; } return result; diff --git a/src/c/payloads/integer.c b/src/c/payloads/integer.c index 9b85b5a..71ed2c1 100644 --- a/src/c/payloads/integer.c +++ b/src/c/payloads/integer.c @@ -22,8 +22,6 @@ /** * Allocate an integer cell representing this `value` and return a pso_pointer to it. * @param value an integer value; - * @param more `nil`, or a pointer to the more significant cell(s) of this number. - * *NOTE* that if `more` is not `nil`, `value` *must not* exceed `MAX_INTEGER`. */ struct pso_pointer make_integer( struct pso_pointer frame_pointer, int64_t value ) { @@ -34,8 +32,8 @@ struct pso_pointer make_integer( struct pso_pointer frame_pointer, struct pso2 *cell = pointer_to_object( result ); cell->payload.integer.value = value; - debug_print( L"make_integer: returning\n", DEBUG_ALLOC, 0 ); - debug_dump_object( result, DEBUG_ALLOC, 0 ); + debug_printf( DEBUG_ALLOC, 0, L"\nmake_integer returning %ld\n", + cell->payload.integer.value ); return result; } diff --git a/src/c/payloads/stack.c b/src/c/payloads/stack.c index ed65024..c4b11c5 100644 --- a/src/c/payloads/stack.c +++ b/src/c/payloads/stack.c @@ -62,8 +62,8 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, } else { new_frame->payload.stack_frame.depth = 0; } - - new_frame->payload.stack_frame.previous = inc_ref( previous); + + new_frame->payload.stack_frame.previous = inc_ref( previous ); debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", new_frame->payload.stack_frame.depth ); @@ -129,7 +129,7 @@ struct pso_pointer make_frame_with_env( int arg_count, arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = inc_ref(previous); + prev_frame->payload.stack_frame.previous = inc_ref( previous ); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -203,7 +203,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer arg_count, new_pointer.page, new_pointer.offset ); #endif - prev_frame->payload.stack_frame.previous = inc_ref( previous); + prev_frame->payload.stack_frame.previous = inc_ref( previous ); if ( stackp( previous ) ) { new_frame->payload.stack_frame.depth = @@ -279,12 +279,12 @@ struct pso_pointer destroy_stack_frame( struct pso_pointer fp, dec_ref( frame->payload.stack_frame.arg[i] ); } - frame->payload.stack_frame.previous = nil; - frame->payload.stack_frame.function = nil; - frame->payload.stack_frame.more = nil; - frame->payload.stack_frame.locals = nil; - frame->payload.stack_frame.env = nil; - + frame->payload.stack_frame.previous = nil; + frame->payload.stack_frame.function = nil; + frame->payload.stack_frame.more = nil; + frame->payload.stack_frame.locals = nil; + frame->payload.stack_frame.env = nil; + frame->payload.stack_frame.args = 0; frame->payload.stack_frame.depth = 0; } diff --git a/src/c/psse.c b/src/c/psse.c index 38f7d96..bf7c745 100644 --- a/src/c/psse.c +++ b/src/c/psse.c @@ -21,6 +21,7 @@ #include "psse.h" #include "io/print.h" + #include "memory/node.h" #include "memory/pso.h" #include "memory/tags.h" @@ -77,11 +78,11 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; char *infilename = NULL; - - if ( initialise_io( ) != 0 ) { - fputs( "Failed to initialise I/O subsystem\n", stderr ); - exit( 1 ); - } + + if ( initialise_io( ) != 0 ) { + fputs( "Failed to initialise I/O subsystem\n", stderr ); + exit( 1 ); + } while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) { switch ( option ) { @@ -114,7 +115,7 @@ int main( int argc, char *argv[] ) { } setlocale( LC_ALL, "" ); - + oblist = initialise_node( 0 ); debug_print( L"Oblist: ", DEBUG_BOOTSTRAP, 0 ); debug_print_object( oblist, DEBUG_BOOTSTRAP, 0 ); @@ -134,18 +135,25 @@ int main( int argc, char *argv[] ) { stdout ); } - struct pso_pointer bootstrap_stack = inc_ref( - make_frame_with_env(1, nil, - consp - ( oblist ) ? oblist : make_cons(nil, oblist, nil), - show_prompt ? t : nil)); + struct pso_pointer bootstrap_stack = inc_ref( make_frame_with_env( 1, nil, + consp + ( oblist ) + ? oblist + : + make_cons + ( nil, + oblist, + nil ), + show_prompt + ? t : + nil ) ); repl( bootstrap_stack ); dec_ref( bootstrap_stack ); - dec_ref( oblist); + dec_ref( oblist ); #ifdef DEBUG - print_allocation_table(); + print_allocation_table( ); #endif