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

Good news: only one test failing. Bad news: it's nlambda.

Browse source
This commit is contained in:
Simon Brooke 2018-12-28 21:21:11 +00:00
parent e52ccce0eb
commit 96dad29f91
8 changed files with 80 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
src/debug.c
View file

@ -42,6 +42,21 @@ void debug_print( wchar_t *message, int level ) {
#endif
}
/**
* print a line feed to stderr, if `verbosity` matches `level`.
* `verbosity is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_println( int level ) {
#ifdef DEBUG
if ( level & verbosity ) {
fwide( stderr, 1 );
fputws( L"\n", stderr );
}
#endif
}
/**
* `wprintf` adapted for the debug logging system. Print to stderr only
* `verbosity` matches `level`. All other arguments as for `wprintf`.

1
src/debug.h
View file

@ -25,6 +25,7 @@
extern int verbosity;
void debug_print( wchar_t *message, int level );
void debug_println( int level );
void debug_printf( int level, wchar_t * format, ...);
void debug_print_object( struct cons_pointer pointer, int level );
void debug_dump_object( struct cons_pointer pointer, int level );

4
src/memory/dump.c
View file

@ -62,11 +62,13 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
print( output, pointer);
fputws( L"\n", output);
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );

80
src/memory/stack.c
View file

@ -26,6 +26,18 @@
#include "stack.h"
#include "vectorspace.h"
void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) {
debug_printf(DEBUG_STACK, L"Setting register %d to ", reg);
debug_print_object(value, DEBUG_STACK);
debug_println(DEBUG_STACK);
frame->arg[reg++] = value;
inc_ref(value);
if (reg > frame->args) {
frame->args = reg;
}
}
/**
* get the actual stackframe object from this `pointer`, or NULL if
* `pointer` is not a stackframe pointer.
@ -53,32 +65,24 @@ 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_STACK );
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
debug_dump_object( result, DEBUG_STACK );
debug_dump_object( result, DEBUG_ALLOC );
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 );
// 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_STACK );
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
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_STACK );
inc_ref( previous );
/*
* clearing the frame with memset would probably be slightly quicker, but
@ -88,13 +92,12 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
frame->function = NIL;
frame->args = 0;
debug_print( L"make_empty_frame: about to initialise arg registers\n",
DEBUG_STACK );
for ( int i = 0; i < args_in_frame; i++ ) {
set_reg( frame, i, NIL );
frame->arg[i] = NIL;
}
}
debug_print( L"Leaving make_empty_frame\n", DEBUG_STACK );
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC);
return result;
}
@ -121,8 +124,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
} else {
struct stack_frame *frame = get_stack_frame( result );
for ( frame->args = 0; frame->args < args_in_frame && consp( args );
frame->args++ ) {
while ( frame->args < args_in_frame && consp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
@ -134,23 +136,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct cons_pointer arg_frame_pointer = make_empty_frame( result );
inc_ref( arg_frame_pointer );
if ( nilp( arg_frame_pointer ) ) {
result =
make_exception( c_string_to_lisp_string
( 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 =
lisp_eval( arg_frame, arg_frame_pointer, env );
struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env);
if ( exceptionp( val ) ) {
result = val;
break;
@ -160,11 +146,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
set_reg( frame, frame->args, val );
}
dec_ref( arg_frame_pointer );
args = cell.payload.cons.cdr;
}
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
@ -175,10 +159,10 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
inc_ref( more );
}
}
}
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
}
}
debug_print( L"Leaving make_stack_frame\n", DEBUG_STACK );
return result;
}
@ -206,8 +190,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
} else {
struct stack_frame *frame = get_stack_frame( result );
for ( frame->args = 0; frame->args < args_in_frame && !nilp( args );
frame->args++ ) {
while ( frame->args < args_in_frame && !nilp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
@ -222,11 +205,10 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
frame->more = args;
inc_ref( args );
}
}
}
debug_print( L"make_special_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
}
}
debug_print( L"Leaving make_special_frame\n", DEBUG_STACK );
return result;
}

4
src/memory/stack.h
View file

@ -39,7 +39,9 @@
* set a register in a stack frame. Alwaye use this macro to do so,
• because that way we can be sure the inc_ref happens!
*/
#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value);
struct stack_frame *get_stack_frame( struct cons_pointer pointer );

