commit fee509b30df1cafc0d966db1bf2535cc13a3357b
parent 51064d6055e25bbc86d9264b0d826d1b9e94f4d5
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 5 Sep 2022 15:47:49 -0400
cc: improve forth vm
All tests in tests/cc/vm now pass. The next step, making the VM work under
cc/gen, should be a matter of course, right? ... right?
Diffstat:
5 files changed, 72 insertions(+), 49 deletions(-)
diff --git a/Makefile b/Makefile
@@ -36,11 +36,6 @@ run: dusk
test: dusk
echo "' byefail to abort f<< tests/all.fs bye" | ./dusk || (echo; exit 1)
-# temporary while developing the Forth CC VM.
-.PHONY: testvm
-testvm: dusk
- echo "' byefail to abort f<< tests/cc/vm.fs bye" | ./dusk || (echo; exit 1)
-
.PHONY: clean
clean:
rm -f $(TARGETS) dusk.o fs/init.fs posix/boot.fs memdump *.bin *.img
diff --git a/fs/cc/vm/common.fs b/fs/cc/vm/common.fs
@@ -13,10 +13,13 @@
$00 const VM_NONE
$01 const VM_CONSTANT \ 42
$02 const VM_STACKFRAME \ esp+x
+$03 const VM_ARGSFRAME \ ebp+x
+$04 const VM_REGISTER \ eax
$05 const VM_CONSTARRAY \ pointer to an array with the 1st elem being length
$11 const VM_*CONSTANT \ [1234]
$12 const VM_*STACKFRAME \ [esp+x]
$13 const VM_*ARGSFRAME \ [ebp+x]
+$14 const VM_*REGISTER \ [eax]
\ 2 operands, 2 fields each (type, arg), 4b per field
create operands 16 allot0
@@ -26,12 +29,16 @@ operands value 'curop
: selop2 ( -- ) operands 8 + to 'curop ;
: selectedop ( -- n ) \ 0 == Op1 1 == Op2
'curop operands = not ;
+: selop^ selectedop if selop1 else selop2 then ;
: optype ( -- type ) 'curop @ ;
+: optypelo optype $f and ;
+: opderef? ( -- f ) optype $10 and bool ;
: optype! ( type -- ) 'curop ! ;
-: oparg ( -- arg ) 'curop 4 + @ ;
-: oparg! ( arg -- ) 'curop 4 + ! ;
+: 'oparg 'curop 4 + ;
+: oparg ( -- arg ) 'oparg @ ;
+: oparg! ( arg -- ) 'oparg ! ;
-: .ops 4 >r operands begin dup @ .x spc> 4 + next drop nl> ;
+: .ops selectedop .x1 spc> 4 >r operands begin @+ .x spc> next drop nl> ;
\ Managing operands
@@ -48,3 +55,8 @@ operands value 'curop
: oppop ( oparg optype -- ) noop# optype! oparg! ;
+\ Swap op1 and op2 types/args
+: op1<>op2
+ selop1 optype oparg
+ selop2 oparg swap oparg! optype rot optype!
+ selop1 optype! oparg! ;
diff --git a/fs/cc/vm/forth.fs b/fs/cc/vm/forth.fs
@@ -4,8 +4,21 @@
\ the advantage of working under any architecture.
?f<< /cc/vm/common.fs
-\ Operands that are specific to this VM
-$04 const VM_TOS \ op is on current TOS. Only one of them can have this type.
+\ How the VM works
+\ Generally, CPUs have registers that we want to use for performance reasons.
+\ With a forth backend, the fastest way to proceed will generally to keep things
+\ on PS. However, tracking PS levels for op1 and op2 is complex and because the
+\ uses of this backend are limited, we opt for the simplest approach: what we
+\ call a "register" in this backend are two 32-bit memory area reserved for op1
+\ and op2. Those memory areas correspond to "oparg", which is the area itself
+\ directly.
+
+\ VM_TOS is a special type of optype which indicates that the op lives on PS
+\ directly. This optype is set after an operation and has limited uses: it is
+\ used to return a value during vmret, and it is used as a staging area to be
+\ pushed to a register.
+$06 const VM_TOS
+$16 const VM_*TOS
\ To simplify argframe management, we copy the args to the buffer below during
\ vmprelude, and then refer to this buffer whenever we need to. This way, when
@@ -13,38 +26,51 @@ $04 const VM_TOS \ op is on current TOS. Only one of them can have this type.
$40 const MAXARGSZ
create argsframe MAXARGSZ allot
-: opdeinit optype $f and VM_TOS = if 4 p+, then VM_NONE optype! ;
+: opdeinit VM_NONE optype! ;
: ops$
selop2 opdeinit selop1 opdeinit
operands 16 0 fill ;
-\ Resolve current operand and compile a push to PS
-: op>PS ( -- )
- optype case
+: TOS# selop^ optypelo VM_TOS <> _assert selop^ ;
+: op>TOS VM_TOS optype! ;
+: op>*TOS VM_*TOS optype! ;
+
+: _ ( optype -- )
+ case
VM_CONSTANT of = oparg litn endof
VM_STACKFRAME of = oparg r', endof
- VM_TOS of = VM_NONE optype! endof
- VM_*CONSTANT of = oparg litn compile @ endof
- VM_*STACKFRAME of = oparg r', compile @ endof
- VM_*ARGSFRAME of = argsframe oparg + litn compile @ endof
+ VM_ARGSFRAME of = argsframe oparg + litn endof
+ VM_REGISTER of = 'oparg litn compile @ endof
+ VM_TOS of = endof \ nothing to do
_err endcase ;
-\ if possible, transform current operand in its reference
-: &op>op optype case
- VM_*STACKFRAME of = VM_STACKFRAME optype! endof
- VM_*CONSTANT of = VM_CONSTANT optype! endof
- _err endcase ;
+\ Resolve current operand and compile a push to PS as either VM_TOS or VM_*TOS.
+: opCompile ( -- )
+ opderef? if optypelo _ op>*TOS else optype _ op>TOS then ;
-\ if possible, dereference current operand
-: *op>op optype case
- VM_CONSTANT of = VM_*CONSTANT optype! endof
- VM_*CONSTANT of = abort" TODO" endof
- VM_STACKFRAME of = VM_*STACKFRAME optype! endof
- VM_*STACKFRAME of = abort" TODO" endof
- VM_*ARGSFRAME of = abort" TODO" endof
- VM_TOS of = compile @ endof
- _err endcase ;
+\ Resolve current operand and forces dereferencing. Always yields VM_TOS.
+: opCompile* ( -- )
+ opCompile optype VM_*TOS = if compile @ op>TOS then ;
+
+\ transform current operand in its reference
+: ?&op>op ( -- f ) opderef? if optypelo optype! 1 else 0 then ;
+: &op>op ?&op>op _assert ;
+
+: op>reg optypelo VM_REGISTER = if exit then
+ hasop# ?&op>op ( f ) opCompile 'oparg litn compile ! ( f )
+ 4 lshift VM_REGISTER or optype! ;
+
+\ If any of the op is VM_TOS, push it to a register.
+: _ optypelo VM_TOS = if op>reg then ;
+: ?tos>reg _ selop^ _ selop^ ;
+
+\ dereference current operand
+: *op>op opderef? if
+ opCompile* op>*TOS op>reg else
+ optype $10 or optype! then ;
+
+: oppop ( oparg optype -- ) noop# ?tos>reg optype! oparg! ?tos>reg ;
\ generate function prelude code by allocating "locsz" bytes on RS.
: vmprelude, ( argsz locsz -- )
@@ -55,9 +81,10 @@ create argsframe MAXARGSZ allot
locsz if locsz neg r+, then ;
: binop doer ' , does> @ ( w )
- selop1 op>PS selop2 hasop# op>PS
+ selop1 opCompile* opdeinit \ op1 is "lost" on PS
+ selop2 hasop# opCompile* opdeinit \ op2 is "lost" on PS
( w ) execute,
- opdeinit selop1 VM_TOS optype! ;
+ selop1 op>TOS ; \ result in op1 as VM_TOS
binop vmadd, +
binop vmsub, -
@@ -67,14 +94,13 @@ binop vmmul, *
\ op2. In other words, perform a AST_ASSIGN with the right part as op2
\ and the left part as op1.
: vmmov,
- selop2 hasop# op>PS selop1 &op>op op>PS
- compile !
- opdeinit selop2 opdeinit selop1 ;
+ selop2 hasop# opCompile* opdeinit \ op2 is "lost" on PS
+ selop1 &op>op opCompile* opdeinit compile ! ;
\ deallocate locsz and argsz. If result is set, keep a 4b in here and push the
\ result there.
: vmret,
selop2 noop# \ returning with a second operand? something's wrong
+ selop1 optype if opCompile* opdeinit then
locsz if locsz r+, then
- selop1 optype if op>PS opdeinit then
exit, ;
diff --git a/fs/cc/vm/i386.fs b/fs/cc/vm/i386.fs
@@ -43,10 +43,6 @@
?f<< asm/i386.fs
?f<< /cc/vm/common.fs
-\ Operands that are specific to this VM
-$04 const VM_REGISTER \ eax
-$14 const VM_*REGISTER \ [eax]
-
\ Register management
\ When an operand needs to go to a register, we allocate one for it. when it
\ doesn't need it anymore, we deallocate it. Registers have to be deallocated
@@ -145,12 +141,6 @@ create registers AX c, BX c, CX c, DX c, SI c, DI c,
VM_*REGISTER of = opderef VM_*REGISTER optype! endof
_err endcase ;
-\ Swap op1 and op2 types/args
-: op1<>op2
- selop1 optype oparg
- selop2 oparg swap oparg! optype rot optype!
- selop1 optype! oparg! ;
-
\ Code generation - Functions, calls, ret, pspush, pspop
\ generate function prelude code by allocating "locsz" bytes on RS.
diff --git a/fs/tests/cc/all.fs b/fs/tests/cc/all.fs
@@ -1,6 +1,6 @@
\ Run all CC test suites
f<< tests/cc/tree.fs
f<< tests/cc/ast.fs
-HASCC not [if] \s [then]
f<< tests/cc/vm.fs
+HASCC not [if] \s [then]
f<< tests/cc/cc.fs
