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

Much progress! Half the unit tests pass.

Browse source
This commit is contained in:
Simon Brooke 2018-12-28 15:50:37 +00:00
parent 75abfb4050
commit e52ccce0eb
17 changed files with 296 additions and 253 deletions
Download patch file Download diff file Expand all files Collapse all files

29
src/memory/conspage.c
View file

@ -18,6 +18,7 @@
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
/**
@ -65,7 +66,7 @@ void make_cons_page( ) {
cell->count = MAXREFERENCE;
cell->payload.free.car = NIL;
cell->payload.free.cdr = NIL;
fwprintf( stderr, L"Allocated special cell NIL\n" );
debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" );
break;
case 1:
/*
@ -79,7 +80,7 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1
};
fwprintf( stderr, L"Allocated special cell T\n" );
debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
break;
}
} else {
@ -96,7 +97,7 @@ void make_cons_page( ) {
initialised_cons_pages++;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages );
exit( 1 );
@ -128,10 +129,8 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
#ifdef DEBUG
fwprintf( stderr, L"Freeing cell " );
dump_object( stderr, pointer );
#endif
debug_printf( DEBUG_ALLOC, L"Freeing cell " );
debug_dump_object( pointer, DEBUG_ALLOC );
switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other
@ -165,10 +164,8 @@ void free_cell( struct cons_pointer pointer ) {
case VECTORPOINTTV:
/* for vector space pointers, free the actual vector-space
* object. Dangerous! */
#ifdef DEBUG
fwprintf( stderr, L"About to free vector-space object at %ld\n",
debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address );
#endif
//free( ( void * ) cell->payload.vectorp.address );
break;
@ -181,12 +178,12 @@ void free_cell( struct cons_pointer pointer ) {
cell->payload.free.cdr = freelist;
freelist = pointer;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset );
}
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset );
}
@ -218,13 +215,11 @@ struct cons_pointer allocate_cell( char *tag ) {
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
#ifdef DEBUG
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset );
#endif
} else {
fwprintf( stderr, L"WARNING: Allocating non-free cell!" );
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
}
}
@ -243,7 +238,7 @@ void initialise_cons_pages( ) {
make_cons_page( );
conspageinitihasbeencalled = true;
} else {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
}
}

25
src/memory/consspaceobject.c
View file

@ -20,6 +20,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "print.h"
#include "stack.h"
@ -178,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on
* strings are quite massively off. */
* strings are quite massively off. Fix is probably
* cell->payload.string.cdr = tsil */
cell->payload.string.cdr.offset = tail.offset;
} else {
fwprintf( stderr,
L"Warning: only NIL and %s can be appended to %s\n",
// TODO: should throw an exception!
debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag );
}
@ -249,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) {
}
/**
* Return a lisp string representation of this old skool ASCII string.
* Return a lisp string representation of this wide character string.
*/
struct cons_pointer c_string_to_lisp_string( char *string ) {
struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
struct cons_pointer result = NIL;
for ( int i = strlen( string ); i > 0; i-- ) {
result = make_string( ( wint_t ) string[i - 1], result );
for ( int i = wcslen( string ); i > 0; i-- ) {
result = make_string( string[i - 1], result );
}
return result;
}
/**
* Return a lisp symbol representation of this old skool ASCII string.
* Return a lisp symbol representation of this wide character string.
*/
struct cons_pointer c_string_to_lisp_symbol( char *symbol ) {
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) {
struct cons_pointer result = NIL;
for ( int i = strlen( symbol ); i > 0; i-- ) {
result = make_symbol( ( wint_t ) symbol[i - 1], result );
for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( symbol[i - 1], result );
}
return result;

4
src/memory/consspaceobject.h
View file

@ -582,11 +582,11 @@ struct cons_pointer make_write_stream( FILE * output );
/**
* Return a lisp string representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_string( char *string );
struct cons_pointer c_string_to_lisp_string( wchar_t *string );
/**
* Return a lisp symbol representation of this old skool ASCII string.
*/
struct cons_pointer c_string_to_lisp_symbol( char *symbol );
struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol );
#endif

26
src/memory/dump.c
View file

@ -55,11 +55,8 @@ void dump_string_cell( FILE * output, wchar_t *prefix,
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
L"\t%4.4s (%d) at page %d, offset %d count %u\n",
cell.tag.bytes,
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
@ -91,6 +88,8 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
case NILTV:
break;
case RATIOTV:
fwprintf( output,
L"\t\tRational cell: value %ld/%ld, count %u\n",
@ -101,6 +100,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
break;
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
@ -111,26 +111,28 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
case TRUETV:
break;
case VECTORPOINTTV:{
fwprintf( output,
L"\t\tPointer to vector-space object at %p\n",
cell.payload.vectorp.address );
struct vector_space_object *vso = cell.payload.vectorp.address;
fwprintf( output,
L"\t\tVector space object of type %4.4s, payload size %d bytes\n",
&vso->header.tag.bytes, vso->header.size );
L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n",
&vso->header.tag.bytes, vso->header.tag.value, vso->header.size );
if (stackframep(vso)) {
dump_frame(output, pointer);
}
switch ( vso->header.tag.value ) {
case STACKFRAMETV:
dump_frame( output, pointer );
break;
default:
fputws( L"(Unknown vector type)\n", output );
break;
}
}
break;
default:
fputws( L"(Unknown cons space type)\n", output );
case WRITETV:
fwprintf( output, L"\t\tOutput stream\n" );
break;
}
}

