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

Tactical commit: things in 'stack_ops' really didn't belong in ops; moving.

Browse source
This commit is contained in:
Simon Brooke 2026-05-05 17:21:16 +01:00
parent d2efc8ba78
commit 4d480798e8
10 changed files with 333 additions and 231 deletions
Download patch file Download diff file Expand all files Collapse all files

8
Makefile
View file

@ -51,8 +51,14 @@ clean:
coredumps: coredumps:
ulimit -c unlimited ulimit -c unlimited
repl: repl: Makefile $(TARGET)
$(TARGET) -ps1000 2> tmp/psse.log $(TARGET) -ps1000 2> tmp/psse.log
run: Makefile $(TARGET)
$(TARGET) -ps1000v1023 2> tmp/psse.log
install: Makefile $(TARGET)
cp $(TARGET) ~/bin
-include $(DEPS) -include $(DEPS)

142
docs/State-of-play.md
View file

@ -1,5 +1,147 @@
# State of Play # State of Play
## 20260505
### The stack frame corruption(?) bug
I have a weird bug in `read_symbol`, which at present I'm not understanding.
Stack frames in `0.1.0` are [paged space objects](https://www.journeyman.cc/blog/posts-output/2026-03-23-Paged-space-objects/), like all other objects; specifically they are objects of size class 4, which is to say they have a payload size of fourteen words. The first eight arguments to the function being called (which in most cases will be all the arguments) are held directly in the frame.
`read_symbol` expects its arguments to be as follows (I'm numbering from zero here, although I consider that perverse and confusing, because the substrate language is C which uses numbering from zero:)
| Argument | Expected value | Expected type |
| -------- | --------------- | ------------------------------------ |
| 0 | input stream | input stream |
| 1 | read table | store (cons, hashtable or namespace) |
| 2 | first character | character object |
`read_symbol` then reads characters sequentially from the stream until it encounters a white-space character; for each character it reads, it creates a symbol object representing that character, and conses that object onto the list of the characters it has read so far. So if the user has typed
> xyz
the internal representation is now a sequence
```lisp
(z y x)
```
Obviously, this now has to be reversed. So `read_symbol` then calls `reverse`. But wait! Because we're still in the bootstrap layer, the version of `read_symbol` I'm talking about is written in C. So *at the time of writing* it actually calls a wrapper function called `c_reverse` which builds the Lisp stack frame for `reverse` and then calls `reverse` with that stack frame. There was an earlier version of `c_reverse` which failed to create a new stack frame, and which would account for the bug I'm seeing; but that version has been replaced and the current version does certainly create the new stack frame:
```c
/**
* @brief reverse a sequence.
*
* A sequence is a list or a string-like-thing. A dotted pair is not a
* sequence.
*
* @param sequence a pointer to a sequence.
* @return a sequence like the `sequence` passed, but reversed; or `nil` if
* the argument was not a sequence.
*/
struct pso_pointer c_reverse( struct pso_pointer frame_pointer,
struct pso_pointer sequence ) {
struct pso_pointer result = nil;
if ( stackp( frame_pointer ) ) {
result = reverse( make_frame(1, frame_pointer, sequence) );
}
return result;
}
```
So, I can see in the debugger that the sequence created in `read_symbol` is passed to `c_reverse` as the sequence argument; I can see it is put into the new frame as the first (index 0) argument; the new frame is directly passed into reverse. Reverse expects the argument in its stack frame to look like this:
| Argument | Expected value | Expected type |
| -------- | -------------- | ------------------------------------------ |
| 0 | sequence | sequence (cons, keyword, string or symbol) |
Reverse throws an exception:
```lisp
<exception: ("Invalid object in sequence")>
```
D'oh! And, of course, in trying to explain the bug, I've found the bug. It wasn't what I thought it was, so I was looking in the wrong place. It was this:
```diff
struct pso_pointer sequence =
fetch_arg( pointer_to_pso4( frame_pointer ), 0 );
- for ( struct pso_pointer cursor = sequence; !c_nilp( sequence );
+ for ( struct pso_pointer cursor = sequence; !c_nilp( cursor );
cursor = c_cdr( cursor ) ) {
struct pso2 *object = pointer_to_object( cursor );
switch ( get_tag_value( cursor ) ) {
```
I was checking for `nil` on the sequence, which obviously didn't change, not on the cursor, which did. D'oh!
### About debuggers
I switched to Eclipse for this session, because Eclipse has really good, really easy to use, debugger integration. But I don't, as I said yesterday, much like Eclipse. It is too helpful; it gets in the way too much.
Zed, Gram, Gnome Builder and VS Codium (discussed yesterday) all claim to have debugger integration, and I'm pretty sure the debugger used in all cases is the [GNU debugger, `gdb`](https://sourceware.org/gdb/) (edited: I'm wrong. Zed, and so presumably also Gram, use [`lldb`](https://lldb.llvm.org/)). `Gdb` is an excellent debugger with a truly atrocious user interface, but fortunately there's a large range of tools which wrap more or less good user interfaces around `gdb`, of which I use (and like) ['seer'](https://github.com/epasveer/seer). However it's *much* more productive to have your debugger integrated with your editor.
I've tried this morning to get each of these to enter a useful debugging session. It has taken some work. Gnome Builder fails (for me) because although selecting `Run with Debugger` from the `run` menu does start both a `psse` session and a `gdb` session, and although terminating the `psse` session does show `[Inferior 1 (process 248474) exited normally]` on the GDB console, when I attempt to set a breakpoint (you don't seem to be able to set on in the GUI), I get the following:
```
> break src/c/ops/eval_apply.c:784
Make breakpoint pending on future shared library load? (y or [n]) [answered N; input not from terminal]
> n
Cannot execute this command without a live selected thread.
```
So there is something alive there, and probably with a bit of struggle I could make it work.
Zed and Gram are much the same, because Gram is a fork of Zed. Zed appears(?) to copy VS Codium's (and thus VS Code's) approach to interacting with `gdb`. VS Codium *appears*(?) to need some sort of JSON configuration in `launch.json`. I've tried this:
```json
{
// Use IntelliSense to learn about possible attributes.
// Hover to view descriptions of existing attributes.
// For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387
"version": "0.2.0",
"configurations": [
{
"name": "PSSE Debug (gdb Attach)",
"type": "cppdbg",
"request": "attach",
"program": "target/psse",
// "args": ["-p", "-s1000", "-v1023"],
"processId": "${command:pickProcess}",
"MIMode": "gdb",
"setupCommands": [
{
"description": "Enable pretty-printing for gdb",
"text": "-enable-pretty-printing",
"ignoreFailures": true
}
]
}
]
}
```
It does not work, at least not in VS Codium.
Zed's debugger [configuration documentation](https://zed.dev/docs/debugger) is better. Using it, I was able to compose this stanza:
```json
{
"label": "PSSE Start debugger config",
"adapter": "CodeLLDB",
"request": "launch",
"program": "target/psse",
"cwd": "$ZED_WORKTREE_ROOT",
},
```
which successfully launches a debugger session. It's easy to set breakpoints in the editor windows; it's probably as easy to find your way around variables and stack frames as it is in Eclipse or Seer, once you get used to it (I haven't yet). I haven't yet worked out how to get it to automatically rebuild before running if it needs to do so, but I expect I shall. This is usable; but I shall need to get used to it.
## 20260504 ## 20260504
My monster, she builds! My monster, she builds!

15
src/c/environment/environment.c
View file

@ -36,7 +36,7 @@ bool environment_initialised = false;
/** /**
* @brief Initialise a minimal environment, so that Lisp can be bootstrapped. * @brief Initialise a minimal environment, so that Lisp can be bootstrapped.
* *
* @param node the index of the node we are initialising. * @param node the index of the node we are initialising.
* @return a proto-environment on success, else an exception. * @return a proto-environment on success, else an exception.
*/ */
@ -81,10 +81,11 @@ struct pso_pointer initialise_environment( uint32_t node ) {
} }
} }
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
frame_pointer = inc_ref( make_frame(0, nil));
result = result =
lisp_bind( make_frame lisp_bind( make_frame
( 3, frame_pointer, ( 3, frame_pointer,
c_string_to_lisp_symbol( frame_pointer, U"niU" ), nil, c_string_to_lisp_symbol( frame_pointer, U"nil" ), nil,
nil ) ); nil ) );
debug_print( U"Environment after binding `nil`: ", DEBUG_BOOTSTRAP, debug_print( U"Environment after binding `nil`: ", DEBUG_BOOTSTRAP,
0 ); 0 );
@ -101,14 +102,14 @@ struct pso_pointer initialise_environment( uint32_t node ) {
debug_print( U"\nEnvironment initialised successfully.\n", debug_print( U"\nEnvironment initialised successfully.\n",
DEBUG_BOOTSTRAP, 0 ); DEBUG_BOOTSTRAP, 0 );
}
initialise_privileged_keywords(frame_pointer); initialise_privileged_keywords(frame_pointer);
result = initialise_function_bindings(push_local( result = inc_ref( initialise_function_bindings(push_local(
frame_pointer, make_frame_with_env(0, frame_pointer, result))); frame_pointer, make_frame_with_env(0, frame_pointer, result))));
dec_ref(frame_pointer); dec_ref(frame_pointer);
}
return result; return result;
} }

