%
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
\section[ConFold]{Constant Folder}
Conceptually, constant folding should be parameterized with the kind
of target machine to get identical behaviour during compilation time
and runtime. We cheat a little bit here...
ToDo:
check boundaries before folding, e.g. we can fold the Float addition
(i1 + i2) only if it results in a valid Float.
\begin{code}
module PrelRules ( primOpRules, builtinRules ) where
#include "HsVersions.h"
import CoreSyn
import MkCore ( mkWildCase )
import Id ( idUnfolding )
import Literal ( Literal(..), mkMachInt, mkMachWord
, literalType
, word2IntLit, int2WordLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, char2IntLit, int2CharLit
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
, float2DoubleLit, double2FloatLit, litFitsInChar
)
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( cheapEqExpr, exprIsConApp_maybe )
import Type ( tyConAppTyCon, coreEqType )
import OccName ( occNameFS )
import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
eqStringName, unpackCStringIdKey, inlineIdName )
import Maybes ( orElse )
import Name ( Name, nameOccName )
import Outputable
import FastString
import StaticFlags ( opt_SimplExcessPrecision )
import Constants
import Data.Bits as Bits
import Data.Word ( Word )
\end{code}
Note [Constant folding]
~~~~~~~~~~~~~~~~~~~~~~~
primOpRules generates the rewrite rules for each primop
These rules do what is often called "constant folding"
E.g. the rules for +# might say
4 +# 5 = 9
Well, of course you'd need a lot of rules if you did it
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values. So the rule is really
more like
(Lit 4) +# (Lit y) = Lit (x+#y)
where the (+#) on the rhs is done at compile time
That is why these rules are built in here. Other rules
which don't need to be built in are in GHC.Base. For
example:
x +# 0 = x
\begin{code}
primOpRules :: PrimOp -> Name -> [CoreRule]
primOpRules op op_name = primop_rule op
where
one_lit = oneLit op_name
two_lits = twoLits op_name
relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
primop_rule IntAddOp = two_lits (intOp2 (+))
primop_rule IntSubOp = two_lits (intOp2 ())
primop_rule IntMulOp = two_lits (intOp2 (*))
primop_rule IntQuotOp = two_lits (intOp2Z quot)
primop_rule IntRemOp = two_lits (intOp2Z rem)
primop_rule IntNegOp = one_lit negOp
primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
primop_rule WordAddOp = two_lits (wordOp2 (+))
primop_rule WordSubOp = two_lits (wordOp2 ())
primop_rule WordMulOp = two_lits (wordOp2 (*))
primop_rule WordQuotOp = two_lits (wordOp2Z quot)
primop_rule WordRemOp = two_lits (wordOp2Z rem)
primop_rule AndOp = two_lits (wordBitOp2 (.&.))
primop_rule OrOp = two_lits (wordBitOp2 (.|.))
primop_rule XorOp = two_lits (wordBitOp2 xor)
primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
primop_rule OrdOp = one_lit (litCoerce char2IntLit)
primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
primop_rule FloatAddOp = two_lits (floatOp2 (+))
primop_rule FloatSubOp = two_lits (floatOp2 ())
primop_rule FloatMulOp = two_lits (floatOp2 (*))
primop_rule FloatDivOp = two_lits (floatOp2Z (/))
primop_rule FloatNegOp = one_lit negOp
primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
primop_rule DoubleSubOp = two_lits (doubleOp2 ())
primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
primop_rule DoubleNegOp = one_lit negOp
primop_rule IntEqOp = relop (==) ++ litEq op_name True
primop_rule IntNeOp = relop (/=) ++ litEq op_name False
primop_rule CharEqOp = relop (==) ++ litEq op_name True
primop_rule CharNeOp = relop (/=) ++ litEq op_name False
primop_rule IntGtOp = relop (>)
primop_rule IntGeOp = relop (>=)
primop_rule IntLeOp = relop (<=)
primop_rule IntLtOp = relop (<)
primop_rule CharGtOp = relop (>)
primop_rule CharGeOp = relop (>=)
primop_rule CharLeOp = relop (<=)
primop_rule CharLtOp = relop (<)
primop_rule FloatGtOp = relop (>)
primop_rule FloatGeOp = relop (>=)
primop_rule FloatLeOp = relop (<=)
primop_rule FloatLtOp = relop (<)
primop_rule FloatEqOp = relop (==)
primop_rule FloatNeOp = relop (/=)
primop_rule DoubleGtOp = relop (>)
primop_rule DoubleGeOp = relop (>=)
primop_rule DoubleLeOp = relop (<=)
primop_rule DoubleLtOp = relop (<)
primop_rule DoubleEqOp = relop (==)
primop_rule DoubleNeOp = relop (/=)
primop_rule WordGtOp = relop (>)
primop_rule WordGeOp = relop (>=)
primop_rule WordLeOp = relop (<=)
primop_rule WordLtOp = relop (<)
primop_rule WordEqOp = relop (==)
primop_rule WordNeOp = relop (/=)
primop_rule _ = []
\end{code}
%************************************************************************
%* *
\subsection{Doing the business}
%* *
%************************************************************************
ToDo: the reason these all return Nothing is because there used to be
the possibility of an argument being a litlit. Litlits are now gone,
so this could be cleaned up.
\begin{code}
litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
litCoerce fn lit = Just (Lit (fn lit))
predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
predLitCoerce p fn lit
| p lit = Just (Lit (fn lit))
| otherwise = Nothing
cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
cmpOp cmp l1 l2
= go l1 l2
where
done res | cmp res = Just trueVal
| otherwise = Just falseVal
go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
go _ _ = Nothing
negOp :: Literal -> Maybe CoreExpr
negOp (MachFloat 0.0) = Nothing
negOp (MachFloat f) = Just (mkFloatVal (f))
negOp (MachDouble 0.0) = Nothing
negOp (MachDouble d) = Just (mkDoubleVal (d))
negOp (MachInt i) = intResult (i)
negOp _ = Nothing
intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
intOp2 _ _ _ = Nothing
intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
intOp2Z op (MachInt i1) (MachInt i2)
| i2 /= 0 = intResult (i1 `op` i2)
intOp2Z _ _ _ = Nothing
intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
intShiftOp2 _ _ _ = Nothing
shiftRightLogical :: Integer -> Int -> Integer
shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordOp2 op (MachWord w1) (MachWord w2)
= wordResult (w1 `op` w2)
wordOp2 _ _ _ = Nothing
wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordOp2Z op (MachWord w1) (MachWord w2)
| w2 /= 0 = wordResult (w1 `op` w2)
wordOp2Z _ _ _ = Nothing
wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
-> Maybe CoreExpr
wordBitOp2 op (MachWord w1) (MachWord w2)
= wordResult (w1 `op` w2)
wordBitOp2 _ _ _ = Nothing
wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordShiftOp2 op (MachWord x) (MachInt n)
= wordResult (x `op` fromInteger n)
wordShiftOp2 _ _ _ = Nothing
floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
-> Maybe (Expr CoreBndr)
floatOp2 op (MachFloat f1) (MachFloat f2)
= Just (mkFloatVal (f1 `op` f2))
floatOp2 _ _ _ = Nothing
floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
-> Maybe (Expr CoreBndr)
floatOp2Z op (MachFloat f1) (MachFloat f2)
| (f1 /= 0 || f2 > 0)
&& f2 /= 0
= Just (mkFloatVal (f1 `op` f2))
floatOp2Z _ _ _ = Nothing
doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
-> Maybe (Expr CoreBndr)
doubleOp2 op (MachDouble f1) (MachDouble f2)
= Just (mkDoubleVal (f1 `op` f2))
doubleOp2 _ _ _ = Nothing
doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
-> Maybe (Expr CoreBndr)
doubleOp2Z op (MachDouble f1) (MachDouble f2)
| (f1 /= 0 || f2 > 0)
&& f2 /= 0
= Just (mkDoubleVal (f1 `op` f2))
doubleOp2Z _ _ _ = Nothing
litEq :: Name
-> Bool
-> [CoreRule]
litEq op_name is_eq
= [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
`appendFS` (fsLit "->case"),
ru_fn = op_name,
ru_nargs = 2, ru_try = rule_fn }]
where
rule_fn [Lit lit, expr] = do_lit_eq lit expr
rule_fn [expr, Lit lit] = do_lit_eq lit expr
rule_fn _ = Nothing
do_lit_eq lit expr
= Just (mkWildCase expr (literalType lit) boolTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
val_if_eq | is_eq = trueVal
| otherwise = falseVal
val_if_neq | is_eq = falseVal
| otherwise = trueVal
intResult :: Integer -> Maybe CoreExpr
intResult result
= Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
wordResult :: Integer -> Maybe CoreExpr
wordResult result
= Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
\end{code}
%************************************************************************
%* *
\subsection{Vaguely generic functions
%* *
%************************************************************************
\begin{code}
mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
mkBasicRule op_name n_args rule_fn
= [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
ru_fn = op_name,
ru_nargs = n_args, ru_try = rule_fn }]
oneLit :: Name -> (Literal -> Maybe CoreExpr)
-> [CoreRule]
oneLit op_name test
= mkBasicRule op_name 1 rule_fn
where
rule_fn [Lit l1] = test (convFloating l1)
rule_fn _ = Nothing
twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
-> [CoreRule]
twoLits op_name test
= mkBasicRule op_name 2 rule_fn
where
rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
rule_fn _ = Nothing
convFloating :: Literal -> Literal
convFloating (MachFloat f) | not opt_SimplExcessPrecision =
MachFloat (toRational ((fromRational f) :: Float ))
convFloating (MachDouble d) | not opt_SimplExcessPrecision =
MachDouble (toRational ((fromRational d) :: Double))
convFloating l = l
trueVal, falseVal :: Expr CoreBndr
trueVal = Var trueDataConId
falseVal = Var falseDataConId
mkIntVal :: Integer -> Expr CoreBndr
mkIntVal i = Lit (mkMachInt i)
mkWordVal :: Integer -> Expr CoreBndr
mkWordVal w = Lit (mkMachWord w)
mkFloatVal :: Rational -> Expr CoreBndr
mkFloatVal f = Lit (convFloating (MachFloat f))
mkDoubleVal :: Rational -> Expr CoreBndr
mkDoubleVal d = Lit (convFloating (MachDouble d))
\end{code}
%************************************************************************
%* *
\subsection{Special rules for seq, tagToEnum, dataToTag}
%* *
%************************************************************************
\begin{code}
tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
tagToEnumRule [Type ty, Lit (MachInt i)]
= ASSERT( isEnumerationTyCon tycon )
case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
[] -> Nothing
(dc:rest) -> ASSERT( null rest )
Just (Var (dataConWorkId dc))
where
correct_tag dc = (dataConTag dc fIRST_TAG) == tag
tag = fromInteger i
tycon = tyConAppTyCon ty
tagToEnumRule _ = Nothing
\end{code}
For dataToTag#, we can reduce if either
(a) the argument is a constructor
(b) the argument is a variable whose unfolding is a known constructor
\begin{code}
dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr)
dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
| tag_to_enum `hasKey` tagToEnumKey
, ty1 `coreEqType` ty2
= Just tag
dataToTagRule [_, val_arg]
| Just (dc,_) <- exprIsConApp_maybe val_arg
= ASSERT( not (isNewTyCon (dataConTyCon dc)) )
Just (mkIntVal (toInteger (dataConTag dc fIRST_TAG)))
dataToTagRule _ = Nothing
\end{code}
%************************************************************************
%* *
\subsection{Built in rules}
%* *
%************************************************************************
Note [Scoping for Builtin rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When compiling a (basepackage) module that defines one of the
functions mentioned in the RHS of a builtin rule, there's a danger
that we'll see
f = ...(eq String x)....
....and lower down...
eqString = ...
Then a rewrite would give
f = ...(eqString x)...
....and lower down...
eqString = ...
and lo, eqString is not in scope. This only really matters when we get to code
generation. With O we do a GlomBinds step that does a new SCC analysis on the whole
set of bindings, which sorts out the dependency. Without O we don't do any rule
rewriting so again we are fine.
(This whole thing doesn't show up for nonbuiltin rules because their dependencies
are explicit.)
\begin{code}
builtinRules :: [CoreRule]
builtinRules
= [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
ru_nargs = 4, ru_try = match_append_lit },
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
ru_nargs = 2, ru_try = match_eq_string },
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
ru_nargs = 2, ru_try = match_inline }
]
match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_append_lit [Type ty1,
Lit (MachStr s1),
c1,
Var unpk `App` Type ty2
`App` Lit (MachStr s2)
`App` c2
`App` n
]
| unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
= ASSERT( ty1 `coreEqType` ty2 )
Just (Var unpk `App` Type ty1
`App` Lit (MachStr (s1 `appendFS` s2))
`App` c1
`App` n)
match_append_lit _ = Nothing
match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_eq_string [Var unpk1 `App` Lit (MachStr s1),
Var unpk2 `App` Lit (MachStr s2)]
| unpk1 `hasKey` unpackCStringIdKey,
unpk2 `hasKey` unpackCStringIdKey
= Just (if s1 == s2 then trueVal else falseVal)
match_eq_string _ = Nothing
match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_inline (Type _ : e : _)
| (Var f, args1) <- collectArgs e,
Just unf <- maybeUnfoldingTemplate (idUnfolding f)
= Just (mkApps unf args1)
match_inline _ = Nothing
\end{code}