commit f83fc6dde2295f4197d67842107416b8ef3579a4
parent b3fe55802ac441619f39813d0ece0a9e57905cd8
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 27 Feb 2023 21:18:31 -0500
Change (br) and (?br) into branch, and ?branch,
I'm not sure, but I *think* I'm going somewhere nice.
Diffstat:
6 files changed, 75 insertions(+), 60 deletions(-)
diff --git a/fs/comp/c/vm/forth.fs b/fs/comp/c/vm/forth.fs
@@ -81,9 +81,9 @@ struct+[ VMOp
: vmpspush, vmop :compile$ PS- ;
\ Jumping
-: ]vmjmp ( 'jump_addr -- ) here swap ! ;
-: vmjmp, ( a -- ) [compile] again ;
-: vmjmp[, ( -- a ) compile (br) here 4 allot ;
+: ]vmjmp [compile] then ;
+: vmjmp, [compile] again ;
+: vmjmp[, [compile] ahead ;
\ In conditional jumps below, the source of the test is in current op
\ However, because we don't track "psoff" across branches, we *have* to have a
\ neutral level before the jump, which means that this flag that we're pushing
diff --git a/fs/doc/arch.txt b/fs/doc/arch.txt
@@ -207,7 +207,7 @@ configure its size.
## Parens words ()
At the core of each kernel is a set of words that all have their name wrapped
-inside parentheses, such as (br), (val), etc. These words are designed to not
+inside parentheses, such as (cell), (does), etc. These words are designed to not
be called directly, but compiled inside a definite structure. These structures
are documented here:
@@ -221,10 +221,3 @@ Does *not* obey "to" semantics.
(s): A string literal, compiled by S". It pushes PC+1 to PS, which is the
address of the first character of the string. Then, it reads the byte at PC+0,
which is the length of the string, and pushes it to PS.
-
-(br): Compiled by "again" and "else", it's an unconditional branch. It works
-like (alias), but ignores "to" semantics.
-
-(?br): Compiled by "if" and "until", a conditional branch. It pops from PS and
-if the popped value is zero, branches exactly like (br). Otherwise, it continues
-to PC+4.
diff --git a/fs/doc/dict.txt b/fs/doc/dict.txt
@@ -332,7 +332,12 @@ which can then be executed to have the desired effect.
; -- *I* Compile a return from call and then stop compiling.
litn n -- Compile a literal with value n.
execute, a -- Compile a call to address a.
-alias, a -- Compile a jump to address a.
+branch, a -- a Compile a jump to address a and yield an address for branch!
+ if it's a forward jump.
+?branch, a -- a Like branch, but compiles a conditional jump, that is, code
+ that consumes PS top and jumps if it's zero.
+branch! n a -- With "a" being the output of branch, or ?branch, make that
+ branching target address "n".
exit, -- Compile a return from call.
compile "x" -- *I* Find word x and compile a compilation of a call to it.
[compile] "x" -- *I* Find immediate word x and instead of executing it
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -10,6 +10,7 @@
," code" 0 , sysdict @ , 4 c, HERE @ w>e sysdict ! ]
sysdict word entry ;
code : ] code ] ;
+code drop 4 p+, exit,
: e>w 5 + ;
: current sysdict @ e>w ;
: immediate current 1- dup c@ $80 or swap c! ;
@@ -17,18 +18,17 @@ code : ] code ] ;
: compile ' litn ['] execute, execute, ; immediate
: [compile] ' execute, ; immediate
: allot HERE +! ;
-: if compile (?br) HERE @ 4 allot ; immediate
-: ahead compile (br) HERE @ 4 allot ; immediate
-: then HERE @ swap ! ; immediate
-: else [compile] ahead HERE @ rot ! ; immediate
+: if 0 ?branch, ; immediate
+: ahead 0 branch, ; immediate
+: then HERE @ swap branch! ; immediate
+: else [compile] ahead HERE @ rot branch! ; immediate
: begin HERE @ ; immediate
-: again compile (br) , ; immediate
-: until compile (?br) , ; immediate
+: again branch, drop ; immediate
+: until ?branch, drop ; immediate
: = - not ;
: \ begin in< $0a = until ; immediate
\ hello, this is a comment!
: exit exit, ; immediate
-code drop 4 p+, exit,
: ( begin
word dup c@ 1 = if
1+ c@ ')' = if exit then else drop then
@@ -93,8 +93,6 @@ $11 const EMETA_16B
: 16b EMETA_16B MOD ! ; immediate
\ Compiling words
-\ TODO: 5 is hardcoded, might not work on all arches
-5 const CALLSZ
create _ 0 ,
: doer code compile (does) HERE @ _ ! CELLSZ allot ;
: does> r> ( exit current definition ) _ @ ! ;
@@ -104,7 +102,7 @@ _to to ! A!, _to to+ +! A+!, _to to' noop A>,
: _toexec ( a -- ) compiling if LIT>A, then toptr@ execute ;
: value doer , immediate does> _toexec ;
: here HERE _toexec ; immediate
-: alias ' code alias, ;
+: alias ' code branch, drop ;
alias @ llnext
: llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ;
@@ -150,10 +148,11 @@ _to to!+ @!+ _
: &+w@ ( n -- ) doer , does> @ + w@ ;
: &+c@ ( n -- ) doer , does> @ + c@ ;
-: realias ( 'new 'tgt -- ) to@! here swap alias, to here ;
+: realias ( 'new 'tgt -- ) to@! here swap branch, drop to here ;
: _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ;
: chain ( w1 w2 -- w )
- _ swap _ tuck over and? if here rot execute, swap alias, else ?swap nip then ;
+ _ swap _ tuck over and? if
+ here rot execute, swap branch, drop else ?swap nip then ;
alias noop idle
alias execute | immediate
@@ -179,7 +178,6 @@ alias execute | immediate
: next
[compile] yield [compile] again [compile] then
12 r+, 4 [rcnt] +! 0 to@! _breaklbl ?dup drop ; immediate
-CALLSZ CELLSZ + const BRSZ
: unyield RSP>A, BRSZ [A]+, ; immediate
: break 16 r+, [compile] ahead to _breaklbl ; immediate
diff --git a/fs/xcomp/i386/kernel.fs b/fs/xcomp/i386/kernel.fs
@@ -41,9 +41,10 @@ L1 forward!
lblidt m) lidt, sti,
forward16 jmp, to L1
-xcode IDT
- L2 pspushN,
- ret,
+xcode IDT L2 pspushN, ret,
+xcode CALLSZ 5 pspushN, ret,
+xcode BRSZ 5 pspushN, ret,
+xcode ?BRSZ 14 pspushN, ret,
xcode noop pc to lblret ret,
@@ -67,18 +68,6 @@ xcode (s)
si ax add, \ ret to PC right after str
si jmp,
-xcode (br)
- ax pop,
- ax 0 d) jmp,
-
-xcode (?br)
- AX pspop,
- ax ax or,
- xwordlbl (br) abs>rel jz,
- ax pop,
- ax CELLSZ i) add,
- ax jmp,
-
xcode herestart
HERESTART pspushN,
ret,
@@ -760,16 +749,36 @@ xcode execute,
BX pspop,
lblcallwr absjmp,
-xcode alias,
- al $e9 ( jmp ) i) mov,
- lblcwrite abscall,
- AX pspop,
- lblrelwr absjmp,
-
xcode exit,
al $c3 ( ret ) i) mov,
lblcwrite absjmp,
+xcode branch,
+ al $e9 ( jmp ) i) mov, lblcwrite abscall,
+ AX pspop,
+ lblrelwr abscall,
+ ax lblhere m) mov,
+ ax 4 i) sub,
+ AX pspush,
+ ret,
+
+pc 10 nc, $8b $45 $00 $83 $c5 $04 $85 $c0 $0f $84 \ AX pspop, ax ax test, XX jz,
+xcode ?branch,
+ ( pc ) 10 movewrite,
+ AX pspop,
+ lblrelwr abscall,
+ ax lblhere m) mov,
+ ax 4 i) sub,
+ AX pspush,
+ ret,
+
+xcode branch!
+ AX BX pspop2, \ ax=a bx=n
+ bx ax sub, \ displacement
+ bx 4 i) sub, \ ... from *after* call/jmp op
+ ax 0 d) bx mov,
+ ret,
+
pc 2 nc, $89 $e7 \ di sp mov,
xcode RSP>A,
( pc ) 2 movewrite, ret,
diff --git a/posix/vm.c b/posix/vm.c
@@ -233,18 +233,27 @@ static void SLIT() { // op: 0b
vm.PC = a + gb(a) + 1;
}
-static void BR() { // op: 0c
- vm.PC = gd(rpop());
+// ( a -- a )
+static void BRWR() { // op: 0c
+ dword a = here()+1;
+ jumpwr(ppop());
+ ppush(a);
}
static void CBR() { // op: 0d
- if (ppop()) {
- rpush(rpop()+4);
- } else {
- BR();
- }
+ dword a = gpc();
+ if (!ppop()) vm.PC = a;
}
+// ( a -- a )
+static void CBRWR() { // op: 0e
+ dword a = here()+1;
+ cwrite(0x0d); // CBR
+ dwrite(ppop());
+ ppush(a);
+}
+
+// ( a -- a )
static void YIELD() { // op: 0f
dword pc = vm.PC;
vm.PC = rpop();
@@ -695,9 +704,6 @@ static void COMPILING() { // op: 57
ppush(vm.compiling);
}
-static void ALIASWR() { // op: 58
- jumpwr(ppop());
-}
static void STARTCOMP() { // op: 59
vm.compiling = 1;
}
@@ -1024,7 +1030,7 @@ static void DRVWR() { // op: 6b
#define OPCNT 0x6c
static void (*ops[OPCNT])() = {
JUMP, CALL, RET, LIT, BYE, BYEFAIL, QUIT, ABORT_,
- EXECUTE, CELL, DOES, SLIT, BR, CBR, NULL, YIELD,
+ EXECUTE, CELL, DOES, SLIT, BRWR, CBR, CBRWR, YIELD,
PSADD, PSADDWR, NULL, NULL, BOOTRD, STDOUT, MAYBEKEY, FINDMETA,
DUP, CDUP, SWAP, OVER, ROT, ROTR, NIP, TUCK,
RSADD, RSADDWR, NULL, NULL, SCNT, RCNT, RSP2A, PSP2A,
@@ -1034,13 +1040,13 @@ static void (*ops[OPCNT])() = {
OR, XOR, BOOL, NOT, LT, SHLC, SHRC, LSHIFT,
RSHIFT, NULL, NULL, NULL, MOVE, MOVEWR, FINDMOD, WNF,
STACKCHK, MAYBEWORD, WORD, PARSE, REQ, FIND, APOS, COMPILING,
- ALIASWR, STARTCOMP, STOPCOMP, COMPWORD, RUNWORD, USLEEP, NULL, NULL,
+ NULL, STARTCOMP, STOPCOMP, COMPWORD, RUNWORD, USLEEP, NULL, NULL,
FCHILD, FOPEN, FREADBUF, FCLOSE, FINFO, FITER, NULL, FSEEK,
MOUNTDRV, UNMOUNTDRV, DRVRD, DRVWR};
static char *opnames[OPCNT] = {
NULL, NULL, NULL, NULL, "bye", "byefail", "quit", "(abort)",
- "execute", "(cell)", "(does)", "(s)", "(br)", "(?br)", NULL, NULL,
+ "execute", "(cell)", "(does)", "(s)", "branch,", NULL, "?branch,", NULL,
NULL, "p+,", NULL, NULL, "boot<", "(emit)", "(key?)", "findmeta",
"dup", "?dup", "swap", "over", "rot", "rot>", "nip", "tuck",
NULL, "r+,", NULL, NULL, "scnt", "rcnt", NULL, NULL,
@@ -1050,7 +1056,7 @@ static char *opnames[OPCNT] = {
"or", "xor", "bool", "not", "<", "<<c", ">>c", "lshift",
"rshift", NULL, NULL, NULL, "move", "move,", "findmod", "(wnf)",
"stack?", "maybeword", "word", "parse", "[]=", "find", "'", "compiling",
- "alias,", "]", "[", "compword", "runword", "_usleep", NULL, NULL,
+ NULL, "]", "[", "compword", "runword", "_usleep", NULL, NULL,
"_fchild", "_fopen", "_freadbuf", "_fclose", "_finfo", "_fiter", NULL, "_fseek",
"_mountdrv", "_unmountdrv", "_drv@", "_drv!"};
@@ -1172,10 +1178,14 @@ static void buildsysdict() {
sysalias("in<", "boot<");
inrdaddr = find("in<");
sysalias("rtype", "byefail");
+ sysalias("branch!", "!");
sysconst("HERE", HERE);
sysconst("NEXTWORD", NEXTWORD);
sysconst("HEREMAX", HEREMAX);
sysconst("MOD", MOD);
+ sysconst("CALLSZ", 5);
+ sysconst("BRSZ", 5);
+ sysconst("?BRSZ", 5);
sysconst("curword", CURWORD);
sysconst("sysdict", SYSDICT);
sysconst("nextmeta", NEXTMETA);
