%
% (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
import Id
import Literal
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( cheapEqExpr )
import CoreUnfold ( exprIsConApp_maybe )
import Type
import OccName ( occNameFS )
import PrelNames
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
-> (IdUnfoldingFun -> [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}
%* *
%************************************************************************
Note [tagToEnum#]
~~~~~~~~~~~~~~~~~
Nasty check to ensure that tagToEnum# is applied to a type that is an
enumeration TyCon. Unification may refine the type later, but this
check won't see that, alas. It's crude but it works.
Here's are two cases that should fail
f :: forall a. a
f = tagToEnum# 0
g :: Int
g = tagToEnum# 0
We used to make this check in the type inference engine, but it's quite
ugly to do so, because the delayed constraint solving means that we don't
really know what's going on until the end. It's very much a corner case
because we don't expect the user to call tagToEnum# at all; we merely
generate calls in derived instances of Enum. So we compromise: a
rewrite rule rewrites a bad instance of tagToEnum# to an error call,
and emits a warning.
\begin{code}
tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
tagToEnumRule _ [Type ty, Lit (MachInt i)]
| Just (tycon, tc_args) <- splitTyConApp_maybe ty
, isEnumerationTyCon tycon
= case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
[] -> Nothing
(dc:rest) -> ASSERT( null rest )
Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
| otherwise
= WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
where
correct_tag dc = (dataConTag dc fIRST_TAG) == tag
tag = fromInteger i
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 :: IdUnfoldingFun -> [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 id_unf [_, val_arg]
| Just (dc,_,_) <- exprIsConApp_maybe id_unf 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 :: IdUnfoldingFun -> [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 :: IdUnfoldingFun -> [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 :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_inline _ (Type _ : e : _)
| (Var f, args1) <- collectArgs e,
Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
= Just (mkApps unf args1)
match_inline _ _ = Nothing
\end{code}