commit b11bf44c2de78b2b425840a0dc9203420aaf4b07
parent 1c6abb4fe0c49a95cdf8a15f7c46b1d4c35f266d
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Tue, 2 Aug 2022 21:23:36 -0400
Introduce the ARCH constant
In CC, move vm.fs to vm/i386.fs and make the loading of the VM unit dependant
on the value of the ARCH constant.
Also, add HASCC constant and make tests skip units requiring CC when HASCC is
false.
Diffstat:
14 files changed, 382 insertions(+), 363 deletions(-)
diff --git a/codesize.sh b/codesize.sh
@@ -1,14 +1,14 @@
#!/bin/sh
echo "Lines of code in Dusk OS"
echo "All Forth code excluding tests:"
-find . -name "*.fs" | grep -v tests | xargs cat | wc -l
+find fs -name "*.fs" | grep -v tests | xargs cat | wc -l
echo "...excluding empty lines and comments:"
-find . -name "*.fs" | grep -v tests | xargs cat | grep -v "^\\\\" | grep -v '^$' | wc -l
+find fs -name "*.fs" | grep -v tests | xargs cat | grep -v "^\\\\" | grep -v '^$' | wc -l
+echo "All C code excluding tests:"
+find fs -name "*.c" | grep -v tests | xargs cat | wc -l
echo "C compiler:"
find fs/cc -type f | xargs cat | wc -l
echo "...excluding empty lines and comments:"
find fs/cc -type f | xargs cat | grep -v "^\\\\" | grep -v '^$' | wc -l
echo "Test code:"
find fs/tests -type f | xargs cat | wc -l
-echo "Assember:"
-cat dusk.asm | wc -l
diff --git a/fs/cc/cc.fs b/fs/cc/cc.fs
@@ -2,7 +2,12 @@
require sys/scratch.fs
require sys/xhere.fs
1 value _debug
-?f<< cc/gen.fs
+S" /cc/vm" findpath# ( hdl )
+scratch[ ARCH c@+ dup 3 + c, move, ," .fs" ]scratch ( hdl fname )
+fchild dup bool const HASCC ( hdl )
+HASCC not [if] drop ." Unsupported arch for CC" nl> \s [then]
+( hdl ) fload
+?f<< /cc/gen.fs
\ Compiles input coming from the stdin alias and writes the
\ result to here. Aborts on error.
diff --git a/fs/cc/gen.fs b/fs/cc/gen.fs
@@ -45,8 +45,8 @@
\ cc/vm abstracts away the save/restore mechanism through oppush/oppop.
?f<< lib/wordtbl.fs
-?f<< cc/vm.fs
?f<< cc/ast.fs
+\ This unit also requires vm/(ARCH).fs, but it's loaded in cc/cc.fs
: _err ( -- ) abort" gen error" ;
: _assert ( f -- ) not if _err then ;
diff --git a/fs/cc/vm.fs b/fs/cc/vm.fs
@@ -1,343 +0,0 @@
-\ C compiler virtual machine
-
-\ The goal of this VM is to provide a unified API for code generation of a C
-\ AST across CPU architecture.
-
-\ Computation done by this generated code is centered around two operands, Op1
-\ and Op2. Those operands can "live" in different places depending on the
-\ context: in a register, in memory, or as a constant.
-
-\ Each of the two operands can be of either of those types:
-
-\ None: operand not specified
-\ Constant: a constant value
-\ Stack Frame: an address on the Stack Frame
-\ Register: value currently being held a register
-
-\ Besides the type, each operand has an accompanying "argument", whose meaning
-\ depend on the type:
-
-\ Constant: the value of the constant
-\ Stack Frame: the offset relative to the SF pointer
-\ Arguments Frame: the offset relative to the AF pointer
-\ Register: the ID of the register
-
-\ On those operands, the VM generates code that perform operations on them.
-\ Although some operations are special, there are basically 2 types of
-\ operations: unary op and binary op.
-
-\ When performing an unary op we:
-\ 1. Assert that op2 is unset
-\ 2. if op1 is not in a register, move the value to a register
-\ 3. Perform the operation on the register
-
-\ When performing an binary op we:
-\ 1. Assert that op2 is set
-\ 2. if op1 is not in a register, move the value to a register
-\ 3. Perform the binary operation with op1 as the target, op2 as the source.
-
-\ To avoid errors, moving an operand to a non-empty and non-pushed Result is an
-\ error. To set the operand when it's not None is also an error.
-
-\ For usage example, see tests/cc/vm.fs
-?f<< asm/i386.fs
-
-: _err abort" vm error" ;
-: _assert not if _err then ;
-
-\ Execution context (function)
-
-0 value argsz \ size of the argument portion of the SF.
-0 value locsz \ size of the "local vars" portion of the SF.
-0 value callsz \ size of the args portion of a Function Call
-
-\ 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
-\ in the reverse order they were allocated.
-\ Allocation works by having a list of register to allocate, and a pointer,
-\ "reglvl" which indicate which register can be used next. When we run out of
-\ register, allocating a register pushes the first register to the stack and
-\ then allocates it.
-
-6 const REGCNT
-create registers AX c, BX c, CX c, DX c, SI c, DI c,
-0 value reglvl
-
-: curreg ( -- regid )
- reglvl REGCNT < if
- registers reglvl + c@ ( regid ) else
- ax push, AX ( regid ) then ;
-: regallot ( -- regid ) curreg 1 to+ reglvl ;
-: regfree ( -- )
- reglvl not if abort" too many regfree" then
- -1 to+ reglvl reglvl REGCNT >= if ax pop, then ;
-
-\ Operands definition and selection
-$00 const VM_NONE
-$01 const VM_CONSTANT \ 42
-$02 const VM_STACKFRAME \ esp+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
-
-operands value 'curop
-: selop1 ( -- ) operands to 'curop ;
-: selop2 ( -- ) operands 8 + to 'curop ;
-: selectedop ( -- n ) \ 0 == Op1 1 == Op2
- 'curop operands = not ;
-: optype ( -- type ) 'curop @ ;
-: optype! ( type -- ) 'curop ! ;
-: oparg ( -- arg ) 'curop 4 + @ ;
-: oparg! ( arg -- ) 'curop 4 + ! ;
-
-\ reinitialize selected op to VM_NONE and dealloc registers if needed
-: opdeinit optype $f and VM_REGISTER = if regfree then VM_NONE optype! ;
-
-\ Deinit both ops and select Op1
-: ops$
- selop2 opdeinit selop1 opdeinit
- reglvl if abort" unbalanced reg allot/free" then
- operands 16 0 fill ;
-: .ops 4 >r operands begin dup @ .x spc> 4 + next drop nl> ;
-
-\ Managing operands
-
-: hasop# optype VM_NONE = not _assert ;
-: isconst# optype VM_CONSTANT = _assert ;
-: noop# optype VM_NONE = _assert ;
-: const>op ( n -- ) noop# VM_CONSTANT optype! oparg! ;
-: constarray>op ( a -- ) noop# VM_CONSTARRAY optype! oparg! ;
-: sf+>op ( off -- ) noop# VM_*STACKFRAME optype! oparg! ;
-: ps+>op ( off -- ) noop# VM_*ARGSFRAME optype! oparg! ;
-: mem>op ( n -- ) noop# VM_*CONSTANT optype! oparg! ;
-
-\ get current operand SF offset, adjusted with callsz
-: opsf+ ( -- off ) oparg callsz + ;
-
-\ Resolve current operand as an assembler "src" argument.
-: opAsm ( -- )
- optype case
- VM_CONSTANT of = oparg i) endof
- VM_STACKFRAME of = abort" can't address VM_STACKFRAME directly" endof
- VM_REGISTER of = oparg r! endof
- VM_*CONSTANT of = oparg m) endof
- VM_*STACKFRAME of = sp oparg d) endof
- VM_*ARGSFRAME of = bp opsf+ d) endof
- VM_*REGISTER of = oparg r! 0 d) endof
- _err endcase ;
-
-\ Force current operand to be copied to a register
-: _ regallot dup r! ( regid ) opAsm mov, oparg! ;
-: op>reg optype case
- VM_CONSTANT of = _ VM_REGISTER optype! endof
- VM_*CONSTANT of = _ VM_REGISTER optype! endof
- VM_REGISTER of = endof
- VM_*REGISTER of = endof
- VM_STACKFRAME of =
- regallot dup r! sp mov,
- oparg if dup r! oparg i) add, then ( regid )
- oparg! VM_REGISTER optype! endof
- VM_*STACKFRAME of = _ VM_REGISTER optype! endof
- VM_*ARGSFRAME of = _ VM_REGISTER optype! endof
- _err
- endcase ;
-
-\ Resolve any referencing into a "simple" result. A VM_STACKFRAME goes into a
-\ register, a VM_*REGISTER is resolved into a VM_REGISTER.
-: opderef
- optype case
- VM_STACKFRAME of = op>reg endof
- VM_*CONSTANT of = op>reg endof
- VM_*STACKFRAME of = op>reg endof
- VM_*ARGSFRAME of = op>reg endof
- VM_*REGISTER of = oparg r! oparg r! 0 d) mov, VM_REGISTER optype! endof
- endcase ;
-
-\ Before doing an operation on two operands, we verify that they are compatible.
-\ For example, we can't have two VM_*REGISTER ops. one of them has to be
-\ dereferenced (it has to be op2).
-: maybederef
- selop1 optype VM_*REGISTER = optype $f and VM_STACKFRAME = or
- optype VM_*ARGSFRAME = or if selop2 opderef then ;
-
-\ 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
- VM_*REGISTER of = VM_REGISTER optype! endof
- _err endcase ;
-
-\ if possible, dereference current operand
-: *op>op optype case
- VM_CONSTANT of = VM_*CONSTANT optype! endof
- VM_*CONSTANT of = op>reg *op>op endof
- VM_STACKFRAME of = VM_*STACKFRAME optype! endof
- VM_*STACKFRAME of = op>reg *op>op endof
- VM_*ARGSFRAME of = op>reg *op>op endof
- VM_REGISTER of = VM_*REGISTER optype! endof
- VM_*REGISTER of = opderef VM_*REGISTER optype! endof
- _err endcase ;
-
-: oppush ( -- oparg optype ) oparg optype VM_NONE optype! ;
-
-: 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! ;
-
-\ Code generation - Functions, calls, ret, pspush, pspop
-
-\ generate function prelude code by allocating "locsz" bytes on PS.
-: vmprelude, ( argsz locsz -- )
- to locsz to argsz
- locsz if sp locsz i) sub, then ;
-\ 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
- argsz selop1 optype if CELLSZ - then
- opderef \ for bp 0 d) src mov, to work, "src" has to be "simple"
- locsz if sp locsz i) add, then
- ?dup if bp i) add, then
- optype if bp 0 d) opAsm mov, then
- ret, ;
-
-: callargallot, ( bytes -- ) dup to callsz ?dup if bp i) sub, then ;
-
-\ Call the address in current op. If the function has a result, you need to
-\ pop it with vmpspop,
-: vmcall, ( -- )
- VM_*CONSTANT optype = if oparg VM_NONE optype! else opAsm then
- abs>rel call, opdeinit 0 to callsz ;
-
-\ Allocate a new register for active op and pop 4b from PS into it.
-: vmpspop,
- noop# VM_REGISTER optype! regallot dup oparg! r! bp 0 d) mov,
- bp CELLSZ i) add, ;
-
-\ Push active op to PS.
-: vmpspush, opderef bp CELLSZ i) sub, bp 0 d) opAsm mov, opdeinit ;
-
-\ Code generation - Binary ops
-: binopprep ( -- ) \ prepare ops for the binop
- selop1 op>reg opAsm
- selop2 hasop# opAsm ;
-: vmadd, binopprep add, opdeinit ;
-: vmsub, binopprep sub, opdeinit ;
-: vm&, binopprep and, opdeinit ;
-: vm|, binopprep or, opdeinit ;
-: vm^, binopprep xor, opdeinit ;
-\ TODO: allow non-const shift right-operand
-: vm<<, binopprep isconst# shl, opdeinit ;
-: vm>>, binopprep isconst# shr, opdeinit ;
-
-\ mul is special and cannot use binopprep for two reasons: its target operand
-\ is hardcoded to EAX and also, EDX gets written by the op, so we need to save
-\ EDX if in use.
-: vmmul,
- reglvl 4 >= if dx push, then
- \ if op1 is not EAX, we need to push EAX, perform the mul, copy EAX to op1's
- \ reg, then pop eax back.
- selop1 op>reg oparg AX = not if ax push, ax opAsm mov, then
- selop2 op>reg hasop# opAsm mul, opdeinit
- selop1 oparg AX = not if opAsm ax mov, ax pop, then
- reglvl 4 >= if dx pop, then ;
-\ Copy the contents of op2 in the memory address pointed out by op1 and deinit
-\ op2. In other words, perform a AST_ASSIGN with the right part as op2
-\ and the left part as op1.
-: vmmov,
- selop2 optype VM_CONSTARRAY = if \ special case, we have a {1, 2, 3} assign
- selop1 optype VM_STACKFRAME = _assert
- *op>op selop2 oparg selop1 dup @ ( a len ) >r begin ( a )
- opAsm 4 + dup @ i) mov, ( a+4 ) oparg 4 + oparg! next ( a )
- drop selop2
- else
- maybederef selop1 opAsm selop2 opAsm mov, then
- opdeinit ;
-
-: binop=prep ( -- ) \ prepare ops a binop of the "assign" type
- selop1 opAsm selop2 hasop# opAsm ;
-: vm<<=, binop=prep isconst# shl, opdeinit ;
-: vm>>=, binop=prep isconst# shr, opdeinit ;
-
-\ Code generation - Unary ops
-\ Unary operations are performed on the selected op, which can be either op1 or
-\ op2.
-: unaryopprep op>reg opAsm ;
-: vmneg, unaryopprep neg, ;
-: vmnot, ( ~ ) unaryopprep not, ;
-: vmboolify, unaryopprep
- opAsm test,
- opAsm 0 i) mov,
- opAsm setnz, ;
-: vmboolnot, unaryopprep
- opAsm test,
- opAsm 0 i) mov,
- opAsm setz, ;
-
-\ pre-inc/dec op1
-: vm++op, opAsm inc, ;
-: vm--op, opAsm dec, ;
-
-\ post-inc/dec op1
-\ It's a bit complicated here. Before we inc/dec, we need a copy of the current
-\ value in a new register, which will be our result.
-\ For now, we only support op1=VM_STACKFRAME
-\ TODO: don't use both ops for this and thus allow post-inc and post-dec to run
-\ on either on the 2 ops
-: _ ( 'w -- )
- selop1 optype VM_*STACKFRAME = optype VM_*ARGSFRAME = or _assert
- selop2 noop# selop1 optype oparg selop2 oparg! optype!
- selop1 op>reg selop2 opAsm execute opdeinit selop1 ;
-: vmop++, ['] inc, _ ;
-: vmop--, ['] dec, _ ;
-
-\ Code generation - Logic
-
-: _
- selop1 op>reg opAsm selop2 opAsm cmp, opdeinit
- selop1 opAsm 0 i) mov, ;
-: vm<, _ opAsm setl, ;
-: vm==, _ opAsm setz, ;
-: _ ( 'w -- ) selop1 opAsm selop2 opAsm execute opdeinit selop1 vmboolify, ;
-: vm&&, ['] and, _ ;
-: vm||, ['] or, _ ;
-
-\ Jumping in the VM
-\ There are 2 kinds of jumps: forward and backward. In forward jumps, we need
-\ to emit a jump opcode followed by a placeholder and then push the address of
-\ that placeholder to PS. When we reach the target, we write the target address
-\ to that placeholder.
-\ In backward jumps, we push the target address upon meeting it, and then simply
-\ write the jump opcode followed by that address.
-\ Forward jumps are written with the "[" words:
-\ vmjmp[, ... ]vmjmp
-\ vmjz[, ... ]vmjmp
-\ Backward jumps are written with the non-"[" words:
-\ here ... vmjmp,
-\ here ... vmjnz,
-
-: ]vmjmp ( 'jump_addr -- ) here over - 4 - swap ! ;
-: _ here 4 - ;
-: vmjmp, ( a -- ) abs>rel jmp, ;
-: vmjmp[, ( -- a ) 0 vmjmp, _ ;
-\ we take current op and test whether it's zero, setting Z. If the op is a
-\ simple register, the "test eax, eax" form is more compact. Otherwise, use
-\ test ..., -1.
-: vmtest,
- opAsm optype $f and VM_REGISTER = if opAsm else -1 i) then test, ( sets Z )
- opdeinit ;
-: vmjz, ( a -- ) selop1 vmtest, jz, ;
-: vmjz[, ( -- a ) 0 vmjz, _ ;
-: vmjnz, ( a -- ) selop1 vmtest, jnz, ;
-: vmjnz[, ( -- a ) 0 vmjnz, _ ;
diff --git a/fs/cc/vm/i386.fs b/fs/cc/vm/i386.fs
@@ -0,0 +1,343 @@
+\ C compiler virtual machine for i386
+
+\ The goal of this VM is to provide a unified API for code generation of a C
+\ AST across CPU architecture.
+
+\ Computation done by this generated code is centered around two operands, Op1
+\ and Op2. Those operands can "live" in different places depending on the
+\ context: in a register, in memory, or as a constant.
+
+\ Each of the two operands can be of either of those types:
+
+\ None: operand not specified
+\ Constant: a constant value
+\ Stack Frame: an address on the Stack Frame
+\ Register: value currently being held a register
+
+\ Besides the type, each operand has an accompanying "argument", whose meaning
+\ depend on the type:
+
+\ Constant: the value of the constant
+\ Stack Frame: the offset relative to the SF pointer
+\ Arguments Frame: the offset relative to the AF pointer
+\ Register: the ID of the register
+
+\ On those operands, the VM generates code that perform operations on them.
+\ Although some operations are special, there are basically 2 types of
+\ operations: unary op and binary op.
+
+\ When performing an unary op we:
+\ 1. Assert that op2 is unset
+\ 2. if op1 is not in a register, move the value to a register
+\ 3. Perform the operation on the register
+
+\ When performing an binary op we:
+\ 1. Assert that op2 is set
+\ 2. if op1 is not in a register, move the value to a register
+\ 3. Perform the binary operation with op1 as the target, op2 as the source.
+
+\ To avoid errors, moving an operand to a non-empty and non-pushed Result is an
+\ error. To set the operand when it's not None is also an error.
+
+\ For usage example, see tests/cc/vm.fs
+?f<< asm/i386.fs
+
+: _err abort" vm error" ;
+: _assert not if _err then ;
+
+\ Execution context (function)
+
+0 value argsz \ size of the argument portion of the SF.
+0 value locsz \ size of the "local vars" portion of the SF.
+0 value callsz \ size of the args portion of a Function Call
+
+\ 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
+\ in the reverse order they were allocated.
+\ Allocation works by having a list of register to allocate, and a pointer,
+\ "reglvl" which indicate which register can be used next. When we run out of
+\ register, allocating a register pushes the first register to the stack and
+\ then allocates it.
+
+6 const REGCNT
+create registers AX c, BX c, CX c, DX c, SI c, DI c,
+0 value reglvl
+
+: curreg ( -- regid )
+ reglvl REGCNT < if
+ registers reglvl + c@ ( regid ) else
+ ax push, AX ( regid ) then ;
+: regallot ( -- regid ) curreg 1 to+ reglvl ;
+: regfree ( -- )
+ reglvl not if abort" too many regfree" then
+ -1 to+ reglvl reglvl REGCNT >= if ax pop, then ;
+
+\ Operands definition and selection
+$00 const VM_NONE
+$01 const VM_CONSTANT \ 42
+$02 const VM_STACKFRAME \ esp+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
+
+operands value 'curop
+: selop1 ( -- ) operands to 'curop ;
+: selop2 ( -- ) operands 8 + to 'curop ;
+: selectedop ( -- n ) \ 0 == Op1 1 == Op2
+ 'curop operands = not ;
+: optype ( -- type ) 'curop @ ;
+: optype! ( type -- ) 'curop ! ;
+: oparg ( -- arg ) 'curop 4 + @ ;
+: oparg! ( arg -- ) 'curop 4 + ! ;
+
+\ reinitialize selected op to VM_NONE and dealloc registers if needed
+: opdeinit optype $f and VM_REGISTER = if regfree then VM_NONE optype! ;
+
+\ Deinit both ops and select Op1
+: ops$
+ selop2 opdeinit selop1 opdeinit
+ reglvl if abort" unbalanced reg allot/free" then
+ operands 16 0 fill ;
+: .ops 4 >r operands begin dup @ .x spc> 4 + next drop nl> ;
+
+\ Managing operands
+
+: hasop# optype VM_NONE = not _assert ;
+: isconst# optype VM_CONSTANT = _assert ;
+: noop# optype VM_NONE = _assert ;
+: const>op ( n -- ) noop# VM_CONSTANT optype! oparg! ;
+: constarray>op ( a -- ) noop# VM_CONSTARRAY optype! oparg! ;
+: sf+>op ( off -- ) noop# VM_*STACKFRAME optype! oparg! ;
+: ps+>op ( off -- ) noop# VM_*ARGSFRAME optype! oparg! ;
+: mem>op ( n -- ) noop# VM_*CONSTANT optype! oparg! ;
+
+\ get current operand SF offset, adjusted with callsz
+: opsf+ ( -- off ) oparg callsz + ;
+
+\ Resolve current operand as an assembler "src" argument.
+: opAsm ( -- )
+ optype case
+ VM_CONSTANT of = oparg i) endof
+ VM_STACKFRAME of = abort" can't address VM_STACKFRAME directly" endof
+ VM_REGISTER of = oparg r! endof
+ VM_*CONSTANT of = oparg m) endof
+ VM_*STACKFRAME of = sp oparg d) endof
+ VM_*ARGSFRAME of = bp opsf+ d) endof
+ VM_*REGISTER of = oparg r! 0 d) endof
+ _err endcase ;
+
+\ Force current operand to be copied to a register
+: _ regallot dup r! ( regid ) opAsm mov, oparg! ;
+: op>reg optype case
+ VM_CONSTANT of = _ VM_REGISTER optype! endof
+ VM_*CONSTANT of = _ VM_REGISTER optype! endof
+ VM_REGISTER of = endof
+ VM_*REGISTER of = endof
+ VM_STACKFRAME of =
+ regallot dup r! sp mov,
+ oparg if dup r! oparg i) add, then ( regid )
+ oparg! VM_REGISTER optype! endof
+ VM_*STACKFRAME of = _ VM_REGISTER optype! endof
+ VM_*ARGSFRAME of = _ VM_REGISTER optype! endof
+ _err
+ endcase ;
+
+\ Resolve any referencing into a "simple" result. A VM_STACKFRAME goes into a
+\ register, a VM_*REGISTER is resolved into a VM_REGISTER.
+: opderef
+ optype case
+ VM_STACKFRAME of = op>reg endof
+ VM_*CONSTANT of = op>reg endof
+ VM_*STACKFRAME of = op>reg endof
+ VM_*ARGSFRAME of = op>reg endof
+ VM_*REGISTER of = oparg r! oparg r! 0 d) mov, VM_REGISTER optype! endof
+ endcase ;
+
+\ Before doing an operation on two operands, we verify that they are compatible.
+\ For example, we can't have two VM_*REGISTER ops. one of them has to be
+\ dereferenced (it has to be op2).
+: maybederef
+ selop1 optype VM_*REGISTER = optype $f and VM_STACKFRAME = or
+ optype VM_*ARGSFRAME = or if selop2 opderef then ;
+
+\ 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
+ VM_*REGISTER of = VM_REGISTER optype! endof
+ _err endcase ;
+
+\ if possible, dereference current operand
+: *op>op optype case
+ VM_CONSTANT of = VM_*CONSTANT optype! endof
+ VM_*CONSTANT of = op>reg *op>op endof
+ VM_STACKFRAME of = VM_*STACKFRAME optype! endof
+ VM_*STACKFRAME of = op>reg *op>op endof
+ VM_*ARGSFRAME of = op>reg *op>op endof
+ VM_REGISTER of = VM_*REGISTER optype! endof
+ VM_*REGISTER of = opderef VM_*REGISTER optype! endof
+ _err endcase ;
+
+: oppush ( -- oparg optype ) oparg optype VM_NONE optype! ;
+
+: 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! ;
+
+\ Code generation - Functions, calls, ret, pspush, pspop
+
+\ generate function prelude code by allocating "locsz" bytes on PS.
+: vmprelude, ( argsz locsz -- )
+ to locsz to argsz
+ locsz if sp locsz i) sub, then ;
+\ 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
+ argsz selop1 optype if CELLSZ - then
+ opderef \ for bp 0 d) src mov, to work, "src" has to be "simple"
+ locsz if sp locsz i) add, then
+ ?dup if bp i) add, then
+ optype if bp 0 d) opAsm mov, then
+ ret, ;
+
+: callargallot, ( bytes -- ) dup to callsz ?dup if bp i) sub, then ;
+
+\ Call the address in current op. If the function has a result, you need to
+\ pop it with vmpspop,
+: vmcall, ( -- )
+ VM_*CONSTANT optype = if oparg VM_NONE optype! else opAsm then
+ abs>rel call, opdeinit 0 to callsz ;
+
+\ Allocate a new register for active op and pop 4b from PS into it.
+: vmpspop,
+ noop# VM_REGISTER optype! regallot dup oparg! r! bp 0 d) mov,
+ bp CELLSZ i) add, ;
+
+\ Push active op to PS.
+: vmpspush, opderef bp CELLSZ i) sub, bp 0 d) opAsm mov, opdeinit ;
+
+\ Code generation - Binary ops
+: binopprep ( -- ) \ prepare ops for the binop
+ selop1 op>reg opAsm
+ selop2 hasop# opAsm ;
+: vmadd, binopprep add, opdeinit ;
+: vmsub, binopprep sub, opdeinit ;
+: vm&, binopprep and, opdeinit ;
+: vm|, binopprep or, opdeinit ;
+: vm^, binopprep xor, opdeinit ;
+\ TODO: allow non-const shift right-operand
+: vm<<, binopprep isconst# shl, opdeinit ;
+: vm>>, binopprep isconst# shr, opdeinit ;
+
+\ mul is special and cannot use binopprep for two reasons: its target operand
+\ is hardcoded to EAX and also, EDX gets written by the op, so we need to save
+\ EDX if in use.
+: vmmul,
+ reglvl 4 >= if dx push, then
+ \ if op1 is not EAX, we need to push EAX, perform the mul, copy EAX to op1's
+ \ reg, then pop eax back.
+ selop1 op>reg oparg AX = not if ax push, ax opAsm mov, then
+ selop2 op>reg hasop# opAsm mul, opdeinit
+ selop1 oparg AX = not if opAsm ax mov, ax pop, then
+ reglvl 4 >= if dx pop, then ;
+\ Copy the contents of op2 in the memory address pointed out by op1 and deinit
+\ op2. In other words, perform a AST_ASSIGN with the right part as op2
+\ and the left part as op1.
+: vmmov,
+ selop2 optype VM_CONSTARRAY = if \ special case, we have a {1, 2, 3} assign
+ selop1 optype VM_STACKFRAME = _assert
+ *op>op selop2 oparg selop1 dup @ ( a len ) >r begin ( a )
+ opAsm 4 + dup @ i) mov, ( a+4 ) oparg 4 + oparg! next ( a )
+ drop selop2
+ else
+ maybederef selop1 opAsm selop2 opAsm mov, then
+ opdeinit ;
+
+: binop=prep ( -- ) \ prepare ops a binop of the "assign" type
+ selop1 opAsm selop2 hasop# opAsm ;
+: vm<<=, binop=prep isconst# shl, opdeinit ;
+: vm>>=, binop=prep isconst# shr, opdeinit ;
+
+\ Code generation - Unary ops
+\ Unary operations are performed on the selected op, which can be either op1 or
+\ op2.
+: unaryopprep op>reg opAsm ;
+: vmneg, unaryopprep neg, ;
+: vmnot, ( ~ ) unaryopprep not, ;
+: vmboolify, unaryopprep
+ opAsm test,
+ opAsm 0 i) mov,
+ opAsm setnz, ;
+: vmboolnot, unaryopprep
+ opAsm test,
+ opAsm 0 i) mov,
+ opAsm setz, ;
+
+\ pre-inc/dec op1
+: vm++op, opAsm inc, ;
+: vm--op, opAsm dec, ;
+
+\ post-inc/dec op1
+\ It's a bit complicated here. Before we inc/dec, we need a copy of the current
+\ value in a new register, which will be our result.
+\ For now, we only support op1=VM_STACKFRAME
+\ TODO: don't use both ops for this and thus allow post-inc and post-dec to run
+\ on either on the 2 ops
+: _ ( 'w -- )
+ selop1 optype VM_*STACKFRAME = optype VM_*ARGSFRAME = or _assert
+ selop2 noop# selop1 optype oparg selop2 oparg! optype!
+ selop1 op>reg selop2 opAsm execute opdeinit selop1 ;
+: vmop++, ['] inc, _ ;
+: vmop--, ['] dec, _ ;
+
+\ Code generation - Logic
+
+: _
+ selop1 op>reg opAsm selop2 opAsm cmp, opdeinit
+ selop1 opAsm 0 i) mov, ;
+: vm<, _ opAsm setl, ;
+: vm==, _ opAsm setz, ;
+: _ ( 'w -- ) selop1 opAsm selop2 opAsm execute opdeinit selop1 vmboolify, ;
+: vm&&, ['] and, _ ;
+: vm||, ['] or, _ ;
+
+\ Jumping in the VM
+\ There are 2 kinds of jumps: forward and backward. In forward jumps, we need
+\ to emit a jump opcode followed by a placeholder and then push the address of
+\ that placeholder to PS. When we reach the target, we write the target address
+\ to that placeholder.
+\ In backward jumps, we push the target address upon meeting it, and then simply
+\ write the jump opcode followed by that address.
+\ Forward jumps are written with the "[" words:
+\ vmjmp[, ... ]vmjmp
+\ vmjz[, ... ]vmjmp
+\ Backward jumps are written with the non-"[" words:
+\ here ... vmjmp,
+\ here ... vmjnz,
+
+: ]vmjmp ( 'jump_addr -- ) here over - 4 - swap ! ;
+: _ here 4 - ;
+: vmjmp, ( a -- ) abs>rel jmp, ;
+: vmjmp[, ( -- a ) 0 vmjmp, _ ;
+\ we take current op and test whether it's zero, setting Z. If the op is a
+\ simple register, the "test eax, eax" form is more compact. Otherwise, use
+\ test ..., -1.
+: vmtest,
+ opAsm optype $f and VM_REGISTER = if opAsm else -1 i) then test, ( sets Z )
+ opdeinit ;
+: vmjz, ( a -- ) selop1 vmtest, jz, ;
+: vmjz[, ( -- a ) 0 vmjz, _ ;
+: vmjnz, ( a -- ) selop1 vmtest, jnz, ;
+: vmjnz[, ( -- a ) 0 vmjnz, _ ;
diff --git a/fs/lib/scratch.fs b/fs/lib/scratch.fs
@@ -28,5 +28,5 @@ struct Scratchpad
\ Open a scratch area for writing
: scratch[ ( -- ) here to _here scratch> to here ;
\ Stop writing to the scratch area and restore here
-\ Returs the address of the beginning of the written area
+\ Returns the address of the beginning of the written area
: ]scratch ( -- a ) scratch> here to scratch> _here to here ;
diff --git a/fs/tests/all.fs b/fs/tests/all.fs
@@ -1,4 +1,6 @@
\ Run all test suites
+?f<< /cc/cc.fs
+HASCC not [if] ." No CC. Will skip tests requiring it" nl> [then]
f<< /tests/kernel.fs
f<< /tests/lib/all.fs
f<< /tests/sys/all.fs
diff --git a/fs/tests/cc/all.fs b/fs/tests/cc/all.fs
@@ -1,4 +1,5 @@
\ Run all CC test suites
+HASCC not [if] \s [then]
f<< tests/cc/tree.fs
f<< tests/cc/ast.fs
f<< tests/cc/vm.fs
diff --git a/fs/tests/cc/vm.fs b/fs/tests/cc/vm.fs
@@ -1,5 +1,5 @@
?f<< tests/harness.fs
-?f<< cc/vm.fs
+?f<< cc/vm/i386.fs
testbegin
\ Tests for the C compiler VM module
\ binop[+](binop[*](const[2],const[3]),const[1])
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -25,3 +25,7 @@ chain foo myfoo
fooinit
42 foo 86 #eq \ (42+1)*2
testend
+
+\ [if]..then
+1 [if] 42 42 #eq [then]
+0 [if] abort [then]
diff --git a/fs/tests/lib/crc.fs b/fs/tests/lib/crc.fs
@@ -1,3 +1,4 @@
+HASCC not [if] \s [then]
?f<< tests/harness.fs
?f<< lib/crc.fs
testbegin
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -64,18 +64,6 @@
: doer code compile (does) CELLSZ allot ;
: does> r> ( exit current definition ) current 5 + ! ;
-\ Emitting
-$20 const SPC $0d const CR $0a const LF $08 const BS
-: nl> CR emit LF emit ; : spc> SPC emit ;
-\ emit all chars of "str"
-: stype ( str -- ) c@+ rtype ;
-: ," begin in< dup '"' = if drop exit then c, again ;
-: S" ( comp: -- ) ( not-comp: -- str )
- compiling if compile (s) else here then
- here 1 allot here ," here -^ ( 'len len ) swap c! ; immediate
-: ." [compile] S" compile stype ; immediate
-: abort" [compile] ." compile abort ; immediate
-
\ while..repeat
: while [compile] if swap ; immediate
: repeat [compile] again [compile] then ; immediate
@@ -96,8 +84,24 @@ alias else endof immediate
: endcase ( then-stopgap jump1? jump2? ... jumpn? -- )
?dup if begin [compile] then ?dup not until then compile r~ ; immediate
+\ Emitting
+$20 const SPC $0d const CR $0a const LF $08 const BS
+: nl> CR emit LF emit ; : spc> SPC emit ;
+\ emit all chars of "str"
+: stype ( str -- ) c@+ rtype ;
+: ," begin in< dup '"' = not while c, repeat drop ;
+: S" ( comp: -- ) ( not-comp: -- str )
+ compiling if compile (s) else here then
+ here 1 allot here ," here -^ ( 'len len ) swap c! ; immediate
+: ."
+ compiling if [compile] S" compile stype else
+ begin in< dup '"' = not while emit repeat drop then ; immediate
+: abort" [compile] ." compile abort ; immediate
+
\ Return whether strings s1 and s2 are equal
: s= ( s1 s2 -- f ) over c@ 1+ []= ;
+: [if] not if S" [then]" begin word over s= until drop then ;
+alias noop [then]
\ Alias chaining. See doc/usage.
: _ ( 'target 'alias -- )
diff --git a/fs/xcomp/pc/init.fs b/fs/xcomp/pc/init.fs
@@ -1,4 +1,5 @@
\ Initialization for PC
+: ARCH S" i386" ;
herestart to here
0 S" sys" fchild S" file.fs" fchild fload
\ We now have f<<
diff --git a/posix/init.fs b/posix/init.fs
@@ -1,4 +1,5 @@
\ Initialization for POSIX Dusk
+: ARCH S" i386" ;
0 S" sys" fchild S" file.fs" fchild fload
\ We now have f<<
f<< sys/doc.fs
