Robert Allan JamesandClaude Sonnet 5
aafcce4320
process.4th is dead per task 0.1's reachability check (156d1642): zero
EXEC sites anywhere, and its four words (SPAWN/PAUSE/RESUME/KILL-VM)
have zero callers outside the file itself. Deleted outright.
EVENT-EMIT/EVENT-WAIT/EVENT-DRAIN (messaging.4th Block 5030) had
exactly one live caller -- process.4th, per FABRIC-3.5.md SXXXIII.3 --
so they go with it. Block 5030 was self-contained (nothing else in
it), so the whole block was removed rather than edited down.
mkcapsule --lint capsules/ clean, 37 files / 0 violations (was 38).
Three-arch boot clean: amd64/aarch64/riscv64 all reach [zuse@Hera] ok>,
zero UNKNOWN WORD. dict_hash moved for Hermes and Artemis (both load
messaging.4th) but is identical across all three architectures, which
is the invariant that matters, not an unchanging absolute value
(SXXII.4). Hera's own PARITY:M7.1a snapshot is unchanged since it fires
before any capsule loads.
capsule-reserved.txt and MANIFEST.md's stale block-4055/2049 entries
still untouched -- tasks 0.5 and 0.6, now unblocked since both strips
are done.
Authorized by Captain Bob ("Yes, you may continue.").
Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
492 lines
15 KiB
Forth
492 lines
15 KiB
Forth
Block 5003
|
|
( common:messaging.4th -- generic per-VM messaging vocab. )
|
|
1 CONSTANT SPAWN-EVENT
|
|
2 CONSTANT PAUSE-EVENT
|
|
3 CONSTANT RESUME-EVENT
|
|
4 CONSTANT KILL-EVENT
|
|
0 CONSTANT CH-NEGOTIATING
|
|
1 CONSTANT CH-OPEN
|
|
2 CONSTANT CH-CLOSING
|
|
9 CONSTANT MSG-CELLS
|
|
6 CONSTANT CH-CELLS
|
|
2 CONSTANT MBR-CELLS
|
|
32 CONSTANT MSG-MAX
|
|
16 CONSTANT CH-MAX
|
|
64 CONSTANT MBR-MAX
|
|
65208 CONSTANT Q-DECAY
|
|
255 CONSTANT MSG-DELIVERED
|
|
Block 5038
|
|
( CONSOLE-CMD-EVENT: console-VM -> paired user-VM command )
|
|
( relay message type, async MSG-SEND/MSG-DELIVER. )
|
|
7 CONSTANT CONSOLE-CMD-EVENT
|
|
( ELEVATE-REQUEST: H.5/H.8 -- word-ACL elevation ask, )
|
|
( carried to Zuse via CH-REQUEST. See SEND-ELEVATE- )
|
|
( REQUEST/ELEVATE-GRANT below and in zuse-eligibility.4th. )
|
|
8 CONSTANT ELEVATE-REQUEST
|
|
Block 5041
|
|
( BLK-ATTACH-EVENT: Hera -> Artemis storage-attach request, )
|
|
( and Artemis -> Hera ack. Payload is FORTH text, executed )
|
|
( by the receiver, same as every other message here -- see )
|
|
( HERA-BLK-ATTACH-REQ (artemis:init.4th) and BLK-ATTACH-ACK )
|
|
( (repl.c). Messaging-migration decision, Bob, 2026-09-07: )
|
|
( Hera keeps polling/sig-checking; the storage-registration )
|
|
( step (blk_subsys_attach_device) moves to a real message )
|
|
( instead of a direct C call, so identity birth only )
|
|
( proceeds once Artemis confirms storage succeeded. )
|
|
9 CONSTANT BLK-ATTACH-EVENT
|
|
Block 5004
|
|
( StadiumBehaviour tags, match stadium.h's enum )
|
|
0 CONSTANT SB-MIGRATE
|
|
1 CONSTANT SB-DELIVER
|
|
2 CONSTANT SB-EXPIRE
|
|
3 CONSTANT SB-COOL
|
|
-1 CONSTANT STADIUM-NONE
|
|
( per-item admission heat for MSG-SEND/CH-ACCEPT. )
|
|
( Remaining reservoir after COMMON-CH's Q.1/3 floor, split )
|
|
( evenly across MSG-MAX messages + non-COMMON CH-MAX-1 slots. )
|
|
Q.1 Q.1 3 / - MSG-MAX CH-MAX 1- + / CONSTANT Q.SLOT
|
|
Block 5005
|
|
( arenas. heat/capacity via Stadium; MBR keeps its own )
|
|
( free list (not part of heat economy). )
|
|
CREATE MSG-ARENA MSG-MAX MSG-CELLS * CELLS ALLOT
|
|
CREATE CH-ARENA CH-MAX CH-CELLS * CELLS ALLOT
|
|
CREATE MBR-ARENA MBR-MAX MBR-CELLS * CELLS ALLOT
|
|
VARIABLE MSG-ALLOC-SLOT
|
|
VARIABLE CH-ALLOC-SLOT
|
|
VARIABLE MBR-FREE-HEAD
|
|
VARIABLE MSG-SEQ
|
|
VARIABLE CH-ACTIVE
|
|
VARIABLE COMMON-CH
|
|
VARIABLE MY-CH-ID
|
|
Block 5006
|
|
( VM routing table. SXIX: 16 slots, not 8 -- see FABRIC-3.md. )
|
|
( Hera/Hermes/Artemis stay 0/1/2 (artemis:init.4th depends on )
|
|
( it); identities get NEW slots 3-10, never renumbered. )
|
|
16 CONSTANT VM-MAX
|
|
CREATE VM-NAME-ADDRS VM-MAX CELLS ALLOT
|
|
CREATE VM-NAME-LENS VM-MAX CELLS ALLOT
|
|
: VM-NAME-REG ( addr u idx -- )
|
|
DUP VM-MAX >= IF DROP 2DROP EXIT THEN
|
|
>R R@ CELLS VM-NAME-LENS + !
|
|
R> CELLS VM-NAME-ADDRS + ! ;
|
|
Block 5042
|
|
( doe-idx (std79-doe.fth ID-NAME) -> msg-idx: 1..8 -> 3..10. )
|
|
: DOE-IDX>MSG-IDX ( doe-idx -- msg-idx ) 2 + ;
|
|
: VM-NAMES-INIT ( -- )
|
|
S" Hera" 0 VM-NAME-REG
|
|
S" Hermes" 1 VM-NAME-REG
|
|
S" Artemis" 2 VM-NAME-REG
|
|
S" rajames" 1 DOE-IDX>MSG-IDX VM-NAME-REG
|
|
S" 00" 2 DOE-IDX>MSG-IDX VM-NAME-REG
|
|
S" 01" 3 DOE-IDX>MSG-IDX VM-NAME-REG
|
|
S" 02" 4 DOE-IDX>MSG-IDX VM-NAME-REG
|
|
S" 03" 5 DOE-IDX>MSG-IDX VM-NAME-REG
|
|
S" 04" 6 DOE-IDX>MSG-IDX VM-NAME-REG
|
|
S" 05" 7 DOE-IDX>MSG-IDX VM-NAME-REG
|
|
S" 06" 8 DOE-IDX>MSG-IDX VM-NAME-REG ;
|
|
Block 5007
|
|
( INIT-FREE. stamps STADIUM-NONE into each slot's stadium- )
|
|
( cell field (msg off 5, ch off 3). Raw offsets: accessors )
|
|
( aren't defined yet in file order. )
|
|
: MSG-INIT-FREE ( -- )
|
|
MSG-MAX 0 DO
|
|
STADIUM-NONE I MSG-CELLS * CELLS MSG-ARENA + 5 CELLS + !
|
|
LOOP ;
|
|
: CH-INIT-FREE ( -- )
|
|
CH-MAX 0 DO
|
|
STADIUM-NONE I CH-CELLS * CELLS CH-ARENA + 3 CELLS + !
|
|
LOOP ;
|
|
Block 5008
|
|
( MBR-INIT-FREE (member free list, untouched) )
|
|
: MBR-INIT-FREE ( -- )
|
|
MBR-MAX 1- 0 DO
|
|
I MBR-CELLS * CELLS MBR-ARENA +
|
|
I 1+ MBR-CELLS * CELLS MBR-ARENA + SWAP !
|
|
LOOP
|
|
0 MBR-MAX 1- MBR-CELLS * CELLS MBR-ARENA + !
|
|
MBR-ARENA MBR-FREE-HEAD ! ;
|
|
Block 5009
|
|
( MSG-ALLOC: finds a free slot (TYPE=0) first, admits into )
|
|
( Stadium only once confirmed free (no leak). )
|
|
: MSG-FIND-FREE-SLOT ( -- addr|0 )
|
|
MSG-ARENA MSG-MAX 0 DO
|
|
DUP @ 0= IF UNLOOP EXIT THEN
|
|
MSG-CELLS CELLS +
|
|
LOOP DROP 0 ;
|
|
Block 5010
|
|
( MSG-ALLOC: pulls heat from reservoir first, admits )
|
|
( (identity=idx, heat=pulled), rolls back on refusal. )
|
|
: MSG-ALLOC ( heat -- addr|0 )
|
|
MSG-FIND-FREE-SLOT DUP 0= IF SWAP DROP EXIT THEN
|
|
MSG-ALLOC-SLOT !
|
|
STADIUM-RES-PULL
|
|
MSG-ALLOC-SLOT @ MSG-ARENA - MSG-CELLS CELLS /
|
|
SWAP DUP >R
|
|
SB-DELIVER STADIUM-ADMIT
|
|
DUP STADIUM-NONE = IF
|
|
DROP R> STADIUM-RES-PUSH 0 EXIT
|
|
THEN
|
|
R> DROP
|
|
MSG-ALLOC-SLOT @ MSG-CELLS CELLS 0 FILL
|
|
MSG-ALLOC-SLOT @ 5 CELLS + !
|
|
MSG-ALLOC-SLOT @ ;
|
|
Block 5011
|
|
( MSG-FREE-NODE: evict from Stadium, clear field )
|
|
: MSG-FREE-NODE ( addr -- )
|
|
DUP 5 CELLS + @ STADIUM-EVICT DROP
|
|
DUP 5 CELLS + STADIUM-NONE SWAP !
|
|
DROP ;
|
|
Block 5012
|
|
( MBR alloc/free (unchanged; not heat economy) )
|
|
: MBR-ALLOC ( -- addr|0 )
|
|
MBR-FREE-HEAD @ DUP 0= IF EXIT THEN
|
|
DUP @ MBR-FREE-HEAD !
|
|
DUP MBR-CELLS CELLS 0 FILL ;
|
|
: MBR-FREE-NODE ( addr -- )
|
|
MBR-FREE-HEAD @ OVER ! MBR-FREE-HEAD ! ;
|
|
Block 5013
|
|
( CH-FIND-FREE-SLOT. No TYPE field, so freeness is )
|
|
( stadium-cell = STADIUM-NONE. CH-ALLOC -> block 4176. )
|
|
: CH-FIND-FREE-SLOT ( -- addr|0 )
|
|
CH-ARENA CH-MAX 0 DO
|
|
DUP 3 CELLS + @ STADIUM-NONE = IF UNLOOP EXIT THEN
|
|
CH-CELLS CELLS +
|
|
LOOP DROP 0 ;
|
|
Block 5014
|
|
( CH-ALLOC: pulls heat from reservoir first, admits )
|
|
( (identity=idx, heat=pulled), rolls back on refusal. )
|
|
: CH-ALLOC ( heat -- addr|0 )
|
|
CH-FIND-FREE-SLOT DUP 0= IF SWAP DROP EXIT THEN
|
|
CH-ALLOC-SLOT !
|
|
STADIUM-RES-PULL
|
|
CH-ALLOC-SLOT @ CH-ARENA - CH-CELLS CELLS /
|
|
SWAP DUP >R
|
|
SB-COOL STADIUM-ADMIT
|
|
DUP STADIUM-NONE = IF
|
|
DROP R> STADIUM-RES-PUSH 0 EXIT
|
|
THEN
|
|
R> DROP
|
|
CH-ALLOC-SLOT @ CH-CELLS CELLS 0 FILL
|
|
CH-ALLOC-SLOT @ 3 CELLS + !
|
|
CH-ALLOC-SLOT @ ;
|
|
Block 5015
|
|
( CH-FREE-NODE: evict from Stadium, clear field )
|
|
: CH-FREE-NODE ( addr -- )
|
|
DUP 3 CELLS + @ STADIUM-EVICT DROP
|
|
DUP 3 CELLS + STADIUM-NONE SWAP !
|
|
DROP ;
|
|
Block 5016
|
|
( message field accessors )
|
|
: MSG-TYPE@ ( m -- n ) @ ;
|
|
: MSG-TYPE! ( n m -- ) ! ;
|
|
: MSG-FROM@ ( m -- n ) 1 CELLS + @ ;
|
|
: MSG-FROM! ( n m -- ) 1 CELLS + ! ;
|
|
: MSG-TO@ ( m -- n ) 2 CELLS + @ ;
|
|
: MSG-TO! ( n m -- ) 2 CELLS + ! ;
|
|
: MSG-PADDR@ ( m -- a ) 3 CELLS + @ ;
|
|
: MSG-PADDR! ( a m -- ) 3 CELLS + ! ;
|
|
: MSG-PLEN@ ( m -- u ) 4 CELLS + @ ;
|
|
: MSG-PLEN! ( u m -- ) 4 CELLS + ! ;
|
|
( offset 5 = Stadium cell idx. MSG-HEAT@/! -> 4154. )
|
|
: MSG-STADIUM-CELL@ ( m -- cell ) 5 CELLS + @ ;
|
|
: MSG-STADIUM-CELL! ( cell m -- ) 5 CELLS + ! ;
|
|
: MSG-SEQ@ ( m -- n ) 6 CELLS + @ ;
|
|
: MSG-SEQ! ( n m -- ) 6 CELLS + ! ;
|
|
Block 5017
|
|
( message accessors: CH@/CH! )
|
|
: MSG-CH@ ( m -- c ) 7 CELLS + @ ;
|
|
: MSG-CH! ( c m -- ) 7 CELLS + ! ;
|
|
: MSG-ORIG-TYPE@ ( m -- n ) 8 CELLS + @ ;
|
|
: MSG-ORIG-TYPE! ( n m -- ) 8 CELLS + ! ;
|
|
253 CONSTANT MSG-NACKED
|
|
Block 5018
|
|
( channel + member accessors )
|
|
: CH-ID@ ( c -- n ) @ ;
|
|
: CH-ID! ( n c -- ) ! ;
|
|
: CH-OWNER@ ( c -- n ) 1 CELLS + @ ;
|
|
: CH-OWNER! ( n c -- ) 1 CELLS + ! ;
|
|
: CH-STATE@ ( c -- n ) 2 CELLS + @ ;
|
|
: CH-STATE! ( n c -- ) 2 CELLS + ! ;
|
|
( offset 3 = Stadium cell index. CH-HEAT@/! -> 4154. )
|
|
: CH-STADIUM-CELL@ ( c -- cell ) 3 CELLS + @ ;
|
|
: CH-STADIUM-CELL! ( cell c -- ) 3 CELLS + ! ;
|
|
: CH-MBRS@ ( c -- a ) 4 CELLS + @ ;
|
|
: CH-MBRS! ( a c -- ) 4 CELLS + ! ;
|
|
: CH-NEXT@ ( c -- a ) 5 CELLS + @ ;
|
|
: CH-NEXT! ( a c -- ) 5 CELLS + ! ;
|
|
: MBR-NEXT@ ( m -- a ) @ ;
|
|
: MBR-VM@ ( m -- n ) 1 CELLS + @ ;
|
|
Block 5019
|
|
( composed MSG/CH-HEAT@/!, same names/stacks, bodies )
|
|
( routed via Stadium. Callers need no changes. )
|
|
: MSG-HEAT@ ( m -- q ) MSG-STADIUM-CELL@ STADIUM-HEAT@ ;
|
|
: MSG-HEAT! ( q m -- ) MSG-STADIUM-CELL@ STADIUM-HEAT! ;
|
|
: CH-HEAT@ ( c -- q ) CH-STADIUM-CELL@ STADIUM-HEAT@ ;
|
|
: CH-HEAT! ( q c -- ) CH-STADIUM-CELL@ STADIUM-HEAT! ;
|
|
Block 5020
|
|
( deliver )
|
|
VARIABLE MSG-LAST-MSG
|
|
VARIABLE MSG-SEND-TO-IDX
|
|
: IDX>NAME ( idx -- addr u )
|
|
DUP VM-MAX >= IF DROP 0 0 EXIT THEN
|
|
DUP CELLS VM-NAME-ADDRS + @
|
|
SWAP CELLS VM-NAME-LENS + @ ;
|
|
: MSG-DELIVER ( m -- )
|
|
DUP MSG-LAST-MSG !
|
|
DUP MSG-PADDR@ OVER MSG-PLEN@
|
|
ROT MSG-TO@ IDX>NAME VM-EXEC ;
|
|
Block 5021
|
|
( MSG-SEND. heat -> MSG-ALLOC's admission directly )
|
|
( (zero-heat would lose eviction-fallback density )
|
|
( comparisons), not set afterward as before. )
|
|
: MSG-SEND ( type from to paddr plen ch -- )
|
|
3 PICK MSG-SEND-TO-IDX !
|
|
Q.SLOT MSG-ALLOC DUP 0= IF 2DROP 2DROP 2DROP DROP EXIT THEN
|
|
>R
|
|
MSG-SEQ @ 1+ DUP MSG-SEQ ! R@ MSG-SEQ!
|
|
R@ MSG-CH!
|
|
R@ MSG-PLEN! R@ MSG-PADDR!
|
|
R@ MSG-TO! R@ MSG-FROM! DUP R@ MSG-TYPE! R@ MSG-ORIG-TYPE!
|
|
R> DROP
|
|
MSG-SEND-TO-IDX @ IDX>NAME SWITCH-MARK-WORK ;
|
|
Block 5022
|
|
( MSG-COOL-ONE/ALL: linear decay per tick )
|
|
VARIABLE MSG-SCAN
|
|
: MSG-COOL-ONE ( m -- )
|
|
DUP MSG-HEAT@ Q-DECAY Q.* SWAP MSG-HEAT! ;
|
|
: MSG-COOL-ALL ( -- )
|
|
MSG-ARENA MSG-SCAN !
|
|
MSG-MAX 0 DO
|
|
MSG-SCAN @ MSG-HEAT@ 0 > IF
|
|
MSG-SCAN @ MSG-COOL-ONE
|
|
THEN
|
|
MSG-SCAN @ MSG-CELLS CELLS + MSG-SCAN !
|
|
LOOP ;
|
|
Block 5023
|
|
( MSG-TOTAL-HEAT )
|
|
: MSG-TOTAL-HEAT ( -- q48 )
|
|
0 MSG-ARENA MSG-SCAN !
|
|
MSG-MAX 0 DO
|
|
MSG-SCAN @ MSG-TYPE@ 0 <> IF
|
|
MSG-SCAN @ MSG-HEAT@ +
|
|
THEN
|
|
MSG-SCAN @ MSG-CELLS CELLS + MSG-SCAN !
|
|
LOOP ;
|
|
: MSG-REDELIVER-NACKED ( -- )
|
|
MSG-ARENA MSG-SCAN !
|
|
MSG-MAX 0 DO
|
|
MSG-SCAN @ MSG-TYPE@ MSG-NACKED = IF
|
|
MSG-SCAN @ MSG-ORIG-TYPE@ MSG-SCAN @ MSG-TYPE! THEN
|
|
MSG-SCAN @ MSG-CELLS CELLS + MSG-SCAN !
|
|
LOOP ;
|
|
Block 5024
|
|
( MSG-DELIVER-ALL )
|
|
: MSG-DELIVER-ALL ( -- )
|
|
MSG-ARENA MSG-SCAN !
|
|
MSG-MAX 0 DO
|
|
MSG-SCAN @ MSG-TYPE@ 0 <>
|
|
MSG-SCAN @ MSG-TYPE@ MSG-DELIVERED <> AND
|
|
MSG-SCAN @ MSG-TYPE@ MSG-NACKED <> AND IF
|
|
MSG-SCAN @ MSG-DELIVER
|
|
MSG-SCAN @ MSG-TYPE@ 0 <> IF
|
|
MSG-DELIVERED MSG-SCAN @ MSG-TYPE!
|
|
THEN
|
|
THEN
|
|
MSG-SCAN @ MSG-CELLS CELLS + MSG-SCAN !
|
|
LOOP ;
|
|
Block 5025
|
|
( message reaping )
|
|
( K reap only fires at heat=0: freed K contribution is 0. )
|
|
( Force-reap not yet implemented. If added: explicit )
|
|
( K redistribution will be required here. )
|
|
: MSG-REAP ( -- )
|
|
MSG-ARENA MSG-SCAN !
|
|
MSG-MAX 0 DO
|
|
MSG-SCAN @ MSG-HEAT@ 0 = IF
|
|
MSG-SCAN @ MSG-TYPE@ 0 <> IF
|
|
0 MSG-SCAN @ MSG-TYPE!
|
|
MSG-SCAN @ MSG-FREE-NODE
|
|
THEN
|
|
THEN
|
|
MSG-SCAN @ MSG-CELLS CELLS + MSG-SCAN !
|
|
LOOP ;
|
|
Block 5026
|
|
( channel cooling + heat aggregate )
|
|
VARIABLE CH-SCAN
|
|
: CH-COOL-ALL ( -- )
|
|
CH-ACTIVE @ CH-SCAN !
|
|
BEGIN CH-SCAN @ 0 <> WHILE
|
|
CH-SCAN @ CH-HEAT@ Q-DECAY Q.* CH-SCAN @ CH-HEAT!
|
|
CH-SCAN @ CH-NEXT@ CH-SCAN !
|
|
REPEAT ;
|
|
: CH-TOTAL-HEAT ( -- q48 )
|
|
0 CH-ACTIVE @ CH-SCAN !
|
|
BEGIN CH-SCAN @ 0 <> WHILE
|
|
CH-SCAN @ CH-HEAT@ +
|
|
CH-SCAN @ CH-NEXT@ CH-SCAN !
|
|
REPEAT ;
|
|
Block 5027
|
|
( channel reaping )
|
|
: CH-REAP-SAFE ( -- )
|
|
CH-ACTIVE @ CH-SCAN !
|
|
0 CH-ACTIVE !
|
|
BEGIN CH-SCAN @ 0 <> WHILE
|
|
CH-SCAN @ CH-NEXT@
|
|
CH-SCAN @ CH-HEAT@ 0 =
|
|
CH-SCAN @ COMMON-CH @ <> AND IF
|
|
CH-SCAN @ CH-FREE-NODE
|
|
ELSE
|
|
CH-ACTIVE @ CH-SCAN @ CH-NEXT!
|
|
CH-SCAN @ CH-ACTIVE !
|
|
THEN
|
|
CH-SCAN !
|
|
REPEAT ;
|
|
Block 5028
|
|
( COMMON + MSG-TICK (was HERMES-TICK -- generic now). )
|
|
( floor=Q.1/3. COMMON-CH VARIABLE is in block 4101. )
|
|
: COMMON-INIT ( -- )
|
|
Q.1 3 / CH-ALLOC DUP COMMON-CH !
|
|
0 OVER CH-ID! 0 OVER CH-OWNER!
|
|
CH-OPEN OVER CH-STATE!
|
|
0 OVER CH-MBRS!
|
|
CH-ACTIVE @ OVER CH-NEXT!
|
|
CH-ACTIVE ! ;
|
|
( floor-refresh is reservoir-constrained, may no-op under )
|
|
( pressure. )
|
|
: MSG-TICK ( -- )
|
|
MSG-DELIVER-ALL MSG-REDELIVER-NACKED
|
|
MSG-COOL-ALL MSG-REAP
|
|
CH-COOL-ALL CH-REAP-SAFE
|
|
Q.1 3 / COMMON-CH @ CH-HEAT! ;
|
|
Block 5029
|
|
( MSG-K (was HERMES-K -- generic now). WELCOME stays )
|
|
( behind in each VM's own init.4th. )
|
|
: MSG-K ( -- q48 )
|
|
MSG-TOTAL-HEAT CH-TOTAL-HEAT + STADIUM-RES@ +
|
|
STADIUM-WORD-HEAT + ;
|
|
Block 5031
|
|
( channel negotiation: mint/request )
|
|
: CH-MINT-ID ( owner -- id )
|
|
MSG-SEQ @ 1+ DUP MSG-SEQ !
|
|
SWAP 32 LSHIFT OR ;
|
|
( H.8: initiator-only gate. Refuses if `from` doesn't )
|
|
( match MY-CH-ID -- no posting while claiming another VM. )
|
|
: CH-REQUEST ( type from to paddr plen -- )
|
|
3 PICK MY-CH-ID @ <> IF 2DROP 2DROP DROP EXIT THEN
|
|
COMMON-CH @ CH-STATE@ CH-OPEN = IF
|
|
COMMON-CH @ MSG-SEND
|
|
ELSE 2DROP 2DROP DROP THEN ;
|
|
Block 5032
|
|
( channel ops: accept confirm close )
|
|
: CH-ACCEPT ( -- ch|0 )
|
|
Q.SLOT CH-ALLOC DUP 0= IF EXIT THEN
|
|
1 CH-MINT-ID OVER CH-ID!
|
|
1 OVER CH-OWNER!
|
|
CH-NEGOTIATING OVER CH-STATE!
|
|
0 OVER CH-MBRS!
|
|
CH-ACTIVE @ OVER CH-NEXT!
|
|
DUP CH-ACTIVE ! ;
|
|
: CH-CONFIRM ( ch -- )
|
|
DUP CH-STATE@ CH-NEGOTIATING = IF CH-OPEN SWAP CH-STATE!
|
|
ELSE DROP THEN ;
|
|
: CH-CLOSE ( ch -- )
|
|
DUP COMMON-CH @ = IF DROP EXIT THEN
|
|
CH-CLOSING SWAP CH-STATE! ;
|
|
Block 5033
|
|
( MSG-CD-INIT (was CD-INIT -- renamed to avoid colliding )
|
|
( with Artemis's own unrelated block-subsystem CD-INIT). )
|
|
( common:msg.4th's HERMES-ACK/NACK indirection is retired: )
|
|
( every VM now has its own local MSG-ACK-LAST/NACK-LAST. )
|
|
: MSG-CD-INIT ( -- )
|
|
MSG-ARENA MSG-MAX MSG-CELLS * CELLS 0 FILL
|
|
CH-ARENA CH-MAX CH-CELLS * CELLS 0 FILL
|
|
MBR-ARENA MBR-MAX MBR-CELLS * CELLS 0 FILL
|
|
MSG-INIT-FREE
|
|
CH-INIT-FREE
|
|
MBR-INIT-FREE
|
|
0 MSG-SEQ !
|
|
0 MSG-LAST-MSG !
|
|
0 CH-ACTIVE ! -1 MY-CH-ID !
|
|
COMMON-INIT
|
|
VM-NAMES-INIT ;
|
|
Block 5034
|
|
( ACK/NACK -- now purely local, no VM-EXEC indirection. )
|
|
: MSG-ACK-LAST ( -- )
|
|
MSG-LAST-MSG @ DUP 0= IF DROP EXIT THEN
|
|
0 OVER MSG-TYPE! MSG-FREE-NODE ;
|
|
: MSG-NACK-LAST ( -- )
|
|
MSG-LAST-MSG @ DUP 0= IF DROP EXIT THEN
|
|
DUP MSG-HEAT@ 2 / OVER MSG-HEAT!
|
|
MSG-NACKED SWAP MSG-TYPE! ;
|
|
Block 5035
|
|
( MSG-STATUS (was HERMES-STATUS -- generic now) )
|
|
: MSG-USED ( -- n )
|
|
0 MSG-ARENA MSG-SCAN !
|
|
MSG-MAX 0 DO
|
|
MSG-SCAN @ MSG-TYPE@ 0 <> IF 1+ THEN
|
|
MSG-SCAN @ MSG-CELLS CELLS + MSG-SCAN !
|
|
LOOP ;
|
|
: CH-USED ( -- n )
|
|
0 CH-ACTIVE @ CH-SCAN !
|
|
BEGIN CH-SCAN @ 0 <> WHILE
|
|
1+
|
|
CH-SCAN @ CH-NEXT@ CH-SCAN !
|
|
REPEAT ;
|
|
: MSG-STATUS ( -- )
|
|
MSG-USED . ." msgs " CH-USED . ." channels" CR ;
|
|
Block 5036
|
|
( member management )
|
|
: MBR-NEXT! ( a m -- ) ! ;
|
|
: MBR-VM! ( n m -- ) 1 CELLS + ! ;
|
|
: CH-ADD-MBR ( vm ch -- )
|
|
MBR-ALLOC DUP 0= IF DROP 2DROP EXIT THEN
|
|
ROT OVER MBR-VM!
|
|
OVER CH-MBRS@ OVER MBR-NEXT!
|
|
SWAP CH-MBRS! ;
|
|
Block 5037
|
|
( Phase 2: real multi-member broadcast )
|
|
VARIABLE BC-TYPE VARIABLE BC-FROM
|
|
VARIABLE BC-PADDR VARIABLE BC-PLEN
|
|
VARIABLE BC-CH VARIABLE BC-SCAN
|
|
: MSG-BROADCAST ( type from paddr plen ch -- )
|
|
BC-CH ! BC-PLEN ! BC-PADDR ! BC-FROM ! BC-TYPE !
|
|
BC-CH @ CH-MBRS@ BC-SCAN !
|
|
BEGIN BC-SCAN @ 0<> WHILE
|
|
BC-TYPE @ BC-FROM @ BC-SCAN @ MBR-VM@
|
|
BC-PADDR @ BC-PLEN @ BC-CH @ MSG-SEND
|
|
BC-SCAN @ MBR-NEXT@ BC-SCAN !
|
|
REPEAT ;
|
|
Block 5039
|
|
( H.8: SEND-ELEVATE-REQUEST payload builder -- )
|
|
( scratch text buffer + append primitives. )
|
|
CREATE ELEVATE-REQ-BUF 256 ALLOT
|
|
VARIABLE ELEVATE-REQ-LEN
|
|
: ELEVATE-REQ-RESET ( -- ) 0 ELEVATE-REQ-LEN ! ;
|
|
: ELEVATE-REQ-PUTC ( c -- )
|
|
ELEVATE-REQ-BUF ELEVATE-REQ-LEN @ + C!
|
|
1 ELEVATE-REQ-LEN +! ;
|
|
: ELEVATE-REQ-APPEND ( addr u -- )
|
|
>R
|
|
ELEVATE-REQ-BUF ELEVATE-REQ-LEN @ +
|
|
R@ CMOVE
|
|
ELEVATE-REQ-LEN @ R> + ELEVATE-REQ-LEN ! ;
|
|
: ELEVATE-REQ-NUM ( n -- )
|
|
<# 0 SWAP #S #> ELEVATE-REQ-APPEND ;
|
|
Block 5040
|
|
( SEND-ELEVATE-REQUEST: ask Zuse for word-ACL )
|
|
( elevation. pk3..pk0 order so top-down emits )
|
|
( pk0 first; waddr/wu = target word name text. )
|
|
: SEND-ELEVATE-REQUEST ( pk3 pk2 pk1 pk0 waddr wu -- )
|
|
ELEVATE-REQ-RESET
|
|
83 ELEVATE-REQ-PUTC 34 ELEVATE-REQ-PUTC
|
|
32 ELEVATE-REQ-PUTC
|
|
ELEVATE-REQ-APPEND
|
|
34 ELEVATE-REQ-PUTC 32 ELEVATE-REQ-PUTC
|
|
ELEVATE-REQ-NUM 32 ELEVATE-REQ-PUTC
|
|
ELEVATE-REQ-NUM 32 ELEVATE-REQ-PUTC
|
|
ELEVATE-REQ-NUM 32 ELEVATE-REQ-PUTC
|
|
ELEVATE-REQ-NUM 32 ELEVATE-REQ-PUTC
|
|
S" ELEVATE-GRANT" ELEVATE-REQ-APPEND
|
|
ELEVATE-REQUEST MY-CH-ID @ 0 ELEVATE-REQ-BUF
|
|
ELEVATE-REQ-LEN @ CH-REQUEST ;
|