admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
d5cd64605d03e30565da0f2ac18d00bfe9c79f4e
LithosAnanake/v4/capsule/core.v4
T
rajamesandClaude Opus 5.5 0d91608f39 fix(v4.0.0): EMIT ran past the output buffer; a message's first word was read before there was room for the rest 
The two root causes behind what the reviews of the wait found, both in
the code as it stands.  Each with a check that failed first.

EMIT stored its character and only then looked whether the buffer was
exactly full.  A flush that ended in a fault -- the stack too deep to
begin a message -- left the buffer full, and the fault's own message was
then put past its end, with (OUT^) never again at the end to be flushed.
The 28 cells after the buffer happen to be unused, so nothing showed;
the wait had put the ports there, and the node blocked writing to one.
EMIT now sends a buffer it finds full before it stores.

AWAIT, and (GATE) when a neighbour is writing, read a message's first
word and then used stack that was not known to be there.  With 27 or 28
values on the stack, or 28 or 29 calls deep, a line typed during AWAIT
was taken and never answered.  (ROOM) tries six cells and four return
entries first: if they are not there the text ends 'Stack overflow' with
nothing read.  (GATE) tries the three cells its writing needs before a
first word goes; it was safe before only by the order things were done.

v4/tools/depthsweep.py runs every message path of the hosted product at
every depth of both stacks: each line typed must be answered and the
node must come back.  hosted-check runs it.

make -C v4 test and sanitize at both widths, hosted-check.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-08 11:46:05 -04:00

403 lines
18 KiB
Plaintext
Raw Blame History