6
src/ops/intern.c
View file

@ -111,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
debug_print(L"Binding ", DEBUG_ALLOC);
debug_print_object(key, DEBUG_ALLOC);
debug_print(L" to ", DEBUG_ALLOC);
debug_print_object(value, DEBUG_ALLOC);
debug_println(DEBUG_ALLOC);
return make_cons( make_cons( key, value ), store );
}

38
src/ops/lispops.c
View file

@ -94,6 +94,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
next->args = 1;
result = lisp_eval( next, next_pointer, env );
@ -253,25 +254,15 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
debug_print(L"Entering c_apply\n", DEBUG_EVAL);
struct cons_pointer result = NIL;
/* construct a child frame and within it evaluate the first argument - the
* argument in the function position. */
struct cons_pointer fn_frame_pointer = make_empty_frame( frame_pointer );
inc_ref( fn_frame_pointer );
struct stack_frame *fn_frame = get_stack_frame( fn_frame_pointer );
set_reg( fn_frame, 0, c_car( frame->arg[0] ) );
struct cons_pointer fn_pointer =
lisp_eval( fn_frame, fn_frame_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( fn_frame_pointer );
}
eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
if ( exceptionp( fn_pointer ) ) {
result = fn_pointer;
} else {
struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] );
@ -327,11 +318,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct stack_frame *next =
get_stack_frame( frame_pointer );
result = eval_lambda( fn_cell, next, next_pointer, env );
if ( !exceptionp( result ) ) {
dec_ref( next_pointer );
}
}
}
break;
case SPECIALTV:
{
@ -341,17 +330,16 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( frame_pointer );
result =
( *fn_cell.payload.special.executable ) ( next,
( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ),
next_pointer,
env );
if ( !exceptionp( result ) ) {
debug_print(L"Special form returning: ", DEBUG_EVAL);
debug_print_object(result, DEBUG_EVAL);
debug_println(DEBUG_EVAL);
dec_ref( next_pointer );
}
}
}
break;
default:
{
@ -367,7 +355,11 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = throw_exception( message, frame_pointer );
}
}
dec_ref( fn_frame_pointer );
}
debug_print(L"c_apply: returning: ", DEBUG_EVAL);
debug_print_object(result, DEBUG_EVAL);
debug_println(DEBUG_EVAL);
return result;
}

16
src/repl.c
View file

@ -54,14 +54,9 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct cons_pointer repl_eval( struct cons_pointer input ) {
debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( input, NIL ), oblist);
if ( !nilp( frame_pointer ) ) {
inc_ref(frame_pointer);
result = lisp_eval( get_stack_frame( frame_pointer ), frame_pointer, oblist );
result = eval_form( NULL, NIL, input, oblist );
dec_ref( frame_pointer );
}
debug_print( L"repl_eval: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );
@ -75,13 +70,8 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) {
debug_print( L"Entered repl_print\n", DEBUG_REPL );
debug_dump_object( value, DEBUG_REPL );
struct cons_pointer result = NIL;
struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons( value, NIL ), oblist);
if ( !nilp( frame_pointer ) ) {
inc_ref(frame_pointer);
result = lisp_print( get_stack_frame( frame_pointer ), frame_pointer, oblist );
dec_ref( frame_pointer );
}
struct cons_pointer result =
print( pointer2cell( stream_pointer ).payload.stream.stream, value );
debug_print( L"repl_print: returning\n", DEBUG_REPL );
debug_dump_object( result, DEBUG_REPL );