57
src/memory/stack.c
View file

@ -32,24 +32,15 @@
*/
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL;
debug_print
( L"get_stack_frame: about to get a pointer to the vector space object\n",
DEBUG_ALLOC );
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
debug_print( L"get_stack_frame: got a pointer, about to test it\n",
DEBUG_ALLOC );
if ( vectorpointp( pointer ) && stackframep( vso ) ) {
debug_print
( L"get_stack_frame: pointer is good, about to set the result\n",
DEBUG_ALLOC );
result = ( struct stack_frame * ) &( vso->payload );
fwprintf( stderr, L"get_stack_frame: all good, returning %p\n",
debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n",
result );
} else {
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_ALLOC );
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
}
return result;
@ -62,31 +53,31 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
debug_print( L"Entering make_empty_frame\n", DEBUG_STACK );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
debug_dump_object( result, DEBUG_ALLOC );
debug_dump_object( result, DEBUG_STACK );
fwprintf( stderr,
debug_printf( DEBUG_STACK,
L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
pointer_to_vso( result )->header.size,
&pointer_to_vso( result )->header.tag.bytes );
if ( !nilp( result ) ) {
debug_print( L"make_empty_frame: about to call get_stack_frame\n",
DEBUG_ALLOC );
DEBUG_STACK );
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
fwprintf( stderr,
debug_printf( DEBUG_STACK,
L"make_empty_frame: about to set previous to %4.4s\n",
&pointer2cell( previous ).tag.bytes );
frame->previous = previous;
debug_print( L"make_empty_frame: about to call inc_ref\n",
DEBUG_ALLOC );
DEBUG_STACK );
inc_ref( previous );
/*
@ -98,12 +89,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->args = 0;
debug_print( L"make_empty_frame: about to initialise arg registers\n",
DEBUG_ALLOC );
DEBUG_STACK );
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL );
}
}
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK );
return result;
}
@ -119,13 +110,13 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_stack_frame\n", DEBUG_ALLOC );
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( c_string_to_lisp_string( "Memory exhausted." ),
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
@ -149,11 +140,13 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
if ( nilp( arg_frame_pointer ) ) {
result =
make_exception( c_string_to_lisp_string
( "Memory exhausted." ), previous );
( L"Memory exhausted." ), previous );
break;
} else {
struct stack_frame *arg_frame =
get_stack_frame( arg_frame_pointer );
debug_print( L"Setting argument 0 of arg_frame to ", DEBUG_STACK);
debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( arg_frame, 0, cell.payload.cons.car );
struct cons_pointer val =
@ -162,6 +155,8 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
result = val;
break;
} else {
debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args);
debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( frame, frame->args, val );
}
@ -180,10 +175,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
inc_ref( more );
}
debug_dump_object( result, DEBUG_ALLOC );
debug_dump_object( result, DEBUG_STACK );
}
}
debug_print( L"Leaving make_stack_frame\n", DEBUG_ALLOC );
debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK );
return result;
}
@ -199,14 +194,14 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_special_frame\n", DEBUG_ALLOC );
debug_print( L"Entering make_special_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( "Memory exhausted." ),
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
@ -228,10 +223,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
inc_ref( args );
}
debug_dump_object( result, DEBUG_ALLOC );
debug_dump_object( result, DEBUG_STACK );
}
}
debug_print( L"Leaving make_special_frame\n", DEBUG_ALLOC );
debug_print( L"Leaving make_special_frame\n", DEBUG_STACK );
return result;
}
@ -263,6 +258,7 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
fwprintf( output, L"Stack frame with %d arguments:\n", frame->args);
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
@ -274,16 +270,19 @@ void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
if (!nilp(frame->more))
{
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
}
}
void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.message );
fwprintf( output, L"\n" );
fputws( L"\n", output );
dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else {

24
src/memory/vectorspace.c
View file

@ -21,7 +21,7 @@
#include "conspage.h"
#include "consspaceobject.h"
#include "dump.h"
#include "debug.h"
#include "vectorspace.h"
@ -32,17 +32,17 @@
* vector-space object, NOT `VECTORPOINTTAG`.
*/
struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
fputws( L"Entered make_vec_pointer\n", stderr );
debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address );
cell->payload.vectorp.address = address;
fwprintf( stderr, L"make_vec_pointer: all good, returning pointer to %p\n",
debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address );
dump_object( stderr, pointer );
debug_dump_object( pointer, DEBUG_ALLOC );
return pointer;
}
@ -55,41 +55,41 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
* Returns NIL if the vector could not be allocated due to memory exhaustion.
*/
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
fputws( L"Entered make_vso\n", stderr );
debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
fputws( L"make_vso: about to malloc\n", stderr );
debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) {
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"make_vso: about to write tag '%s' into vso at %p\n", tag,
vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso );
dump_object( stderr, result );
debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
vso->header.size = payload_size;
#ifdef DEBUG
fwprintf( stderr,
debug_printf( DEBUG_ALLOC,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
&vso->header.tag.bytes, total_size, vso->header.size, vso,
&vso->payload );
if ( padded != total_size ) {
fwprintf( stderr, L"\t\tPadded from %d to %d\n",
debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
total_size, padded );
}
#endif
}
#ifdef DEBUG
fwprintf( stderr, L"make_vso: all good, returning pointer to %p\n",
debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address );
#endif