\ core.v4 -- the core words the host-node capsules rest on.
\
\ Each is the definition DECOMPOSITION.md gives and the golden-model tests
\ execute (test_foundation.c, test_strings.c, test_terminal.c, test_pictured.c),
\ written here as text for the text assembler (v4/include/v4/text.h).
\
\ Constants the loader supplies: N-1 (cell bits - 1), NODE-ERROR, CONSOLE-TX,
\ CONSOLE-RX, CONSOLE-STATUS, BASE, (MSG), (REPLY), (ME), (OUT),
\ (OUT^), (CONSOLE), (ROUTES), (ROUTE#), (ROUTE-DEFAULT), (PRINT-TO),
\ (PRINT-PORT).
\
\ ERRORS (D-18). A word that finds an error takes its arguments off the stack
\ and stores a code in NODE-ERROR. On a node with a prompt that store is a
\ trap: the word goes no further, and the prompt prints the message for the
\ code and ERROR (quit.v4, (RAISED)). The codes:
\ 1 Negative count 2 Not a number 3 Number too long
\ 4 Not a character 5 Dictionary full 6 Name missing
\ 7 Control structure mismatch 8 Control structures too deep
\ 9 Shift count out of range 10 Protected word
\ 11 Division by zero (Q./) 12 Argument out of range
\ 13 Block out of range 14 No block is being loaded
\ 15 Deferred word not set 16 Not a word
\ 17 Storage refused 18 No one on that port
\ 19 Message refused 20 Node gone
\ 21 Interrupted
\ -1 the word has printed its own message
macro SWAP over push push drop pop pop endmacro
macro - push inv pop + inv endmacro \ x y -- x-y
macro NEGATE inv 1 + endmacro
macro NIP push drop pop endmacro
\ ---- section 4: multiply ------------------------------------------------
header UM*
: UM* ( u1 u2 -- ulo uhi )
over 1 and inv 1 + over 2/ and \ u1 u2 t0 t0 = u2 2/ if u1 odd
over a! N-1 push \ A: u2 R: loop count
push over 2/ pop \ u1 u2 s t0 s = u1 2/
L: +* unext \ u1 u2 s hi A: lo
push drop pop \ u1 u2 hi
2* a -if L0 drop 1 + jump L1 L0: drop L1: push
over -if L2 drop dup jump L3 L2: drop 0 L3: push
dup -if L4 drop over 1 and jump L5 L4: drop 0 L5:
pop + pop + push
and 1 and a 2* + pop ;
\ ---- section 5.7: doubles ------------------------------------------------
header D+
: D+ ( d1 d2 -- d3 )
push over push push drop pop \ al bl R: bh ah
over over xor -if L1
drop + -if C1 jump C0
L1: drop over -if L2
drop + jump C1
L2: drop +
C0: pop pop + ;
C1: pop pop + 1 + ;
header DNEGATE
: DNEGATE ( d -- -d )
inv over if L1 drop push inv 1 + pop ;
L1: drop 1 + ;
\ ---- section 5.3: bytes --------------------------------------------------
\ The shifts are written out, eight to a line, where DECOMPOSITION.md 5.3 has
\ a FOR ... UNEXT loop: a loop keeps its count on the return stack, and C@ and
\ C! are at the bottom of every chain of calls in the compiler capsule, where
\ there is not an entry to spare (D-2). The result is the same.
macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro
macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro
header C@
: C@ ( baddr -- c )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop @ 8/ 8/ 8/ 255 and ;
K2: drop @ 8/ 8/ 255 and ;
K1: drop @ 8/ 255 and ;
K0: drop @ 255 and ;
header C!
: C! ( c baddr -- )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop 8* 8* 8* 4278190080 and @ 4278190080 inv and + ! ;
K2: drop 8* 8* 16711680 and @ -16711681 and + ! ;
K1: drop 8* 65280 and @ -65281 and + ! ;
K0: drop 255 and @ -256 and + ! ;
\ ---- section 5.9: strings ------------------------------------------------
header CMOVE
: CMOVE ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push
over C@ over C! 1 + push 1 + pop pop -1 + jump OK
DONE: drop drop drop ;
\ ---- section 5.10: the console -------------------------------------------
\ ---- what a node prints (docs/v4.0.0/MESH.md section 6) ------------------------
\ A node has no console of its own. It does what a message asks, and what
\ it prints while doing it is sent as a message: to the node in (CONSOLE), or
\ if that is 0 to whoever sent the text; by the port that leads there, or if
\ this node knows of none, by the port the text came on. A message is seven words and then its text, four
\ characters to a word:
\ to, from, type, heat and TTL, ACL tag, sequence, length in characters
\ The types: 1 text to be interpreted 2 what a node printed 3 how the
\ text ended (one word of text: 0 QUIT, 1 completed, 2 an error).
\ The header of the message being served is in the seven cells (MSG); (REPLY)
\ is the address of the port it came on; (ME) is this node's number.
\
\ Characters are kept in (OUT), 256 of them, a character to a cell, and sent
\ when it is full and when the text has been done with (quit.v4). (OUT^)
\ is where the next goes.
\
\ THE STACK. What prints may be run with the data stack all but full: EMIT
\ has always needed one free cell and no more, and still does -- it keeps
\ the character and A on the return stack while it works. Sending needs
\ two.
\ FINDING THE WAY (MESH.md section 7). A node knows its ports and nothing of
\ the shape they are wired in. Whoever wires it tells it, for a node, which
\ port leads toward that node: the table (ROUTES), (ROUTE#) entries of a
\ node's number and a port's address; and (ROUTE-DEFAULT), the port for any
\ node that is not in the table, or 0.
\ ( node -- port | 0 ) the address of the port that leads toward the node
: (PORT-FOR)
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
0
NONE: drop drop (ROUTE-DEFAULT) a! @ ;
HIT: drop drop @+ pop drop ;
\ LOOKING BEFORE WRITING (MESH.md section 7a). A write waits until the
\ neighbour reads, and a node that is waiting to write reads nothing: two
\ neighbours that each began to write to the other would wait for ever. So
\ a node does not begin a message until it has looked, (GATE):
\ - while any neighbour is waiting to write to it, it takes that message
\ in and keeps it with the messages waiting, to deal with when it has
\ nothing else to do;
\ - then, if the neighbour it means to write to is waiting to read, it
\ writes;
\ - and if that neighbour is not, it writes all the same when the
\ neighbour's number is the higher of the two, and otherwise looks
\ again. Of two neighbours one only may wait to write to the other, and
\ it is the lower: so those that wait are waiting on ever higher
\ numbers, and the highest of them is not waiting to write; it is
\ looking, and takes in what is being written to it.
\ (WRITERS) and (READERS) are the node's two looks at its neighbours, a bit
\ for each port. (NEAR) is the number of the node on each port, told by
\ whoever wires it (NEIGHBOUR, quit.v4); a port not told of -- a device's
\ -- is written to only when what is there is waiting to read.
\
\ THE MESSAGES WAITING are kept in (MQ) .. (MQ-END), one after another,
\ going round: for each its seven words, the port it came on, and its text.
\ (MQ-HEAD) is where the oldest begins, (MQ-TAIL) where the next will go,
\ (MQ#) how many cells are taken. One that there is no room for is read to
\ its end and let go, and (LOST) counts it.
\ ( mask index -- bit )
: (BIT)
if Z -1 + FOR 2/ NEXT 1 and ;
Z: drop 1 and ;
\ ( mask -- index ) the lowest port in it; the mask is not zero
: (LOW)
0 push
L: dup 1 and if UP drop drop pop ;
UP: drop 2/ pop 1 + push jump L
\ ( w -- ) one more cell of the messages waiting. B is kept.
: (MQ!)
(MQ-TAIL) a! @ a! !+
a (MQ-END) xor if WRAP drop a jump SET
WRAP: drop (MQ)
SET: (MQ-TAIL) a! !
(MQ#) a! @ 1 + ! ;
\ ( -- w ) the oldest cell of the messages waiting, which goes
: (MQ@)
(MQ-HEAD) a! @ a! @+
a (MQ-END) xor if WRAP drop a jump SET
WRAP: drop (MQ)
SET: (MQ-HEAD) a! !
(MQ#) a! @ -1 + ! ;
\ REFUSALS (MESH.md section 7b). A message this node has no room for, or
\ no way to pass on, is let go and counted in (LOST); and its sender is
\ told, by a message of type 4, a NACK, whose one word is the node the
\ refused message was for. A node finds it has no room while it is taking
\ messages in so as to be free to write, where it cannot begin a message
\ of its own: so it notes what it owes, (OWE), in the eight pairs at
\ (OWED) -- whom it is owed to, and the node the message was for -- and
\ sends it when it next has nothing else to do, (PAY). With eight owed
\ already, one more is let go and counted. Nothing is owed for a NACK or
\ for a GONE, type 5: there is no NACK for a NACK. The last 36 cells of
\ the messages waiting are kept for those two types, so that ordinary
\ messages cannot take all the room.
\ ( to about -- ) a refusal is owed to the node `to`, about the node `about`.
\ Owed to this node itself -- its own message came back to it and was let
\ go here -- it is put with the messages waiting, as if it had come by a
\ port, in the room kept for refusals.
: (OWE)
over (ME) a! @ xor if SELF drop
(OWED#) a! @ -8 + -if NOROOM
drop (OWED#) a! @ 2* (OWED) + a!
push !+ pop !
(OWED#) a! @ 1 + ! ;
SELF: drop 1 (MQ#) a! @ + -MQ-ROOM + -if NOROOM
drop push (MQ!) (ME) a! @ (MQ!) 4 (MQ!) 0 (MQ!) 0 (MQ!) 0 (MQ!) 4 (MQ!) 0 (MQ!) pop (MQ!) ;
NOROOM: drop drop drop (LOST) a! @ 1 + ! ;
\ ( from to type -- ) a message of that type, from the one node for the
\ other, has been let go here. Whoever is waiting on it is told: its
\ sender; or, for a node's answer (type 3), the node the answer was for,
\ which is the one that waits. Nothing is owed for a NACK or a GONE.
: (TELL-OF)
dup -4 + if NOT -1 + if NOT drop
-3 + if ANSWER drop jump (OWE) \ to its sender, about whom it was for
ANSWER: drop SWAP jump (OWE) \ to whom it was for, about the node that answered
NOT: drop drop drop drop ;
\ ( port -- flag ) is there anything on that port, by its address?
: (THERE)
(PORT) - -PORTS - (READERS) b! @b SWAP jump (BIT)
\ ( port to -- ) the seven words of a message being taken in, and the
\ port, go into (MQ-HDR). B is at the port, by its address, and `to` is
\ the message's first word, already read from it.
: (TAKE-HDR)
(MQ-HDR) a! !+ 5 FOR @b !+ UNEXT ! ;
\ ( -- ) the message whose seven words are in (MQ-HDR) is kept with the
\ messages waiting: its text is read from the port B is at. A length
\ below zero, or above what a message carries, is kept as -1 with no text:
\ a longer one is read to its end first, so that what follows it is not
\ taken for a message.
: (TAKE-KEEP)
(MQ-HDR)+6 a! @ -if SIZED
drop -1 (MQ-HDR)+6 a! ! 0 jump COUNTED
SIZED: dup -1025 + -if LONG drop 3 + 2/ 2/ jump COUNTED
LONG: drop 3 + 2/ 2/ -1 + FOR @b drop UNEXT -1 (MQ-HDR)+6 a! ! 0
COUNTED: \ ( n ) how many words of text follow
dup (MQ#) a! @ + \ what it would come to
(MQ-HDR)+2 a! @ -4 + if KEPT-FOR -1 + if KEPT-FOR \ a NACK or a GONE may use the room kept for them
drop -MQ-ORDINARY + jump ROOM
KEPT-FOR: drop -MQ-ROOM +
ROOM: -if FULL
drop push
(MQ-HDR) a! @ (MQ!) (MQ-HDR)+1 a! @ (MQ!) (MQ-HDR)+2 a! @ (MQ!) (MQ-HDR)+3 a! @ (MQ!)
(MQ-HDR)+4 a! @ (MQ!) (MQ-HDR)+5 a! @ (MQ!) (MQ-HDR)+6 a! @ (MQ!) (MQ-HDR)+7 a! @ (MQ!)
pop if NOTEXT -1 + FOR @b (MQ!) NEXT ;
NOTEXT: drop ;
FULL: drop if READ -1 + FOR @b drop UNEXT jump LOSE
READ: drop
LOSE: (LOST) a! @ 1 + !
(MQ-HDR)+1 a! @ (MQ-HDR) a! @ (MQ-HDR)+2 a! @ jump (TELL-OF)
\ ( port to -- ) take in a message and keep it
: (TAKE) (TAKE-HDR) jump (TAKE-KEEP)
\ ( -- ) ROOM TO TAKE A MESSAGE IN. Once a message's first word has been
\ read the rest must be: whoever is writing it waits for that, and a fault
\ in the middle leaves the two out of step. Taking one in and keeping it
\ needs five cells of the data stack and four entries of the return stack.
\ So before a first word is read from within text -- where the stacks may
\ be as deep as the text has made them -- six and four are tried: if they
\ are not there the fault comes here, with nothing read, and the text
\ ends "Stack overflow" as it would have (MESH.md 7c.6).
: (ROOM)
0 0 0 0 0 0 drop drop drop drop drop drop
0 push 0 push 0 push 0 push pop drop pop drop pop drop pop drop ;
\ ( port -- ) wait until a message may be begun on the port, by its
\ address, taking in whatever is being written to this node meanwhile; and
\ leave B at the port. The port is kept in (GATE-PORT), not on the stack:
\ this is run with the stack as full as EMIT may be.
: (GATE)
(GATE-PORT) a! !
0 0 0 drop drop drop \ what follows the message's first word needs three cells: tried here, before it goes
L: (WRITERS) b! @b if QUIET
(ROOM) (LOW) (PORT) + dup b! @b (TAKE) jump L
QUIET: drop
(GATE-PORT) a! @ (PORT) - (NEAR) + a! @ if ASK
(ME) a! @ - -if GO jump ASK \ its number less this node's
GO: drop (GATE-PORT) a! @ b! ; \ the neighbour's is the higher
ASK: drop
(READERS) b! @b (GATE-PORT) a! @ (PORT) - (BIT) if NOTYET
drop (GATE-PORT) a! @ b! ; \ it is waiting to read
NOTYET: drop
(READERS) b! @b (GATE-PORT) a! @ (PORT) - -PORTS - (BIT) if NOONE \ is there anything on the port at all?
drop jump L
NOONE: drop NODE-ERROR b! 18 !b ; \ no: what waits here would wait for ever
\ ( type -- ) words 1 to 5 of a message this node sends: from, type, and
\ the three that are carried and not used yet. Its caller has put B at the
\ port and sent word 0, whom it is to, and sends the length and the text.
\ Each write waits for the neighbour to take it.
: (HDR)
(ME) a! @ !b \ from
!b \ type
16 !b 0 !b 0 !b ; \ how many nodes may pass it on (the TTL: MESH.md 7b); ACL tag; sequence
\ PAYING WHAT IS OWED does not hold this node up. A refusal is sent if the
\ neighbour it goes by is reading at this moment. If it is not, and its
\ number is the higher, the refusal is written all the same, as any message
\ would be (MESH.md 7a): that neighbour takes it in when it next looks. If
\ its number is the lower, or it has not been told of, the refusal stays
\ owed, and this node goes on with what it has to do and tries again; it
\ does not sleep while it owes one (quit.v4, (IDLE)). One there is no way
\ for, or whose way is a port with nothing on it, is let go and counted.
\ ( k -- ) the k-th refusal owed is done with: the last takes its place
: (PAID)
(OWED#) a! @ -1 + dup !
2* (OWED) + a! @+ @
push push 2* (OWED) + a! pop !+ pop ! ;
\ ( k -- ) send the k-th refusal owed, if it can go now
: (PAY1)
dup 2* (OWED) + a! @+ @ \ k to about
over (PORT-FOR) if NOWAY \ k to about port
dup (THERE) if GONE
drop (READERS) b! @b over (PORT) - (BIT) if BUSY
drop
WRITE: b! \ k to about B: the port
SWAP !b 4 (HDR) 4 !b !b \ k to; from, type 4; four characters; about
jump (PAID)
BUSY: drop \ it is not reading:
dup (PORT) - (NEAR) + a! @ if LEAVE \ k to about port near
(ME) a! @ - -if BLIND jump LEAVE \ its number less this node's
BLIND: drop jump WRITE \ the higher: it will take it in
LEAVE: drop drop drop drop drop ;
GONE: drop
NOWAY: drop drop drop (LOST) a! @ 1 + ! jump (PAID)
\ ( -- ) send every refusal this node owes that can go now
: (PAY)
(OWED#) a! @ if NONE -1 +
FOR pop dup push (PAY1) NEXT ;
NONE: drop ;
\ ( -- ) send what has been printed, to where (PRINT-TO) says, by the port
\ (PRINT-PORT): its length, then its characters, four to a word, the first
\ lowest. quit.v4 sets those two when text for this node arrives.
: (FLUSH-OUT)
(OUT^) a! @ (OUT) xor if NONE drop
(PRINT-PORT) a! @ (GATE) (PRINT-TO) a! @ !b
2 (HDR)
(OUT^) a! @ (OUT) - dup !b
3 + 2/ 2/ -1 + (OUT) a!
FOR @+ @+ 8* + @+ 8* 8* + @+ 8* 8* 8* + !b NEXT
(OUT) (OUT^) a! ! ;
NONE: drop ;
\ EMIT puts the character with what has been printed. Everything the node
\ prints goes through EMIT. A is kept: the words that print have always
\ been free to use it across an EMIT. As v3, only the low 8 bits of the
\ character are printed.
\ A BUFFER FOUND FULL is sent first. It is full when a flush of it ended
\ in a fault -- the stack too deep to begin a message -- and what is printed
\ next is that fault's own message: put where (OUT^) points, it would go
\ past the buffer's end, and (OUT^) would never again be at the end to be
\ flushed (MESH.md 7c.6).
header EMIT
: EMIT ( c -- )
255 and a push push \ A, and then the character, to the return stack
(OUT^) b! @b (OUT)+256 xor if STALE drop jump PUT
STALE: drop (FLUSH-OUT)
PUT:
(OUT^) b! @b a! pop !+ a !b \ the character goes where (OUT^) points, which moves on
a (OUT)+256 xor if FULL drop pop a! ;
FULL: drop (FLUSH-OUT) pop a! ;
header KEY
: KEY ( -- c )
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
WAIT: drop jump L
header CR
: CR ( -- ) 10 jump EMIT
header SPACE
: SPACE ( -- ) 32 jump EMIT
header COUNT
: COUNT ( baddr -- baddr+1 c ) dup C@ push 1 + pop ;
header TYPE
: TYPE ( baddr u -- )
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK
DONE: drop drop ;
\ ( x -- ) up to four characters packed in one cell, the first in the low
\ byte: how the capsule prints its own short messages, a literal at a time.
: (EMIT4)
L: if DONE dup EMIT 8/ jump L
DONE: drop ;
\ ---- section 5.8: the number base ----------------------------------------
: (BASE) ( -- b ) \ BASE, or 10 when it is outside 2 .. 36
BASE b! @b dup -2 + -if L1 drop drop 10 ;
L1: drop dup -37 + -if L2 drop ;
L2: drop drop 10 ;
Reference in New Issue View Git Blame Copy Permalink