commit b47a95af1dc3b96de4c8e2aa50cec43fc0fdddc3
parent a028adb413830bd7305484f57687b8df19f42972
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sun, 19 Mar 2023 22:08:02 -0400
halcc: boolops()
This required the development of a "W locking" mechanism as well as a "push to
PS when W is locked" one.
Diffstat:
7 files changed, 76 insertions(+), 41 deletions(-)
diff --git a/fs/comp/c/egen.fs b/fs/comp/c/egen.fs
@@ -72,24 +72,34 @@ current ' parseFactor realias
\ ops that can freely swap their operands
: swappable doer ' , does> @ ( left right w ) >r
- dup Result :isW? if swap then over Result :>W Result :hal# r> execute ;
-swappable _+, +, swappable _*, *,
-swappable _&, and, swappable _^, xor, swappable _|, or,
+ dup Result :isW? if swap then over Result :?>W Result :hal# r> execute ;
+swappable _+, +, swappable _*, *,
+swappable _&, and, swappable _^, xor, swappable _|, or,
+: _ ( halop -- ) W=0>Z, 0 Z) branchC, @, W=0>Z, [compile] then NZ) C>W, ;
+swappable _&&, and,
+: _ ( halop -- ) or, W=0>Z, NZ) C>W, ;
+swappable _||, _
: fixed doer ' , does> @ ( left right w ) >r
- Result :?>T over Result :>W r> execute ;
+ Result :?>T over Result :?>W r> execute ;
fixed _-, -, fixed _/, /, fixed _%, %,
fixed _<<, <<, fixed _>>, >>,
: assign doer ' , does> @ ( left right w ) >r
Result :?>T over Result :hal# lea, W>A, ( res-w rightop )
- over Result :>W r> execute A) !, ;
+ over Result :?>W r> execute A) !, ;
assign _=, drop assign _+=, +,
assign _*=, *, assign _/=, /, assign _%=, %,
assign _&=, and, assign _^=, xor, assign _|=, or,
assign _-=, -, assign _/=, /, assign _%=, %,
assign _<<=, <<, assign _>>=, >>,
+: cmpop doer , does> @ ( left right cond ) >r
+ Result :?>T over Result :?>W cmp, r> C>W, ;
+Z) cmpop _==, NZ) cmpop _!=,
+<) cmpop _<, <=) cmpop _<=, >) cmpop _>, >=) cmpop _>=,
+
+
\ Our implementation of "x ? y : z" suffers a significant limitation because
\ we're single pass: by the time _? is called, it's possible that code
\ generating the right part of it has already been generated, so the "true" part
@@ -97,15 +107,15 @@ assign _<<=, <<, assign _>>=, >>,
\ the "true" hand, push it to PS, then generate the "cond", keep it in W. When
\ we encounter the "false" hand, *then* we generate conditional code which
\ cleans up PS.
-: _?, ( left right -- res ) Result :>PS dup Result :>W ;
+: _?, ( left right -- res ) Result :>PS ;
: _:, ( left right -- res )
- PS- W=0>Z, 0 Z) branchC,
- drop, [compile] else nip, swap Result :>W [compile] then ;
+ swap Result :>W$ PS- W=0>Z, 0 Z) branchC,
+ drop, [compile] else nip, over Result :>W [compile] then ;
BOPSCNT wordtbl _tbl ( left right -- res )
-'w _+, 'w _-, 'w _*, 'w _/, 'w _%, 'w _<<, 'w _>>, 'w _err
-'w _err 'w _err 'w _err 'w _err 'w _err 'w _&, 'w _^, 'w _|,
-'w _err 'w _err 'w _=, 'w _+=, 'w _-=, 'w _*=, 'w _/=, 'w _%=,
+'w _+, 'w _-, 'w _*, 'w _/, 'w _%, 'w _<<, 'w _>>, 'w _<,
+'w _>, 'w _<=, 'w _>=, 'w _==, 'w _!=, 'w _&, 'w _^, 'w _|,
+'w _&&, 'w _||, 'w _=, 'w _+=, 'w _-=, 'w _*=, 'w _/=, 'w _%=,
'w _<<=, 'w _>>=, 'w _&=, 'w _^=, 'w _|=, 'w _?, 'w _:,
: bothconst? ( left right -- f ) Result :isconst? swap Result :isconst? and ;
diff --git a/fs/comp/c/expr.fs b/fs/comp/c/expr.fs
@@ -7,41 +7,54 @@
: _assert ( f -- ) not if _err then ;
struct[ Result
- 0 const CONST \ Is a constant (value in arg)
- 1 const W \ Value in W register
- 2 const CTYPE \ CType pointer is in arg.
+ 0 const NONE \ Nothing (probably a released W)
+ 1 const CONST \ Is a constant (value in arg)
+ 2 const W \ Value in W register
+ 3 const CTYPE \ CType pointer is in arg.
+ 4 const PS \ Result pushed to PS, offset in arg
sfield type
- sfield arg \ either CType or constant value
+ sfield arg
+
+ \ There can only be one result using W at once. Whenever a W result is
+ \ created, it takes the lock. If it's already taken, there's an error.
+ 0 value currentW \ link to Result
+ : :Wfree# currentW if abort" W is already taken!" then ;
: :new ( arg type -- res ) SZ syspad :allot dup >r !+ ! r> ;
: :const ( n -- res ) CONST :new ;
- : :W ( -- res ) 0 W :new ;
+ : :W ( -- res ) :Wfree# 0 W :new dup to currentW ;
: :ctype ( ctype -- res ) CTYPE :new ;
- \ TODO: manage W "locks" so that we push to PS when we need intermediate res.
- : :>W ( self -- ) dup bi arg | type case ( self arg )
- CONST of = LIT>W, endof
- W of = drop endof
- CTYPE of = CType :halop @, endof
- _err endcase W swap to type ;
+ : :isW? ( self -- f ) type W = ;
+ : :release ( self -- ) dup :isW? if 0 to currentW then NONE swap to type ;
: :hal# ( self -- halop ) dup type case ( self )
- CTYPE of = arg CType :halop endof
CONST of = arg i) endof
- _err endcase ;
+ CTYPE of = arg CType :halop endof
+ PS of = PSP) swap arg psoff + +) endof
+ abort" :hal# error" endcase ;
+ : :>W ( self -- ) dup type case ( self )
+ W of = endof
+ CONST of = :Wfree# dup arg LIT>W, endof
+ CTYPE of = :Wfree# dup :hal# @, endof
+ PS of = :Wfree# dup :hal# @, endof
+ abort" :>W error" endcase ( self )
+ dup to currentW W swap to type ;
+ : :>W$ ( self -- ) dup :>W :release ;
: :isconst? ( self -- f ) type CONST = ;
: :iszero? bi arg 0 = | :isconst? and ;
: :isone? bi arg 1 = | :isconst? and ;
- : :isW? ( self -- f ) type W = ;
: :const# dup :isconst? _assert arg ;
- : :>PS :>W dup, PS+ ;
+ : :>PS dup :>W$ dup, PS+ PS over to type psoff neg swap to arg ;
+ : :?>W dup :isW? if drop else currentW ?dup if :>PS then :>W then ;
\ Free up W by sending it to T (if needed).
- : :?>T ( self -- halop ) dup :isW? if drop T) dup !, else :hal# then ;
+ : :?>T ( self -- halop )
+ dup :isW? if :release T) dup !, else :hal# then ;
]struct
BOPSCNT wordtbl _tbl ( a b -- n )
'w + 'w - 'w * 'w / 'w mod 'w << 'w >> 'w <
'w > 'w <= 'w >= 'w = 'w <> 'w and 'w xor 'w or
-'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
+'w and? 'w or? 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
: applyConstBinop ( left right opid -- res )
diff --git a/fs/comp/c/fgen.fs b/fs/comp/c/fgen.fs
@@ -10,7 +10,7 @@
: _postlude
_curfunc CType :argssize ?dup if ps+, then
_locvars CType :size ?dup if rs+, then ;
-: emitRet ( res -- ) Result :>W _postlude exit, ;
+: emitRet ( res -- ) Result :>W$ psneutral _postlude exit, ;
: emitNullRet ( -- ) _postlude drop, exit, ;
alias noop parseStatement ( tok -- ) \ forward declaration
@@ -31,7 +31,8 @@ alias noop parseStatement ( tok -- ) \ forward declaration
0 value _laststmtid
: _ ( tok -- ) \ parseStatement
dup statementnames sfind dup >r dup 0< if ( tok -1 ) \ V1=stmtidx
- drop parseExpression drop read; else nip statementhandler swap wexec then
+ drop parseExpression Result :release psneutral read;
+ else nip statementhandler swap wexec then
r> to _laststmtid ;
current ' parseStatement realias
@@ -45,7 +46,7 @@ current ' parseStatement realias
'=' readChar? if ( ctype )
_initcode not if here to _initcode then
nextt parseExpression ( ctype res )
- Result :>W dup CType :halop !, nextt then ( ctype tok )
+ Result :>W$ dup CType :halop !, psneutral nextt then ( ctype tok )
dup ';' isChar? not while ( ctype tok )
',' expectChar CType type parseDeclarator ( ctype )
dup _locvars CType :append repeat ( ctype tok ) 2drop ;
diff --git a/fs/comp/c/glob.fs b/fs/comp/c/glob.fs
@@ -8,4 +8,4 @@
: PS+ CELLSZ to+ psoff ;
: PS- CELLSZ neg to+ psoff ;
-: psneutral# psoff if abort" psoff not neutral!" then ;
+: psneutral 0 to@! psoff ?dup if ps+, then ;
diff --git a/fs/tests/comp/c/cc.fs b/fs/tests/comp/c/cc.fs
@@ -19,8 +19,8 @@ binopmod 1 #eq
1 binopcondeval 42 #eq
0 binopcondeval 12 #eq
assignops 83 #eq
-testend \s
boolops 0 #eq
+testend \s
funcall 42 #eq
42 pushpop 42 #eq
3 2 subber 1 #eq
diff --git a/fs/tests/comp/c/test2.c b/fs/tests/comp/c/test2.c
@@ -63,3 +63,7 @@ int assignops() {
a |= c; // 83
return a;
}
+int boolops() {
+ int a=66, b=2;
+ return a < 54 && 2 == b;
+}
diff --git a/posix/vm.c b/posix/vm.c
@@ -54,10 +54,13 @@ no assembler to complete the HAL to "full" level later. It's all in there.
#define OPHASDISP 0x08
#define OP16B 0x100
#define OP8B 0x200
-#define CONDZ 0x11
-#define CONDNZ 0x01
-#define CONDC 0x22
-#define CONDNC 0x02
+// Condition structure: b6:0 condition ID b7 invert
+#define CONDZ 0x00
+#define CONDNZ 0x80
+#define CONDC 0x01
+#define CONDNC 0x81
+#define CONDA 0x02 // above (unsigned gt)
+#define CONDNA 0x82
#define EMETA_8B 0x10
#define EMETA_16B 0x11
@@ -204,11 +207,14 @@ static void RET() { vm.PC = rpop(); }
static void BRWR() { dwrite(vm.W); vm.W = here()-4; }
static void BRA() { vm.PC = vm.A; }
static int checkcond(byte cond) {
- switch (cond&0xf) {
- case 0x01: return vm.Z == ((cond >> 4) & 1);
- case 0x02: return vm.C == ((cond >> 5) & 1);
- default: return 0;
+ int r = 0;
+ switch (cond&0x7f) {
+ case CONDZ: r = vm.Z; break;
+ case CONDC: r = vm.C; break;
+ case CONDA: r = !vm.C && !vm.Z; break;
}
+ if (cond&0x80) r = !r;
+ return r;
}
static void BRC() { byte cond = gpcb(); dword a = gpc(); if (checkcond(cond)) vm.PC = a; }
static void YIELD() { dword pc = vm.PC; vm.PC = rpop(); rpush(pc); }
@@ -899,6 +905,7 @@ static void buildsysdict() {
sysconst("Z)", CONDZ); sysconst("NZ)", CONDNZ);
sysconst("C)", CONDC); sysconst("NC)", CONDNC);
sysconst("<)", CONDC); sysconst(">=)", CONDNC);
+ sysconst(">)", CONDA); sysconst("<=)", CONDNA);
for (int i=0; i<OPCNT-0x28; i++) {
if (opnames[i]) wentry(opnames[i], i+0x28);
}
