256 lines
7.1 KiB
Forth
256 lines
7.1 KiB
Forth
Block 4110
|
|
( Artemis flat pool disk manager )
|
|
( WARNING: no fs layer -- bugs can destroy disk/artemis.img )
|
|
( Disk: LBN 3072..26073 via virtio-blk = 23002 blocks )
|
|
( Hdr: 3072 Fmap: 3073-3075 Data: 3076..26073 )
|
|
3072 CONSTANT ART-HDR-LBN
|
|
3073 CONSTANT ART-FM-LBN
|
|
3 CONSTANT ART-FM-BLKS
|
|
3076 CONSTANT ART-DATA-LBN
|
|
22998 CONSTANT ART-DATA-BLKS
|
|
65208 CONSTANT Q-DECAY
|
|
Block 4111
|
|
( Arch-neutral little-endian byte I/O -- 32-bit )
|
|
: LE32! ( u addr -- )
|
|
OVER 255 AND OVER C! 1+
|
|
OVER 256 / 255 AND OVER C! 1+
|
|
OVER 65536 / 255 AND OVER C! 1+
|
|
SWAP 16777216 / 255 AND SWAP C! ;
|
|
: LE32@ ( addr -- u )
|
|
DUP C@
|
|
OVER 1+ C@ 256 * +
|
|
OVER 2+ C@ 65536 * +
|
|
SWAP 3 + C@ 16777216 * + ;
|
|
Block 4128
|
|
( LE64 byte I/O -- depends on LE32!/LE32@ )
|
|
: LE64! ( u addr -- )
|
|
2DUP LE32!
|
|
SWAP 4294967296 / SWAP 4 + LE32! ;
|
|
: LE64@ ( addr -- u )
|
|
DUP LE32@
|
|
SWAP 4 + LE32@
|
|
4294967296 * + ;
|
|
Block 4112
|
|
( Bit ops -- 2*/2/ loops; no LSHIFT/RSHIFT in vocabulary )
|
|
: SHL1N ( u n -- u' ) 0 ?DO 2* LOOP ;
|
|
: SHR1N ( u n -- u' ) 0 ?DO 2/ LOOP ;
|
|
: BIT-TEST ( byte bit# -- flag )
|
|
SHR1N 1 AND ;
|
|
: BIT-SET ( byte bit# -- byte' )
|
|
1 SWAP SHL1N OR ;
|
|
: BIT-CLR ( byte bit# -- byte' )
|
|
1 SWAP SHL1N INVERT AND ;
|
|
Block 4113
|
|
( Free map: bit array across LBN 3073-3075 )
|
|
( n = 0-based data block index; n=0 -> LBN 3076 )
|
|
: FM-ADDR-BIT ( n -- bit# addr )
|
|
DUP 7 AND
|
|
SWAP 8 /
|
|
DUP 1024 / ART-FM-LBN + BLOCK
|
|
SWAP 1024 MOD + ;
|
|
: FM-TEST ( n -- flag )
|
|
FM-ADDR-BIT C@ SWAP BIT-TEST ;
|
|
: FM-SET ( n -- )
|
|
FM-ADDR-BIT DUP C@ ROT BIT-SET SWAP C! UPDATE ;
|
|
: FM-CLR ( n -- )
|
|
FM-ADDR-BIT DUP C@ ROT BIT-CLR SWAP C! UPDATE ;
|
|
Block 4137
|
|
( Block heat arena -- Q48.16 heat per data block slot )
|
|
CREATE BLK-HEAT ART-DATA-BLKS CELLS ALLOT
|
|
Block 4138
|
|
( Block heat accessors and LBN conversion )
|
|
: BLK-HEAT@ ( n -- q48 ) CELLS BLK-HEAT + @ ;
|
|
: BLK-HEAT! ( q48 n -- ) CELLS BLK-HEAT + ! ;
|
|
: LBN>IDX ( lbn -- n ) ART-DATA-LBN - ;
|
|
Block 4122
|
|
( Block allocator -- first-free linear scan )
|
|
( NOTE: Hermes owns 4100-9,4114-21,4142+. Artemis resumes 4122 )
|
|
: FM-FIND-FREE ( -- n|-1 )
|
|
ART-DATA-BLKS 0 DO
|
|
I FM-TEST 0= IF I UNLOOP EXIT THEN
|
|
LOOP -1 ;
|
|
: BLK-ALLOC ( -- lbn|-1 )
|
|
FM-FIND-FREE DUP -1 = IF EXIT THEN
|
|
DUP FM-SET Q.1 OVER BLK-HEAT! ART-DATA-LBN + ;
|
|
: BLK-FREE ( lbn -- )
|
|
ART-DATA-LBN -
|
|
DUP 0 < IF DROP EXIT THEN
|
|
DUP ART-DATA-BLKS >= IF DROP EXIT THEN
|
|
DUP FM-TEST 0= IF DROP EXIT THEN
|
|
DUP FM-CLR 0 SWAP BLK-HEAT! ;
|
|
Block 4123
|
|
( Artemis magic and blank detection )
|
|
( Magic = "ARTEMIS\0" = 41 52 54 45 4D 49 53 00 )
|
|
: ART-MAGIC! ( addr -- )
|
|
65 OVER C! 1+ 82 OVER C! 1+
|
|
84 OVER C! 1+ 69 OVER C! 1+
|
|
77 OVER C! 1+ 73 OVER C! 1+
|
|
83 OVER C! 1+ 0 SWAP C! ;
|
|
: ART-MAGIC? ( addr -- flag )
|
|
DUP C@ 65 =
|
|
OVER 1+ C@ 82 = AND
|
|
OVER 2+ C@ 84 = AND
|
|
OVER 3 + C@ 69 = AND
|
|
OVER 4 + C@ 77 = AND
|
|
OVER 5 + C@ 73 = AND
|
|
OVER 6 + C@ 83 = AND
|
|
SWAP 7 + C@ 0 = AND ;
|
|
Block 4129
|
|
( Artemis -- readiness handshake, Phase 1 )
|
|
: ARTEMIS-ANNOUNCE-READY ( -- )
|
|
S" 2 ENQUEUE-READY" S" Hermes" VM-EXEC ;
|
|
: ARTEMIS-READY-ACK ( -- ) LOG-INFO" Artemis: ready-ack" ;
|
|
VARIABLE BCAST-GOT
|
|
: BCAST-RECV ( -- ) 1 BCAST-GOT +! ;
|
|
Block 4130
|
|
( Blank block detection )
|
|
: ART-BLANK? ( addr -- flag )
|
|
1024 0 DO
|
|
DUP I + C@ 0<> IF
|
|
DROP FALSE UNLOOP EXIT
|
|
THEN
|
|
LOOP DROP TRUE ;
|
|
Block 4124
|
|
( Boot detection and block I/O )
|
|
0 CONSTANT ART-BLANK-DISK
|
|
1 CONSTANT ART-LITHOS-DISK
|
|
2 CONSTANT ART-UNRECOG-DISK
|
|
: ART-BOOT-DETECT ( -- mode )
|
|
ART-HDR-LBN BLOCK
|
|
DUP ART-MAGIC? IF DROP ART-LITHOS-DISK EXIT THEN
|
|
DUP ART-BLANK? IF DROP ART-BLANK-DISK EXIT THEN
|
|
DROP ART-UNRECOG-DISK ;
|
|
: BLK-FETCH ( lbn -- addr )
|
|
DUP ART-DATA-LBN >= IF
|
|
DUP LBN>IDX Q.1 SWAP BLK-HEAT! THEN
|
|
BLOCK ;
|
|
: BLK-PERSIST ( lbn -- ) BLOCK DROP UPDATE ;
|
|
: ART-FLUSH ( -- ) FLUSH ;
|
|
Block 4125
|
|
( Artemis header write -- called on first format )
|
|
( Layout: [0-7] magic [8-11] ver [12-15] fm-blks )
|
|
( [16-23] data-start [24-31] total [32-39] free )
|
|
: ART-HDR-WRITE ( -- )
|
|
ART-HDR-LBN BUFFER
|
|
DUP 1024 0 FILL
|
|
DUP ART-MAGIC!
|
|
DUP 8 + 1 SWAP LE32!
|
|
DUP 12 + ART-FM-BLKS SWAP LE32!
|
|
DUP 16 + ART-DATA-LBN SWAP LE64!
|
|
DUP 24 + ART-DATA-BLKS SWAP LE64!
|
|
DUP 32 + ART-DATA-BLKS SWAP LE64!
|
|
DROP UPDATE ;
|
|
Block 4126
|
|
( Boot sequence -- format/resume/halt words )
|
|
: ART-FORMAT ( -- )
|
|
." Artemis: blank disk -- formatting" CR
|
|
ART-HDR-WRITE FLUSH ;
|
|
: ART-RESUME ( -- )
|
|
." Artemis: LithosAnanke disk -- resuming" CR ;
|
|
: ART-HALT-UNRECOG ( -- )
|
|
." ARTEMIS HALT: unrecognized disk content" CR
|
|
." Disk preserved. Manual intervention required." CR
|
|
ABORT ;
|
|
Block 4131
|
|
( ART-INIT -- boot state machine )
|
|
VARIABLE ART-BOOT-MODE
|
|
: ART-INIT ( -- )
|
|
BLK-HEAT ART-DATA-BLKS CELLS 0 FILL
|
|
ART-BOOT-DETECT DUP ART-BOOT-MODE !
|
|
CASE
|
|
ART-BLANK-DISK OF ART-FORMAT ENDOF
|
|
ART-LITHOS-DISK OF ART-RESUME ENDOF
|
|
ART-UNRECOG-DISK OF ART-HALT-UNRECOG ENDOF
|
|
ENDCASE ;
|
|
Block 4139
|
|
( Fleet K total and block cooling )
|
|
: ART-K-TOTAL ( -- q48 )
|
|
0 ART-DATA-BLKS 0 DO I BLK-HEAT@ + LOOP ;
|
|
: ART-COOL ( -- )
|
|
ART-DATA-BLKS 0 DO
|
|
I BLK-HEAT@ DUP 0 > IF
|
|
Q-DECAY Q.* I BLK-HEAT!
|
|
ELSE DROP THEN
|
|
LOOP ;
|
|
Block 4140
|
|
( Block reap and compudynamic tick )
|
|
: ART-REAP ( -- )
|
|
ART-DATA-BLKS 0 DO
|
|
I FM-TEST IF
|
|
I BLK-HEAT@ 0 = IF
|
|
I ART-DATA-LBN + BLK-FREE
|
|
THEN
|
|
THEN
|
|
LOOP ;
|
|
: ART-TICK ( -- )
|
|
ART-COOL ART-REAP ;
|
|
Block 4127
|
|
( Status )
|
|
: ART-STATUS ( -- )
|
|
." Artemis: " ART-DATA-BLKS . ." data blocks" CR
|
|
." K-total=" ART-K-TOTAL Q.PRINT CR ;
|
|
: WELCOME ( -- ) ." Artemis ready" CR ART-STATUS ;
|
|
Block 4132
|
|
( Self-test: alloc/fetch/persist/free round-trip )
|
|
: ART-SELF-TEST ( -- )
|
|
." Artemis self-test..." CR
|
|
BLK-ALLOC DUP -1 = IF
|
|
." FAIL: no free blocks" CR DROP EXIT
|
|
THEN
|
|
DUP . ." allocated" CR
|
|
DUP BLK-FETCH DROP
|
|
DUP BLK-PERSIST
|
|
ART-K-TOTAL Q.PRINT ." K after alloc" CR
|
|
BLK-FREE
|
|
ART-K-TOTAL Q.PRINT ." K after free" CR
|
|
ART-FLUSH
|
|
." PASS" CR ;
|
|
Block 4134
|
|
( Persist write test -- blank disk, no free after alloc )
|
|
( Allocs LBN, fills with 0xA5=165, persists. Stays alloc. )
|
|
: ART-WRITE-TEST ( -- )
|
|
." Artemis: persist-write..." CR
|
|
BLK-ALLOC DUP -1 = IF
|
|
." FAIL: no free block" CR DROP EXIT
|
|
THEN
|
|
DUP BLK-FETCH 1024 165 FILL
|
|
BLK-PERSIST
|
|
ART-FLUSH
|
|
." PASS: persist-write" CR ;
|
|
Block 4135
|
|
( Persist read test -- run on resumed disk )
|
|
( Reads ART-DATA-LBN byte 0; expects 165 = 0xA5 )
|
|
: ART-READ-TEST ( -- )
|
|
." Artemis: persist-read..." CR
|
|
ART-DATA-LBN BLK-FETCH C@ 165 = IF
|
|
." PASS: persist-read" CR
|
|
ELSE
|
|
." FAIL: persist-read" CR
|
|
THEN ;
|
|
Block 4136
|
|
( Boot-mode dispatch -- called from entry block )
|
|
: ART-BOOT-ENTRY ( -- )
|
|
ART-BOOT-MODE @
|
|
DUP ART-BLANK-DISK = IF
|
|
DROP ART-SELF-TEST ART-WRITE-TEST EXIT
|
|
THEN
|
|
ART-LITHOS-DISK = IF ART-READ-TEST THEN ;
|
|
Block 4141
|
|
( Artemis CD-INIT -- Hera calls this at fleet boot )
|
|
: CD-INIT ( -- )
|
|
BLK-HEAT ART-DATA-BLKS CELLS 0 FILL
|
|
LOG-INFO" Artemis: ready" ;
|
|
Block 4133
|
|
( Artemis entry -- runs at capsule load )
|
|
ART-INIT
|
|
ART-BOOT-ENTRY
|
|
WELCOME
|
|
Block 4851
|
|
( Cheap touch target for Phase 3 fleet DoE workload -- O(1), )
|
|
( unlike ART-TICK/ART-STATUS which scan all ART-DATA-BLKS. )
|
|
: ART-PING ( -- ) ;
|
|
Block 4852
|
|
( 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 ;
|