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
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
Block 5006
( VM name routing table -- same fixed table every VM loads, )
( so IDX>NAME resolves identically everywhere. )
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 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
: 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 -- )
  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 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 5030
( event compat interface. SPAWN/KILL notify-Hera is )
( automatic: see vm_physics_init/retire in mama_word_birth. )
: 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 5031
( 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 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 !
  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 ;