commit aedbff9a3a217447cd4c407b3521a3968d67b814
parent 870b813930f7084ac4e41e5fb0afe536d5d4f4c1
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sun, 19 Mar 2023 14:41:46 -0400
halcc: do constant folding on binops
This is a bit verbose, but it does wider folding than the previous CC
incarnation. Previously, we only did folding when both operands were constants.
Now, we also apply special logic for 0 and 1 values of one of the operands.
Diffstat:
3 files changed, 76 insertions(+), 27 deletions(-)
diff --git a/fs/comp/c/egen.fs b/fs/comp/c/egen.fs
@@ -1,7 +1,7 @@
\ Expression code generation
require /sys/scratch.fs
?f<< /comp/c/tok.fs
-?f<< /comp/c/op.fs
+?f<< /comp/c/expr.fs
?f<< /comp/c/func.fs
: _err ( -- ) tokdbg abort" egen error" ;
@@ -18,31 +18,6 @@ Arena :new structbind Arena _litarena
\ Maximum size in bytes that a single literal can have
$400 const MAXLITSZ
-struct[ Result
- 0 const CONST \ Is a constant (value in arg)
- 1 const W \ Value in W register
- 2 const HALOP \ Value in memory, HAL operand is in arg.
- sfield type
- sfield arg \ either HAL operand or constant value
-
- : :new ( arg type -- res ) SZ syspad :allot dup >r !+ ! r> ;
- : :const ( n -- res ) CONST :new ;
- : :W ( -- res ) 0 W :new ;
- : :hal ( operand -- res ) HALOP :new ;
-
- : :>W ( self -- ) dup bi arg | type case ( self arg )
- CONST of = LIT>W, endof
- W of = drop endof
- HALOP of = @, endof
- _err endcase W swap to type ;
- : :hal# ( self -- halop ) dup type case ( self )
- HALOP of = arg endof
- CONST of = arg i) endof
- _err endcase ;
- : :isconst? ( self -- f ) type CONST = ;
- : :isW? ( self -- f ) type W = ;
-]struct
-
alias noop parseExpression ( tok -- res ) \ forward declaration
alias noop parseFactor ( tok -- res ) \ forward declaration
@@ -102,7 +77,21 @@ BOPSCNT wordtbl _tbl ( -- )
'w _err 'w _err 'w _=, 'w _err 'w _err 'w _err 'w _err 'w _err
'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
-: applyBinop ( left right opid -- res ) _tbl swap wexec ;
+: bothconst? ( left right -- f ) Result :isconst? swap Result :isconst? and ;
+
+: ?constApply ( left right opid -- left right opid 0 | res 1 ) >r \ V1=opid
+ 2dup bothconst? if r@ applyConstBinop 1 else ( left right )
+ dup Result :isone? r@ neutralbyrone? and if drop 1 else
+ over Result :isone? r@ neutralbyone? and if nip 1 else
+ dup Result :iszero? r@ nulledbyzero? and if nip 1 else
+ over Result :iszero? r@ nulledbyzero? and if drop 1 else
+ dup Result :iszero? r@ neutralbyrzero? and if drop 1 else
+ over Result :iszero? r@ neutralbyzero? and if nip 1 else 0 then
+ then then then then then then ( left right opid 0 | res 1 )
+ dup if rdrop else r> swap then ;
+
+: applyBinop ( left right opid -- res )
+ ?constApply not if _tbl swap wexec then ;
\ Parse the "right" part of an expression with the leftmost factor and leftmost
\ binary operator already parsed.
diff --git a/fs/comp/c/expr.fs b/fs/comp/c/expr.fs
@@ -0,0 +1,42 @@
+\ Expression parsing and constexpr resolving
+?f<< /comp/c/op.fs
+
+: _err ( -- ) tokdbg abort" expr error" ;
+: _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 HALOP \ Value in memory, HAL operand is in arg.
+ sfield type
+ sfield arg \ either HAL operand or constant value
+
+ : :new ( arg type -- res ) SZ syspad :allot dup >r !+ ! r> ;
+ : :const ( n -- res ) CONST :new ;
+ : :W ( -- res ) 0 W :new ;
+ : :hal ( operand -- res ) HALOP :new ;
+
+ : :>W ( self -- ) dup bi arg | type case ( self arg )
+ CONST of = LIT>W, endof
+ W of = drop endof
+ HALOP of = @, endof
+ _err endcase W swap to type ;
+ : :hal# ( self -- halop ) dup type case ( self )
+ HALOP of = arg endof
+ CONST of = arg i) endof
+ _err endcase ;
+ : :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 ;
+]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 _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
+
+: applyConstBinop ( left right opid -- res )
+ >r swap Result :const# swap Result :const# _tbl r> wexec Result :const ;
diff --git a/fs/comp/c/op.fs b/fs/comp/c/op.fs
@@ -35,3 +35,21 @@ create bopsprectbl BOPSCNT nc,
: bopprec ( opid -- precedence ) BOPSCNT min bopsprectbl + c@ ;
: boptoken ( opid -- tok ) BOPTlist slistiter ;
: ptrbop? ( opid -- f ) 2 < ; \ can op be applied to pointers?
+
+\ List of opids nullified by a zero. we're lazy and apply this to division
+create _ 4 nc, 2 3 4 $d \ * / % &
+: nulledbyzero? ( bopid -- f ) _ 4 [c]? 0>= ;
+
+\ List of opids neutralized by a zero (any position).
+create _ 3 nc, 0 $e $f \ + ^ |
+: neutralbyzero? ( bopid -- f ) _ 3 [c]? 0>= ;
+
+\ List of opids neutralized by a zero right operand
+create _ 3 nc, 1 5 6 \ - << >>
+: neutralbyrzero? ( bopid -- f ) bi neutralbyzero? | _ 3 [c]? 0>= or ;
+
+\ List of opids neutralized by a one (any position).
+: neutralbyone? ( bopid -- f ) 2 = ; \ *
+
+\ List of opids neutralized by a one right operand.
+: neutralbyrone? ( bopid -- f ) bi neutralbyone? | 3 - 2 < or ; \ / %
