commit 0384b7221879ff7d9fe66be1b54d28e69ee3106a
parent db233572a81c44ab8537609ba40971376a8f4b2f
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Fri, 7 Oct 2022 10:07:30 -0400
cc: bug fixes + global variable list initialization
Diffstat:
10 files changed, 69 insertions(+), 25 deletions(-)
diff --git a/fs/app/cos/cvm.c b/fs/app/cos/cvm.c
@@ -89,12 +89,12 @@ static void iowr_blk(byte val)
byte rw = blkop[3];
word blkid, dest;
if (rw) {
- // Compiles up to this point!
blkid = (word)blkop[2] << 8 | (word)blkop[1];
dest = (word)blkop[0] << 8 | (word)val;
memset(blkop, 0, #[ BLKOP_CMD_SZ c]# );
fseek(blkid*1024, blkfp);
if (rw==2) { /* write */
+ // Compiles up to this point!
fwrite(&vm.mem[dest], 1024, 1, blkfp);
} else { /* read */
fread(&vm.mem[dest], 1024, 1, blkfp);
diff --git a/fs/cc/gen.fs b/fs/cc/gen.fs
@@ -108,12 +108,12 @@ BOPSCNT wordtbl bopgentblpost ( -- )
'w vm>=,
'w vm==,
'w vm!=,
-:w ( & ) vm&, ;
-:w ( ^ ) vm^, ;
-:w ( | ) vm|, ;
-'w vm&&, ( && )
-'w vm||, ( || )
-:w ( = ) vmmov, ;
+'w vm&,
+'w vm^,
+'w vm|,
+'w vm&&,
+'w vm||,
+'w vmmov, ( = )
'w vm+=,
'w vm-=,
'w vm*=,
@@ -131,11 +131,18 @@ ASTIDCNT wordtbl gentbl ( node -- )
dup Declare ctype CType name NEXTWORD ! create then ( dnode )
here over Declare ctype to CType offset
dup Declare :totsize allot
+ \ TODO: support Ident during initialization
dup Node firstchild ?dup if Node id case ( dnode )
AST_CONSTANT of =
dup Node firstchild Constant value
over Declare ctype CType offset !
endof
+ AST_LIST of = \ TODO: support multiple widths
+ dup Declare ctype CType offset ( dnode off )
+ over Node firstchild Node firstchild begin ( off node )
+ ?dup while tuck Constant value swap !+ ( node off+4 )
+ swap Node nextsibling repeat
+ drop endof
endcase then drop
else ( node )
Node firstchild ?dup if ( assignnode )
@@ -164,24 +171,28 @@ ASTIDCNT wordtbl gentbl ( node -- )
Node firstchild begin
?dup while dup gennode ops$ Node nextsibling repeat ( snode ) ;
'w drop ( ArgSpecs )
-:w ( Ident ) dup Ident :finddecl ?dup if ( inode dnode-or-fnode )
+:w ( Ident )
+ _debug if ." ident: " dup printast nl> then
+ dup Ident :finddecl ?dup if ( inode dnode-or-fnode )
nip dup Node id AST_FUNCTION = if
\ Sometimes, we get a Function as dnode. In these cases, it's a global
\ address and its type is "void"
TYPE_VOID to vmop type Function address mem>op
else Declare ctype ctype>op then
else ( inode )
- Ident name sysdict @ find ?dup _assert TYPE_VOID to vmop type mem>op then ;
+ Ident name sysdict @ find ?dup _assert TYPE_VOID to vmop type mem>op then
+ _debug if .ops then ;
:w ( UnaryOp )
- _debug if ." unaryop: " dup printast nl> .ops then
+ _debug if ." unaryop: " dup printast nl> then
dup genchildren
- Op opid uopgentbl swap wexec ;
+ Op opid uopgentbl swap wexec
+ _debug if .ops then ;
:w ( PostfixOp )
dup genchildren
Op opid popgentbl swap wexec ;
\ See "Binary op resolution strategy" in opening comment
:w ( BinaryOp )
- _debug if ." binop: " dup printast nl> then
+ _debug if ." binop: " dup printast nl> .ops then
dup >r \ V1=node
Node firstchild dup Node nextsibling swap ( n2 n1 )
over needs2ops? if \ n2 == 2ops
@@ -251,6 +262,7 @@ ASTIDCNT wordtbl gentbl ( node -- )
Node nextsibling ( loop' node ) dup _assert gennode \ control
vmjnz, ops$ r> resolvebreaks ;
:w ( Arrow )
+ _debug if ." arrow: " dup printast nl> then
dup Node firstchild dup _assert gennode Arrow name ( fieldname )
vmop type dup ctype? _assert dup type*lvl 1 = _assert ( name type )
ctype' dup CType :struct? _assert ( name ctype )
diff --git a/fs/cc/ttr.fs b/fs/cc/ttr.fs
@@ -5,6 +5,9 @@
?f<< /lib/wordtbl.fs
?f<< /cc/ast.fs
+: _err ( -- ) abort" ttr error" ;
+: _assert ( f -- ) not if _err then ;
+
UOPSCNT wordtbl uopconsttbl ( -- )
'w neg
'w ^
@@ -72,7 +75,7 @@ ASTIDCNT wordtbl trtbl ( node -- )
:w ( BinaryOp )
dup >r BinaryOp :*ari r@ trchildren
r@ Node firstchild dup Node nextsibling ( n1 n2 )
- over Node id AST_CONSTANT = over Node id AST_CONSTANT = and if
+ over Node id AST_CONSTANT = over Node id AST_CONSTANT = and if
Constant value swap Constant value swap
bopconsttbl r@ BinaryOp opid wexec ( n )
AST_CONSTANT to r@ Node id ( n ) to r@ Constant value
diff --git a/fs/cc/type.fs b/fs/cc/type.fs
@@ -46,8 +46,8 @@ $1d const TYPE_UINT*
: typeunsigned! ( type -- type ) $10 or ;
: type*lvl ( type -- lvl ) 3 and ;
: type*lvl! ( lvl type -- type ) $fffffffc and or ;
-: type*lvl+ ( type -- type ) dup type*lvl 1+ swap type*lvl! ;
-: type*lvl- ( type -- type ) dup type*lvl 1- swap type*lvl! ;
+: type*lvl+ ( type -- type ) dup type*lvl 1+ dup 4 < _assert swap type*lvl! ;
+: type*lvl- ( type -- type ) dup type*lvl 1- dup 0>= _assert swap type*lvl! ;
create _ 0 c, 1 c, 2 c, 4 c,
: ctype? ( type -- f ) $ff > ;
: ctype' ( type -- ctype ) $fffffffc and ;
diff --git a/fs/cc/vm/commonlo.fs b/fs/cc/vm/commonlo.fs
@@ -101,9 +101,9 @@ vmop :self to vmop^ other
: ctype>op ( ctype -- )
vmop :noop#
dup CType type to vmop type ( ctype )
- case
+ dup case
of CType :isglobal? r@ CType offset mem>op endof
of CType :isarg? r@ CType offset ps+>op endof
r@ CType offset sf+>op
- r@ CType nbelem if vmop :&op then
- endcase ;
+ endcase
+ CType nbelem if vmop :&op then ;
diff --git a/fs/cc/vm/forth.fs b/fs/cc/vm/forth.fs
@@ -48,9 +48,7 @@ struct+[ VMOp
r@ :hasop# r@ :?&op ( f ) r@ :compile& r@ 'arg litn compile ! PS- ( f )
4 lshift VM_REGISTER or to r> loc ;
\ dereference current operand
- : :*op dup >r :pointer? if
- r@ :compile r@ :>*TOS r> :>reg else
- r> VMOp :*op then ;
+ : :*op dup :pointer? if dup :compile dup :>reg then VMOp :*op ;
]struct
\ Verify that we're in "neutral" position with regards to PS
diff --git a/fs/cc/vm/i386.fs b/fs/cc/vm/i386.fs
@@ -83,6 +83,11 @@ struct+[ VMOp
VM_*ARGSFRAME of = dup :>reg endof
VM_*REGISTER of = dup :deref endof
endcase VMOp :*op ;
+
+ \ Ensure that vmop is a proper "result", that is, a proper destination operand
+ \ that is not going to mutate its original value.
+ \ TODO: straighten all those "deref/*op/>reg" words, they're confusing.
+ : :>res dup :>reg :deref ;
]struct
\ Verify that we're in "neutral" position with regards to registers
@@ -90,7 +95,7 @@ struct+[ VMOp
\ 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).
+\ dereferenced (it has to be op^).
: maybederef
vmop loc VM_*REGISTER = vmop :loclo VM_STACKFRAME = or
vmop loc VM_*ARGSFRAME = or if vmop^ :deref then ;
@@ -140,7 +145,7 @@ struct+[ VMOp
\ TODO: reduce code duplication in ops below with the help of proper does words
\ Code generation - Binary ops
: binopprep ( -- ) \ prepare ops for the binop
- vmop :>reg vmop :compile vmop^ :hasop# vmop^ :compile ;
+ vmop :>res vmop :compile vmop^ :hasop# vmop^ :compile ;
: vmadd, binopprep add, vmop^ :init ;
: vmsub, binopprep sub, vmop^ :init ;
: vm&, binopprep and, vmop^ :init ;
diff --git a/fs/tests/cc/cc.fs b/fs/tests/cc/cc.fs
@@ -66,6 +66,7 @@ globdata 4 + 16b @ 42 #eq
2 3 binop1 1 #eq
'2' binop2 44 #eq
+binop3 $605 #eq
\ and what about inline functions?
:cfunc int myinline() { return 42; }
diff --git a/fs/tests/cc/test.c b/fs/tests/cc/test.c
@@ -264,3 +264,6 @@ int binop2(int n) {
}
/* There used to be a bug where this type of comment with "'" char in it would
cause a tokenization error. */
+int binop3() {
+ return global2[2] << 8 | global2[1];
+}
diff --git a/fs/tests/cc/vm.fs b/fs/tests/cc/vm.fs
@@ -79,6 +79,7 @@ code test5
\ bar = &foo
vmop :&op
selop2 0 sf+>op
+ vmop^ type to vmop type
vmmov,
\ return *bar
vmop :*op
@@ -96,6 +97,7 @@ code test6
\ bar = &foo
vmop :&op
selop2 0 sf+>op
+ vmop^ type to vmop type
vmmov,
\ *bar = 54
selop1 54 const>op
@@ -181,12 +183,32 @@ ops$
here ," hello" ( a )
code test12 ( n -- c )
4 0 vmprelude,
+ selop2 0 ps+>op
selop1 ( a ) const>op
TYPE_CHAR* to vmop type
- selop2 0 ps+>op
- selop1 vmadd,
+ vmadd,
vmop :*op
vmret,
0 test12 'h' #eq
1 test12 'e' #eq
+
+\ This tests a bug in i386 VM where a binop applied to a VM_*REGISTER vmop
+\ applied the result to *register instead of properly dereferencing the register
+\ first.
+ops$
+here 42 , here swap , ( pc of *int )
+code test13 ( -- n )
+ 0 0 vmprelude,
+ selop2 1 const>op
+ selop1 dup ( pc ) mem>op
+ TYPE_INT* to vmop type
+ vmop :*op
+ vmadd, \ result in register, not in memory location
+ selop2 ( pc ) mem>op
+ TYPE_INT* to vmop type
+ vmop :*op
+ vmadd, \ 42+43, not 43+43
+ vmret,
+test13 85 #eq
+
testend
