admin/LithosAnanake
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
d0fcd2ed86b2997b4da469744301262804edab2f
LithosAnanake/capsules/hermes/init.4th
T
Robert Allan JamesandClaude Sonnet 5 5a28458b21 starkernel: item 4.2 -- Hermes native on the Stadium (complete) 
Migrates Hermes's message/channel lifecycle onto the Stadium's unified
heat/capacity economy: MSG-ALLOC/FREE-NODE and CH-ALLOC/FREE-NODE now
route entirely through stadium_admit()/stadium_evict(), replacing the
old local free-list + independent heat-field mechanism. Eight
kernel-only STADIUM-* FORTH primitives (ADMIT, EVICT, RES@, RES-PULL,
RES-PUSH, HEAT@, HEAT!, WORD-HEAT), VM.stadium_vm_id threaded through
all three vm_core.c dispatch sites (replacing item 4.1's hardcoded
vm_uuid_hera()), and the stadium_owner[idx] fix so evict-credit lands
in the VM that actually admitted a patron, not whoever owned cell 0.

This session's own contribution, on top of that pre-existing
implementation: found and fixed two bugs blocking the item's own K≡1.0
conservation self-check (HERMES-K was reading 0, not 65536):

- Q.SLOT admission-heat fix (capsules/hermes/init.4th): MSG-SEND/
  CH-ACCEPT admitted with Q.1 (the entire fleet-wide "1.0" unit) per
  item, a leftover from before the Stadium migration when each
  message/channel had its own unconstrained heat field. Instantly
  drained the shared, finite reservoir.

- Reservoir floor for word-execution admission (stadium_words.c):
  stadium_word_dispatch() (item 4.1) pulls STADIUM_WORD_HEAT_QUANTUM on
  every word dispatch, not just first admission -- exhausts a VM's
  entire reservoir in ~32 dispatches, starving any application-level
  economy sharing that VM's reservoir before it gets a chance to pull
  anything. word_dispatch_pull() now clamps word-execution's own pulls
  to leave a Q48_ONE/3 floor (same fair-share figure COMMON-CH's own
  floor already uses); application-level pulls are unaffected.

- STADIUM-WORD-HEAT primitive + stadium_words_resident_heat(): the
  floor deliberately leaves word-execution residents holding real
  heat, invisible to HERMES-K's original formula (MSG+CH+reservoir,
  no term for word patrons). Adding this term closes K to exactly
  65536 on all three architectures.

Also rules on two open scope questions in FABRIC.md: MBR-ALLOC/
MBR-FREE-NODE stay off the Stadium (membership records have no heat
field, never did -- the acceptance bullet's inclusion of them was a
completeness gesture predating a check of the actual layout), and
records the effort number (12 implementation files, +759/-120 lines).

Verified: all three architectures boot clean, full self-test passes,
Stadium conservation closes exactly (resident_sum + reservoir =
Q48_ONE) at both the C/Stadium level and the FORTH-level HERMES-K
check.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
2026-08-07 01:49:23 -04:00

464 lines
14 KiB
Forth
Raw Blame History

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" USE
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 ;
Reference in New Issue View Git Blame Copy Permalink