admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(v4.0.0): shorter chains of calls in the compiler capsule

Browse Source 
Measured, compiling a DO loop left one return entry spare under
INTERPRET and a defining word called from inside another word
overflowed the nine-entry return stack (D-2); the prompt loop will take
one more.

C@ and C! shift without a loop.  The code generator shifts each opcode
into the word being built, so nothing is placed by a counted shift, and
the address masks come from a table.  The dictionary search, the
in-liner, the end of a loop and the making of a data word are each one
word reached by a jump.

Every kind of line now leaves at least three return entries spare while
it compiles; a word run from the interpreter has six; and CREATE ...
DOES> works from the prompt, from a word, and from a word that calls
that.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 11:17:58 -04:00
co-authored by Claude Opus 5.5
parent dac7ffac92
commit 806f876ee0
9 changed files with 165 additions and 123 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/capsule/codegen.v4
+32 -29
View File
@@ -19,44 +19,46 @@
\ bits whose lowest is bit 27 - 5k, and a branch there has 27 - 5k address bits.
\
\ Rests on core.v4 and dict.v4. Constants the loader supplies:
\ (CG) word address of thirteen cells of scratch for this file
\ (CG) word address of fourteen cells of scratch for this file
\ CG-BSLOTS how many slots, counted from slot 0, may hold a branch
\ Like WORD, these run under whatever the user has on the stacks, so what they
\ work on is in (CG) and they keep at most three cells of their own on the
\ data stack (D-2):
\ work on is in (CG), they keep at most three cells of their own on the data
\ stack, and they call each other as little as they can (D-2):
\ (CG)+0 the word being built (CG)+1 its next free slot
\ (CG)+2 how many literals it owes, and (CG)+3 .. (CG)+8 the literals
\ (CG)+9 the opcode (OP,) was given (CG)+10 the ref (BRANCH>) is making
\ (CG)+9 the opcode (OP,) was given (CG)+10 the ref (BRANCH0) made
\ (CG)+11 the target a branch is to reach (CG)+12 which literal (FLUSH) is at
\ (CG)+13 what (FLUSH) fills unused slots with: nop, or 0 after a branch
\
\ The word being built is kept right-justified: each opcode is shifted in
\ below the ones before it, and (FLUSH) shifts in what fills the rest and the
\ two spare bits. So nothing is ever shifted by a counted loop, which would
\ want a return-stack entry for its count.
\ ( x n -- x' ) x shifted left n places, n >= 0
: (LSHIFT) if Z -1 + push L: 2* next L ; Z: drop ;
\ ( k -- n ) the number of the lowest bit of slot k: 27 - 5k
: (LOWBIT) dup 2* 2* + NEGATE 27 + ;
\ ( k -- mask ) the address bits of a branch in slot k
: (MASK) (LOWBIT) 1 SWAP (LSHIFT) -1 + ;
\ ( k -- mask ) the address bits of a branch in slot k: 2^(27-5k) - 1
: (MASK)
if K0 -1 + if K1 -1 + if K2
drop 4095 ;
K2: drop 131071 ;
K1: drop 4194303 ;
K0: drop 134217727 ;
\ ( -- ) forget the word being built
: (CG-RESET) 0 (CG) a! ! 0 (CG)+1 a! ! 0 (CG)+2 a! ! ;
: (CG-RESET) 0 (CG) a! ! 0 (CG)+1 a! ! 0 (CG)+2 a! ! 28 (CG)+13 a! ! ;
\ ( op -- ) into the next free slot. The slot must be free. The shift is
\ (LSHIFT) in line; the slot's lowest bit is never bit 0, so it shifts at
\ least once.
\ ( x -- ) five bits into the next free slot, which must be free
: (PUT)
(CG)+1 a! @ dup 1 + ! \ op k
(LOWBIT) -1 + push L: 2* next L
(CG) a! @ + ! ;
(CG) a! @ 2* 2* 2* 2* 2* + !
(CG)+1 a! @ 1 + ! ;
\ ( -- ) append the word being built, its unused slots nop, then the
\ ( -- ) append the word being built, its unused slots filled, then the
\ literals it owes; nothing if no slot is in use
: (FLUSH)
(CG)+1 a! @ if EMPTY drop
P: (CG)+1 a! @ -6 + if FULL drop 28 (PUT) jump P
P: (CG)+1 a! @ -6 + if FULL drop (CG)+13 a! @ (PUT) jump P
FULL: drop
(CG) a! @ ,
(CG) a! @ 2* 2* , \ the two spare bits
0 (CG)+12 a! !
L: (CG)+12 a! @ (CG)+2 a! @ xor if DONE
drop (CG)+12 a! @ dup 1 + ! (CG)+3 + a! @ ,
@@ -85,16 +87,20 @@
\ ( op -- ) a branch (jump 2, call 3, next 5, if 6, -if 7) whose address is
\ not filled in yet. Its ref -- the branch's word address times 8, plus its
\ slot -- is left in (CG)+10. It ends by jumping to (FLUSH), so that the
\ chain of calls under it is one shorter.
\ slot -- is left in (CG)+10. The rest of its word is filled with 0, which
\ is its address field. It ends by jumping to (FLUSH), so that the chain of
\ calls under it is one shorter.
: (BRANCH0)
(CG)+1 a! @ CG-BSLOTS - -if MOVE drop jump PLACED
(CG)+1 a! @ CG-BSLOTS inv + 1 + -if MOVE drop jump PLACED \ slot - CG-BSLOTS
MOVE: drop (FLUSH)
PLACED:
\ the word will be appended at HERE; its literals, if any, come after it
HERE 2* 2* 2* (CG)+1 a! @ + (CG)+10 a! !
(PUT)
6 (CG)+1 a! ! jump (FLUSH)
0 (CG)+13 a! ! jump (FLUSH)
\ ( op -- ref ) the same, leaving the ref, for (RESOLVE) to fill in later
: (BRANCH>) (BRANCH0) (CG)+10 a! @ ;
\ ( ref -- ) put the address in (CG)+11 into the branch at ref
: (RESOLVE1)
@@ -106,9 +112,6 @@
\ ( target ref -- ) put the address into the branch at ref
: (RESOLVE) SWAP (CG)+11 a! ! jump (RESOLVE1)
\ ( op -- ref ) the same, leaving the ref, for (RESOLVE) to fill in later
: (BRANCH>) (BRANCH0) (CG)+10 a! @ ;
\ ( target op -- ) a branch to a known address
: (BRANCH,) SWAP (CG)+11 a! ! (BRANCH0) (CG)+10 a! @ jump (RESOLVE1)
v4/capsule/compile.v4
+47 -39
View File
@@ -28,10 +28,12 @@
\
\ Constants the loader supplies:
\ STATE word address of the variable: non-zero while compiling
\ (C) word address of eight cells of scratch for this file:
\ (C) word address of ten cells of scratch for this file:
\ (C)+0 (C)+1 (C)+4 the in-liner's word, literal pointer and slot
\ (C)+2 LATEST before a header is made (C)+3 a data word's routine
\ (C)+5 what a loop's end lays after its test
\ (C)+6 (C)+7 a branch and a tag a control word is holding
\ (C)+8 whether a data word's entry was made
\ (CFP) word address of the control-flow stack's pointer
\ CFBASE CFEND word addresses of its first cell and of the cell past its last
@@ -65,15 +67,16 @@ macro ROT push SWAP pop SWAP endmacro
\ ---- compiling one word ------------------------------------------------------
\ ( x n -- x' ) x shifted right n places; the bits that come in at the top
\ are masked off by the caller
: (RSHIFT) if Z -1 + push L: 2/ next L ; Z: drop ;
\ ( w -- op ) the opcode in slot 0 of the instruction word w
: (TOP5) 8/ 8/ 8/ 2/ 2/ 2/ 31 and ;
\ ( xt -- ) copy the in-line word at xt into the definition being built
\ ( xt -- ) copy the in-line word at xt into the definition being built.
\ Each slot is read from the top of the word in (C)+0, which is then moved
\ up five bits for the next.
: (INLINE,)
W: dup a! @ (C) a! ! 1 + (C)+1 a! ! \ the word, and its literals after it
0 (C)+4 a! ! \ slot
S: (C)+4 a! @ (LOWBIT) (C) a! @ SWAP (RSHIFT) 31 and \ op
S: (C) a! @ dup 2* 2* 2* 2* 2* ! (TOP5) \ op
if END \ ; ends the copy
dup -8 + if LIT
drop dup -28 + if NOP \ nop is padding
@@ -86,7 +89,7 @@ macro ROT push SWAP pop SWAP endmacro
\ ( xt -- ) compile the word at xt: in line if it is flagged so, else a call
: (COMPILE,)
dup (FLAGS) a! @ 8 and if CALL drop jump (INLINE,)
dup -3 + a! @ 8 and if CALL drop jump (INLINE,)
CALL: drop jump (CALL,)
header EXECUTE
@@ -130,7 +133,7 @@ header INTERPRET
: INTERPRET
L: 32 WORD dup C@ if EOL
drop (LOOKUP) if NUM
dup (FLAGS) a! @ \ xt flags
dup -3 + a! @ \ xt flags
STATE a! @ if INTERP
drop 1 and if COMP \ compiling: immediate words still run
drop EXECUTE jump L
@@ -163,18 +166,13 @@ header ' immediate
\ ---- colon definitions -----------------------------------------------------------
\ ( -- flag ) an entry for the next word in the input stream; -1 if one was
\ made. (C)+2 holds LATEST meanwhile, to tell.
: (NAMED)
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop -1 ;
NONE: ;
\ FORTH-79: start a definition; it cannot be found until ; ends it
\ FORTH-79: start a definition; it cannot be found until ; ends it.
\ (C)+2 holds LATEST while the entry is made, to tell whether one was.
header :
: COLON
(NAMED) if NONE drop
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
HIDDEN (CG-RESET) CFBASE (CFP) a! ! jump RIGHT-BRACKET
NONE: drop ;
@@ -212,29 +210,33 @@ header [COMPILE] immediate compile-only
: (DOVAR) pop ; \ leave the parameter field address
: (DOCON) pop a! @ ; \ leave what it holds
\ ( -- flag ) an entry for the next word, flagged data, its code a call to
\ the routine whose address is in (C)+3; -1 if one was made
\ ( -- ) an entry for the next word, flagged data, its code a call to the
\ routine whose address is in (C)+3. (C)+8 is left -1 if one was made, else
\ 0. It ends by jumping, and CREATE jumps to it, so that a defining word
\ has as few return entries under it as can be.
: (DATA)
LATEST (C)+2 a! ! \ (NAMED), in line: the calls
32 WORD (HEADER) \ below this are deep enough
0 (C)+8 a! !
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
(CG-RESET)
LATEST (FLAGS) a! @ 4 OR !
(C)+3 a! @ (CALL,) -1 ;
NONE: ;
-1 (C)+8 a! !
(C)+3 a! @ jump (CALL,)
NONE: drop ;
\ FORTH-79: an entry whose word leaves the address of its parameter field
header CREATE
: CREATE &(DOVAR) (C)+3 a! ! (DATA) drop ;
: CREATE &(DOVAR) (C)+3 a! ! jump (DATA)
\ FORTH-79: CREATE and one cell. The standard leaves its first value to the
\ programme; here it is 0.
header VARIABLE
: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) if NONE drop 0 jump , NONE: drop ;
: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
\ ( n -- ) FORTH-79: an entry whose word leaves n
header CONSTANT
: CONSTANT &(DOCON) (C)+3 a! ! (DATA) if NONE drop jump , NONE: drop drop ;
: CONSTANT &(DOCON) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop jump , NONE: drop drop ;
\ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become
\ what each word DEFINER makes does, starting with its parameter field address
@@ -257,7 +259,7 @@ header DOES> immediate compile-only
: (PAIR) xor if OK drop pop drop jump (ABANDON) OK: drop ;
\ ( ref -- ) the branch at ref lands here
: (HERE!) (LABEL) SWAP jump (RESOLVE)
: (HERE!) (FLUSH) HERE SWAP jump (RESOLVE)
\ Native if leaves the flag, so both ways out of it drop it (section 2):
\ IF a THEN if L1 drop a jump L2 L1: drop L2:
@@ -315,18 +317,24 @@ header REPEAT immediate compile-only
: (again) drop push push ;
: (3drop) drop drop drop ;
\ lay <less>: ( i' lim -- i' lim s ), the top bit of s set when i' < lim
: (LESS,)
\ The end of a loop. The control-flow stack holds the body's address and 5,
\ or for ?DO its skip, the body and 6; (C)+5 holds the xt of in-line code to
\ lay after the test, or 0. Laid down, in order:
\ <less> ( i' lim -- i' lim s ), the top bit of s set when i' < lim:
\ over over xor -if SAME drop over jump T SAME: drop over over - T:
\ the code in (C)+5, if any
\ -if EXIT drop push push jump BODY EXIT: drop drop drop
\ and for ?DO the landing of its skip: jump PAST SKIP: drop drop drop PAST:
\ It is one word, jumped to by LOOP and +LOOP, so that laying a loop's end
\ takes as few return entries as laying anything else.
: (LOOPS)
&(?do) (INLINE,) 7 (BRANCH>) >CF
&(differ) (INLINE,) 2 (BRANCH>) (C)+6 a! !
CF> (HERE!) &(same) (INLINE,)
(C)+6 a! @ jump (HERE!)
\ The end of a loop, after its increment and test. The control-flow stack
\ holds the body's address and 5, or for ?DO its skip, the body and 6.
\ -if EXIT drop push push jump BODY EXIT: drop drop drop
\ and for ?DO the landing of its skip: jump PAST SKIP: drop drop drop PAST:
: (LOOP-END)
(C)+6 a! @ (HERE!)
(C)+5 a! @ if NOMORE (INLINE,) jump TESTED
NOMORE: drop
TESTED:
CF> (C)+7 a! ! \ the tag
7 (BRANCH>) (C)+6 a! !
&(again) (INLINE,) CF> (JUMP,)
@@ -343,6 +351,6 @@ header DO immediate compile-only
header ?DO immediate compile-only
: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF
header LOOP immediate compile-only
: LOOP &(inc) (INLINE,) (LESS,) jump (LOOP-END)
: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS)
header +LOOP immediate compile-only
: +LOOP &(+inc) (INLINE,) (LESS,) &(a-xor) (INLINE,) jump (LOOP-END)
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
v4/capsule/core.v4
+15 -8
View File
@@ -44,23 +44,30 @@ header DNEGATE
L1: drop 1 + ;
\ ---- section 5.3: bytes --------------------------------------------------
\ The shifts are written out, eight to a line, where DECOMPOSITION.md 5.3 has
\ a FOR ... UNEXT loop: a loop keeps its count on the return stack, and C@ and
\ C! are at the bottom of every chain of calls in the compiler capsule, where
\ there is not an entry to spare (D-2). The result is the same.
macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro
macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro
header C@
: C@ ( baddr -- c )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop @ 23 FOR 2/ UNEXT 255 and ;
K2: drop @ 15 FOR 2/ UNEXT 255 and ;
K1: drop @ 7 FOR 2/ UNEXT 255 and ;
drop @ 8/ 8/ 8/ 255 and ;
K2: drop @ 8/ 8/ 255 and ;
K1: drop @ 8/ 255 and ;
K0: drop @ 255 and ;
header C!
: C! ( c baddr -- )
dup 2/ 2/ a! 3 and push 255 and pop
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop 23 FOR 2* UNEXT @ 4278190080 inv and + ! ;
K2: drop 15 FOR 2* UNEXT @ -16711681 and + ! ;
K1: drop 7 FOR 2* UNEXT @ -65281 and + ! ;
K0: drop @ -256 and + ! ;
drop 8* 8* 8* 4278190080 and @ 4278190080 inv and + ! ;
K2: drop 8* 8* 16711680 and @ -16711681 and + ! ;
K1: drop 8* 65280 and @ -65281 and + ! ;
K0: drop 255 and @ -256 and + ! ;
\ ---- section 5.9: strings ------------------------------------------------
header CMOVE
v4/capsule/dict.v4
+21 -23
View File
@@ -118,12 +118,7 @@ header HIDDEN
\ ---- making an entry -------------------------------------------------------
\ (D)+0 where the name starts (D)+1 the name being looked up
\ (D)+2 the name being copied, or the entry being looked at
\ (D)+3 a count (D)+4 (CLIP)'s string
\ ( baddr -- baddr ) cut the counted string to 31 characters, in place
: (CLIP)
dup (D)+4 a! ! C@ -32 + -if LONG drop (D)+4 a! @ ;
LONG: drop 31 (D)+4 a! @ C! (D)+4 a! @ ;
\ (D)+3 a count
\ ( -- bytes ) what an entry for a name of (D)+3 characters takes: its name
\ cells and three more
@@ -157,27 +152,30 @@ header HIDDEN
\ ---- looking a name up -----------------------------------------------------
\ ( -- flag ) the name of the entry in (D)+2 is the counted string in (D)+1
: (NAME=)
(D)+2 a! @ >NAME (D) a! !
(D)+1 a! @ C@ 1 + (D)+3 a! ! \ the count byte and the characters
L: (D)+3 a! @ if SAME -1 + dup ! \ k
dup (D) a! @ + C@ \ k c1
SWAP (D)+1 a! @ + C@ \ c1 c2
xor if EQ drop 0 ;
EQ: drop jump L
SAME: drop -1 ;
\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string
\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string.
\ Written out in one piece -- the string cut to 31, each entry's flags and
\ name fetched, the two names compared byte by byte -- so that the only call
\ it makes is C@: it is called from the interpreter for every word of every
\ line, with the user's return stack beneath it.
: (LOOKUP)
(CLIP) (D)+1 a! !
dup (D)+1 a! ! \ cut the string to 31 characters
C@ -32 + -if LONG drop jump CUT
LONG: drop 31 (D)+1 a! @ C!
CUT:
LATEST
L: if END
(D)+2 a! !
(D)+2 a! @ (FLAGS) a! @ 2 and if VISIBLE drop jump OLDER
VISIBLE: drop (NAME=) if DIFF drop (D)+2 a! @ ;
DIFF: drop
OLDER: (D)+2 a! @ >LINK a! @ jump L
(D)+2 a! @ -3 + a! @ 2 and if VISIBLE drop jump OLDER
VISIBLE: drop
(D)+2 a! @ -2 + a! @ 4* (D) a! ! \ its name
(D)+1 a! @ C@ 1 + (D)+3 a! ! \ the count byte and the characters
C: (D)+3 a! @ if SAME -1 + dup ! \ k
dup (D) a! @ + C@ \ k c1
SWAP (D)+1 a! @ + C@ \ c1 c2
xor if EQ drop jump OLDER
EQ: drop jump C
SAME: drop (D)+2 a! @ ;
OLDER: (D)+2 a! @ -1 + a! @ jump L
END: ;
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the