Robert Allan JamesandClaude Sonnet 5
af1eb0ca2d
capsules/lib.4th:13-14 defined ": USE ( addr u -- ) EXEC ;" and the same for RUN, shadowing the C-registered mama_word_use()/RUN primitives (CLAUDE.md names both, with BIRTH, as untouchable C primitives) with an unrelated "load/exec a capsule" meaning. This broke the interactive USE-based VM-redirect (S" Artemis" USE printed "EXEC: failed: Artemis" instead of redirecting), discovered while chasing FABRIC-3.md's live-MIGRATE verification. Traced every real caller before touching anything: RUN's alias was dead code, never called anywhere as bare RUN. USE's alias had exactly one real caller -- capsules/hermes/init.4th:397, intentionally exploiting the shadow to load common:msg.4th right after lib.4th itself loaded. Both aliases were pure EXEC wrappers with zero added behavior, so this deletes both definitions outright and switches the one real call site (plus its matching doc comment in capsules/common/msg.4th) to call EXEC directly. No new names invented, the C primitives untouched. Verified live: Hermes still births and her COMMON-CH-eviction self-test (depends on common:msg.4th having loaded) still passes; interactively, S" Artemis" USE now correctly redirects the REPL and prints "USE: now using Artemis". mkcapsule --lint clean (31/31). Clean compile and clean boot with Stadium conservation intact (resident_sum + reservoir == Q48_ONE) on all three architectures. Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_01CXjAPTEKrgY2Mrk25KoLDn
464 lines
14 KiB
Forth
464 lines
14 KiB
Forth
Block 4100
|
|
( Hermes v1 — constants )
|
|
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 4155
|
|
( item 4.2 -- 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
|
|
( item 4.2 -- 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 4101
|
|
( Hermes v1 -- arenas. item 4.2: 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
|
|
Block 4142
|
|
( Hermes v1 — VM name routing table )
|
|
8 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 + ! ;
|
|
: VM-NAMES-INIT ( -- )
|
|
S" Hera" 0 VM-NAME-REG
|
|
S" Hermes" 1 VM-NAME-REG
|
|
S" Artemis" 2 VM-NAME-REG ;
|
|
Block 4102
|
|
( Hermes v1 -- INIT-FREE. item 4.2: 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 4103
|
|
( Hermes v1 -- 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 4156
|
|
( item 4.2 -- 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 4175
|
|
( item 4.2 -- 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 4157
|
|
( item 4.2 -- 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 4104
|
|
( Hermes v1 -- 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 4158
|
|
( item 4.2 -- 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 4176
|
|
( item 4.2 -- 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 4159
|
|
( item 4.2 -- 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 4105
|
|
( Hermes v1 — 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 + ! ;
|
|
( item 4.2: 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 4143
|
|
( Hermes v1 — 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 4106
|
|
( Hermes v1 — 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 + ! ;
|
|
( item 4.2: 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 4154
|
|
( item 4.2 -- composed MSG/CH-HEAT@/!, same names/stacks, )
|
|
( new 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 4107
|
|
( Hermes v1 — deliver )
|
|
VARIABLE MSG-LAST-MSG
|
|
: 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 4144
|
|
( Hermes v1 -- MSG-SEND. item 4.2: 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 -- )
|
|
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 ;
|
|
Block 4108
|
|
( Hermes v1 — 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 4145
|
|
( Hermes v1 — 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 4146
|
|
( Hermes v1 — 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 4109
|
|
( Hermes v1 — 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 4114
|
|
( Hermes v1 — 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 4115
|
|
( Hermes v1 — 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 4116
|
|
( Hermes v1 -- COMMON + HERMES-TICK. floor=Q.1/3, VM-COUNT=3 )
|
|
( COMMON-CH VARIABLE now in block 4101; see CH-REAP-SAFE 4115 )
|
|
: 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 ! ;
|
|
( item 4.2: floor-refresh now reservoir-constrained, may no-op )
|
|
( under pressure (was unconstrained write before). Watch log. )
|
|
: HERMES-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 4147
|
|
( Hermes v1 — HERMES-K + WELCOME )
|
|
( item 4.2: +STADIUM-WORD-HEAT so word patrons count -- 25.7 )
|
|
: HERMES-K ( -- q48 )
|
|
MSG-TOTAL-HEAT CH-TOTAL-HEAT + STADIUM-RES@ +
|
|
STADIUM-WORD-HEAT + ;
|
|
: WELCOME ( -- ) LOG-INFO" Hermes: loaded" ;
|
|
WELCOME
|
|
Block 4117
|
|
( Hermes v1 — event compat interface )
|
|
( SPAWN/KILL notify-Hera is now automatic: see )
|
|
( vm_physics_init/retire in mama_word_birth/kill )
|
|
: EVENT-EMIT ( type -- ) DROP ;
|
|
: EVENT-WAIT ( -- type )
|
|
MSG-ARENA MSG-SCAN !
|
|
MSG-MAX 0 DO
|
|
MSG-SCAN @ MSG-TYPE@ 0 <> IF
|
|
MSG-SCAN @ MSG-TYPE@ UNLOOP EXIT THEN
|
|
MSG-SCAN @ MSG-CELLS CELLS + MSG-SCAN !
|
|
LOOP 0 ;
|
|
: EVENT-DRAIN ( -- )
|
|
( no-op: MSG-REAP owns cleanup; drain breaks async ) ;
|
|
Block 4118
|
|
( Hermes v1 -- readiness handshake, Phase 1 )
|
|
5 CONSTANT READY-EVENT
|
|
VARIABLE READY-COUNT
|
|
: NOTE-READY ( -- ) 1 READY-COUNT +! ;
|
|
: READY-ALL? ( -- flag ) READY-COUNT @ 3 >= ;
|
|
: ENQUEUE-READY ( from-idx -- )
|
|
READY-EVENT SWAP 1 S" NOTE-READY" COMMON-CH @ MSG-SEND ;
|
|
: HERMES-ANNOUNCE-READY ( -- ) 1 ENQUEUE-READY ;
|
|
: READY-ACK ( -- ) LOG-INFO" Hermes: ready-ack" ;
|
|
Block 4119
|
|
( Hermes v1 — channel negotiation: mint/request )
|
|
: CH-MINT-ID ( owner -- id )
|
|
MSG-SEQ @ 1+ DUP MSG-SEQ !
|
|
SWAP 32 LSHIFT OR ;
|
|
: CH-REQUEST ( type from to paddr plen -- )
|
|
COMMON-CH @ CH-STATE@ CH-OPEN = IF
|
|
COMMON-CH @ MSG-SEND
|
|
ELSE 2DROP 2DROP DROP THEN ;
|
|
Block 4148
|
|
( Hermes v1 — 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 4120
|
|
( Hermes v1 — CD-INIT )
|
|
: 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 !
|
|
COMMON-INIT
|
|
VM-NAMES-INIT
|
|
S" lib.4th" EXEC
|
|
S" common:msg.4th" EXEC
|
|
LOG-INFO" Hermes: ready" ;
|
|
Block 4121
|
|
( Hermes v1 — ACK/NACK server )
|
|
: 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 4149
|
|
( Hermes v1 — HERMES-STATUS )
|
|
: 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 ;
|
|
: HERMES-STATUS ( -- )
|
|
MSG-USED . ." msgs " CH-USED . ." channels" CR ;
|
|
Block 4150
|
|
( Hermes v1 — 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! ;
|
|
: HERMES-MSG-TEST ( -- flag )
|
|
SPAWN-EVENT 1 0 0 0 COMMON-CH @ MSG-SEND
|
|
MSG-USED 0 > ;
|
|
Block 4151
|
|
( Hermes v1 -- 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 4152
|
|
( Hermes v1 -- Phase 2: COMMON-CH membership + test )
|
|
VARIABLE BCAST-GOT
|
|
: BCAST-RECV ( -- ) 1 BCAST-GOT +! ;
|
|
: REGISTER-COMMON-MEMBERS ( -- )
|
|
0 COMMON-CH @ CH-ADD-MBR
|
|
1 COMMON-CH @ CH-ADD-MBR
|
|
2 COMMON-CH @ CH-ADD-MBR ;
|
|
6 CONSTANT BCAST-EVENT
|
|
: SEND-BROADCAST-TEST ( -- )
|
|
BCAST-EVENT 1 S" BCAST-RECV" COMMON-CH @ MSG-BROADCAST ;
|
|
Block 4153
|
|
( LOAD-DOE: pulls in doe.4th's word-level DOE-WORK )
|
|
( workload, for doe-campaign.4th's remote VM-EXEC. )
|
|
: LOAD-DOE ( -- ) S" doe.4th" EXEC ;
|