4
src/c/io/read.c
View file

@ -143,8 +143,8 @@ struct pso_pointer read_number( struct pso_pointer frame_pointer ) {
? 0 : pointer_to_object( character )->payload.character.character; ? 0 : pointer_to_object( character )->payload.character.character;
URL_FILE *input = pointer_to_object( stream )->payload.stream.stream; URL_FILE *input = pointer_to_object( stream )->payload.stream.stream;
for ( ; iswdigit( c ); c = url_fgetwc( input ) ) { for ( ; iswdigit( c ) || c == L','; c = url_fgetwc( input ) ) {
value = ( value * base ) + ( ( int ) c - ( int ) L'0' ); if ( iswdigit( c ) ){value = ( value * base ) + ( ( int ) c - ( int ) L'0' );}
} }
url_ungetwc( c, input ); url_ungetwc( c, input );

81
src/c/memory/pso.c
View file

@ -60,6 +60,9 @@ void print_allocation_table( ) {
} }
#endif #endif
struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag,
uint8_t size_class);
/** /**
* @brief a means of creating a cons cell without using a stack frame, to * @brief a means of creating a cons cell without using a stack frame, to
* prevent runaway recursion. * prevent runaway recursion.
@ -71,7 +74,7 @@ void print_allocation_table( ) {
*/ */
struct pso_pointer cheaty_make_cons( struct pso_pointer car, struct pso_pointer cheaty_make_cons( struct pso_pointer car,
struct pso_pointer cdr ) { struct pso_pointer cdr ) {
struct pso_pointer result = allocate( nil, CONSTAG, 2 ); struct pso_pointer result = cheaty_allocate( nil, CONSTAG, 2 );
struct pso2 *obj = pointer_to_object( result ); struct pso2 *obj = pointer_to_object( result );
obj->payload.cons.car = car; obj->payload.cons.car = car;
@ -80,6 +83,46 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car,
return result; return result;
} }
/**
* Special variant of allocate especially for cheaty_make_cons, so we don't
* get excessive spurius missing stack frame warnings. Not to be called
* outside this file!
*/
struct pso_pointer cheaty_allocate(struct pso_pointer frame_pointer, char *tag,
uint8_t size_class) {
struct pso_pointer result = pop_freelist( size_class );
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating object of size class %d with tag `%s`... ",
size_class, tag );
#endif
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 ) ) {
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,
0 );
#endif
return result;
}
/** /**
* @brief Allocate an object of this `size_class` with this `tag`. * @brief Allocate an object of this `size_class` with this `tag`.
* *
@ -100,42 +143,14 @@ struct pso_pointer cheaty_make_cons( struct pso_pointer car,
*/ */
struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag, struct pso_pointer allocate( struct pso_pointer frame_pointer, char *tag,
uint8_t size_class ) { uint8_t size_class ) {
struct pso_pointer result = pop_freelist( size_class );
if ( memory_initialised && c_nilp( frame_pointer ) ) { if ( memory_initialised && c_nilp( frame_pointer ) ) {
fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr ); fputws( L"\nWARNING: No stack frame passed to `allocate`.\n", stderr );
} }
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating object of size class %d with tag `%s`... ",
size_class, tag );
#endif
struct pso2 *obj = pointer_to_object( result ); return cheaty_allocate(frame_pointer, tag, size_class);
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 ) ) {
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,
0 );
#endif
return result;
} }
int payload_size( struct pso2 *object ) { int payload_size( struct pso2 *object ) {
// TODO: Unit tests DEFINITELY needed! // TODO: Unit tests DEFINITELY needed!
int sc = object->header.tag.bytes.size_class; int sc = object->header.tag.bytes.size_class;
@ -157,7 +172,7 @@ int payload_size( struct pso2 *object ) {
*/ */
struct pso_pointer inc_ref( struct pso_pointer pointer ) { struct pso_pointer inc_ref( struct pso_pointer pointer ) {
if ( c_nilp( pointer ) || c_truep( pointer ) ) { if ( c_nilp( pointer ) || c_truep( pointer ) ) {
/* You can't do this and there's no point trying or cluttering the /* You can't do this and there's no point trying or cluttering the
logs. */ logs. */
return pointer; return pointer;
} else if ( freep( pointer ) ) { } else if ( freep( pointer ) ) {
@ -204,7 +219,7 @@ struct pso_pointer inc_ref( struct pso_pointer pointer ) {
*/ */
struct pso_pointer dec_ref( struct pso_pointer pointer ) { struct pso_pointer dec_ref( struct pso_pointer pointer ) {
if ( c_nilp( pointer ) || c_truep( pointer ) ) { if ( c_nilp( pointer ) || c_truep( pointer ) ) {
/* You can't do this and there's no point trying or cluttering the /* You can't do this and there's no point trying or cluttering the
logs. */ logs. */
return pointer; return pointer;
} else if ( freep( pointer ) ) { } else if ( freep( pointer ) ) {

6
src/c/ops/reverse.c
View file

@ -26,6 +26,7 @@
#include "ops/string_ops.h" #include "ops/string_ops.h"
#include "ops/truth.h" #include "ops/truth.h"
#include "payloads/stack.h"
/** /**
* @brief reverse a sequence * @brief reverse a sequence
@ -36,7 +37,7 @@ struct pso_pointer reverse( struct pso_pointer frame_pointer ) {
struct pso_pointer result = nil; struct pso_pointer result = nil;
struct pso_pointer sequence = struct pso_pointer sequence =
fetch_arg( pointer_to_pso4( frame_pointer ), 0 ); fetch_arg( pointer_to_pso4( frame_pointer ), 0 );
for ( struct pso_pointer cursor = sequence; !c_nilp( sequence ); for ( struct pso_pointer cursor = sequence; !c_nilp( cursor );
cursor = c_cdr( cursor ) ) { cursor = c_cdr( cursor ) ) {
struct pso2 *object = pointer_to_object( cursor ); struct pso2 *object = pointer_to_object( cursor );
switch ( get_tag_value( cursor ) ) { switch ( get_tag_value( cursor ) ) {
@ -104,7 +105,8 @@ struct pso_pointer c_reverse( struct pso_pointer frame_pointer,
struct pso_pointer result = nil; struct pso_pointer result = nil;
if ( stackp( frame_pointer ) ) { if ( stackp( frame_pointer ) ) {
result = reverse( frame_pointer ); result = reverse( make_frame(1, frame_pointer, sequence) );
} }
return result; return result;
} }

80
src/c/ops/stack_ops.c
View file

@ -1,80 +0,0 @@
/**
* payloads/stack.c
*
* The execution stack.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#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"
/**
* @brief The maximum depth of stack before we throw an exception.
*
* `0` is interpeted as `unlimited`.
*/
uint32_t stack_limit = 0;
/**
* Fetch a pointer to the value of the local variable at this index.
*
* TODO: I think the first argument would be better as a pso_pointer.
*/
struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) {
struct pso_pointer result = nil;
// TODO check that the frame is indeed a frame!
if ( index < frame->payload.stack_frame.args ) {
result = frame->payload.stack_frame.arg[index];
} else {
struct pso_pointer p = frame->payload.stack_frame.more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer_to_object( p )->payload.cons.cdr;
}
result = pointer_to_object( p )->payload.cons.car;
}
return result;
}
/**
* @brief Return the environment from the stack frame identified by this
* `frame_pointer`
*
* @param frame_pointer a pointer to a stack frame.
*/
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;
}

35
src/c/ops/stack_ops.h
View file

@ -1,35 +0,0 @@
/**
* ops/stack_ops.h
*
* Operations on a Lisp stack frame.
*
* (c) 2026 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __psse_ops_stack_ops_h
#define __psse_ops_stack_ops_h
#include "memory/pointer.h"
#include "memory/pso4.h"
/*
* number of arguments stored in a stack frame
*/
#define args_in_frame 8
/**
* @brief The maximum depth of stack before we throw an exception.
*
* `0` is interpeted as `unlimited`.
*/
extern uint32_t stack_limit;
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

173
src/c/payloads/stack.c
View file

@ -26,6 +26,69 @@
#include "ops/list_ops.h" #include "ops/list_ops.h"
#include "ops/stack_ops.h" #include "ops/stack_ops.h"
/**
* @brief The maximum depth of stack before we throw an exception.
*
* `0` is interpeted as `unlimited`.
*/
uint32_t stack_limit = 0;
/**
* Fetch a pointer to the value of the local variable at this index.
*
* TODO: I think the first argument would be better as a pso_pointer.
*/
struct pso_pointer fetch_arg( struct pso4 *frame, unsigned int index ) {
struct pso_pointer result = nil;
// TODO check that the frame is indeed a frame!
if ( index < frame->payload.stack_frame.args ) {
result = frame->payload.stack_frame.arg[index];
} else {
struct pso_pointer p = frame->payload.stack_frame.more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer_to_object( p )->payload.cons.cdr;
}
result = pointer_to_object( p )->payload.cons.car;
}
return result;
}
/**
* @brief Return the environment from the stack frame identified by this
* `frame_pointer`
*
* @param frame_pointer a pointer to a stack frame.
*/
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;
}
/** /**
* @brief Add an argument to this (already initialised) stack frame, updating * @brief Add an argument to this (already initialised) stack frame, updating
* the args count. * the args count.
@ -60,22 +123,11 @@ struct pso_pointer add_arg( struct pso_pointer frame_pointer, struct pso_pointer
} }
/** /**
* @brief Construct a stack frame with this `previous` pointer, and arguments * @brief internal shared guts of make_frame variants. **Does not** set up the
* taken from the remaining arguments to this function, which should all be * `env` pointer of the new frame -- callers are responsible for doing so.
* struct pso_pointer.
*
* @param arg_count the count of arguments to the Lisp function.
* @param previous the parent stack frame.
* @param ... the arguments to the Lisp function, all of which must be of type
* `struct pso_pointer`.
* @return struct pso_pointer a pointer to a populated stack frame which may be
* passed to the Lisp function.
*/ */
struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, struct pso_pointer in_make_frame( int arg_count, struct pso_pointer previous,
... ) { va_list args ) {
va_list args;
va_start( args, previous );
/* NOTE! It is really important not to `push_local` the new_pointer here, /* NOTE! It is really important not to `push_local` the new_pointer here,
* since that would stop stack frames and all the temporary objects they * since that would stop stack frames and all the temporary objects they
* curate ever being garbage collected! */ * curate ever being garbage collected! */
@ -94,13 +146,13 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
struct pso4 *prev_frame = pointer_to_pso4( previous ); struct pso4 *prev_frame = pointer_to_pso4( previous );
new_frame->payload.stack_frame.depth = new_frame->payload.stack_frame.depth =
prev_frame->payload.stack_frame.depth + 1; prev_frame->payload.stack_frame.depth + 1;
new_frame->payload.stack_frame.env = new_frame->payload.stack_frame.previous = inc_ref( previous );
prev_frame->payload.stack_frame.env;
} else { } else {
new_frame->payload.stack_frame.depth = 0; new_frame->payload.stack_frame.depth = 0;
new_frame->payload.stack_frame.previous = nil;
} }
new_frame->payload.stack_frame.previous = inc_ref( previous ); new_frame->payload.stack_frame.env = nil;
debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n",
new_frame->payload.stack_frame.depth ); new_frame->payload.stack_frame.depth );
@ -136,6 +188,34 @@ struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
return new_pointer; return new_pointer;
} }
/**
* @brief Construct a stack frame with this `previous` pointer, and arguments
* taken from the remaining arguments to this function, which should all be
* struct pso_pointer.
*
* @param arg_count the count of arguments to the Lisp function.
* @param previous the parent stack frame.
* @param ... the arguments to the Lisp function, all of which must be of type
* `struct pso_pointer`.
* @return struct pso_pointer a pointer to a populated stack frame which may be
* passed to the Lisp function.
*/
struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
... ) {
va_list args;
va_start( args, previous );
struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args);
struct pso4* new_frame = pointer_to_pso4(new_pointer);
new_frame->payload.stack_frame.env = stackp(previous) ?
inc_ref(pointer_to_pso4(previous)->payload.stack_frame.env) : nil;
va_end(args);
return new_pointer;
}
/** /**
* @brief variant of make_frame with an explicit replacement environment, to * @brief variant of make_frame with an explicit replacement environment, to
* be called by functions like `binding` which add bindings to their upstack * be called by functions like `binding` which add bindings to their upstack
@ -158,60 +238,10 @@ struct pso_pointer make_frame_with_env( int arg_count,
va_list args; va_list args;
va_start( args, env ); va_start( args, env );
struct pso4 *prev_frame = pointer_to_pso4( previous ); struct pso_pointer new_pointer = in_make_frame( arg_count, previous, args);
/* NOTE! It is really important not to `push_local` the new_pointer here, pointer_to_pso4(new_pointer)->payload.stack_frame.env = inc_ref( env);
* since that would stop stack frames and all the temporary objects they
* curate ever being garbage collected! */
struct pso_pointer new_pointer = allocate( previous, STACKTAG, 4 );
struct pso4 *new_frame = pointer_to_pso4( new_pointer );
#ifdef DEBUG va_end(args);
debug_printf( DEBUG_ALLOC, 0,
L"\nAllocating stack frame with %d arguments at page %d, "
L"offset %d...\n",
arg_count, new_pointer.page, new_pointer.offset );
#endif
prev_frame->payload.stack_frame.previous = inc_ref( previous );
if ( stackp( previous ) ) {
new_frame->payload.stack_frame.depth =
prev_frame->payload.stack_frame.depth + 1;
} else {
new_frame->payload.stack_frame.depth = 0;
}
debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n",
new_frame->payload.stack_frame.depth );
int cursor = 0;
new_frame->payload.stack_frame.args = arg_count;
new_frame->payload.stack_frame.env = env;
for ( ; cursor < arg_count && cursor < args_in_frame; cursor++ ) {
struct pso_pointer argument = va_arg( args, struct pso_pointer );
new_frame->payload.stack_frame.arg[cursor] = inc_ref( argument );
}
if ( cursor < arg_count ) {
struct pso_pointer more_args = nil;
for ( ; cursor < arg_count; cursor++ ) {
more_args =
make_cons( previous, va_arg( args, struct pso_pointer ),
more_args );
}
new_frame->payload.stack_frame.more = c_reverse( previous, more_args );
} else {
for ( ; cursor < args_in_frame; cursor++ ) {
new_frame->payload.stack_frame.arg[cursor] = nil;
}
}
debug_printf( DEBUG_ALLOC, 1,
L"Allocation of stack frame at page %d, offset %d completed.\n",
new_pointer.page, new_pointer.offset );
return new_pointer; return new_pointer;
} }
@ -258,6 +288,7 @@ struct pso_pointer make_frame_with_arglist_and_env( struct pso_pointer
inc_ref( prev_frame->payload.stack_frame.env ); inc_ref( prev_frame->payload.stack_frame.env );
} else { } else {
new_frame->payload.stack_frame.depth = 0; new_frame->payload.stack_frame.depth = 0;
new_frame->payload.stack_frame.env = nil;
} }
debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n", debug_printf( DEBUG_ALLOC, 1, L"depth is %d...\n",

20
src/c/payloads/stack.h
View file

@ -41,6 +41,26 @@ struct stack_frame_payload {
uint32_t depth; uint32_t depth;
}; };
/*
* number of arguments stored in a stack frame
*/
#define args_in_frame 8
/**
* @brief The maximum depth of stack before we throw an exception.
*
* `0` is interpeted as `unlimited`.
*/
extern uint32_t stack_limit;
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 );
struct pso_pointer make_frame( int arg_count, struct pso_pointer previous, struct pso_pointer make_frame( int arg_count, struct pso_pointer previous,
... ); ... );