% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \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} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} module PrelRules ( builtinRules ) where #include "HsVersions.h" import CoreSyn import CoreUtils ( exprType ) import Id ( mkWildId, idUnfolding, idName ) import Literal ( Literal(..), mkMachInt, mkMachWord, mkMachFloat, mkMachDouble, literalType , inIntRange, inWordRange, targetMaxInt, targetMaxWord ) import PrimOp ( PrimOp(..), allThePrimOps ) import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import TysPrim import Coercion ( mkUnsafeCoercion ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) import Type ( tyConAppTyCon, coreEqType, splitTyConApp_maybe ) import OccName ( occNameFS ) import PrelNames ( unpackStringFoldrName, unpackStringFoldrIdKey, hasKey, eqStringName, unpackStringIdKey, inlineIdName ) import PrelInfo ( primOpId ) import Maybes ( orElse ) import Name ( Name, nameOccName ) import Outputable import FastString import DynFlags ( DynFlags, TargetConsts(..), targetConsts ) \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 :: DynFlags -> PrimOp -> Name -> [CoreRule] primOpRules dflags op op_name = primop_rule op where -- A useful shorthand one_lit f = oneLit op_name (f dflags) two_lits f = twoLits op_name (f dflags) relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ)) -- Cunning. cmpOp compares the values to give an Ordering. -- It applies its argument to that ordering value to turn -- the ordering into a boolean value. (`cmp` EQ) is just the job. -- ToDo: something for integer-shift ops? -- NotOp primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule -- Int operations 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 (\x y -> x * 2^y)) primop_rule ISraOp = two_lits (intShiftOp2 (\x y -> x `div` 2^y)) primop_rule ISrlOp = two_lits (intShiftOp2 (\x y -> i2w dflags x `quot` 2^y)) -- Word operations 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 (wordOp2 (mergeBits (&&))) primop_rule OrOp = two_lits (wordOp2 (mergeBits (||))) primop_rule XorOp = two_lits (wordOp2 (mergeBits (/=))) primop_rule SllOp = two_lits (wordShiftOp2 (\x y -> x * 2^y)) primop_rule SrlOp = two_lits (wordShiftOp2 (\x y -> x `quot` 2^y)) -- coercions primop_rule CastOp = castRule op_name dflags -- Float 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 -- Double 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 -- Relational operators 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 other = [] \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} -------------------------- castRule :: Name -> DynFlags -> [CoreRule] castRule op_name dflags = mkBasicRule op_name 3 rule_fn where rule_fn [Type u,Type v,Lit l] | Just (tc_u,_) <- splitTyConApp_maybe u , Just (tc_v,_) <- splitTyConApp_maybe v = do_cast tc_u tc_v l rule_fn _ = Nothing i `sext` mx | i > mx = i - 2*(mx+1) | otherwise = i do_cast tc_u tc_v l | tc_v == wordPrimTyCon, Just i <- lit_as_integer l = wordResult dflags i | tc_v == word8PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger (i`mod`256) word8PrimTyCon)) | tc_v == word16PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger (i`mod`65536) word16PrimTyCon)) | tc_v == word32PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger (i`mod`4294967296) word32PrimTyCon)) | tc_v == word64PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger (i`mod`18446744073709551616) word64PrimTyCon)) | tc_v == intPrimTyCon, Just i <- lit_as_integer l = intResult dflags i | tc_v == int8PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger ((i`mod`256)`sext`127) int8PrimTyCon)) | tc_v == int16PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger ((i`mod`65536)`sext`32767) int16PrimTyCon)) | tc_v == int32PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger ((i`mod`4294967296)`sext`2147483647) int32PrimTyCon)) | tc_v == int64PrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger ((i`mod`18446744073709551616)`sext`9223372036854775807) int64PrimTyCon)) | tc_v == floatPrimTyCon, Just r <- lit_as_rational l = floatResult dflags r | tc_v == doublePrimTyCon, Just r <- lit_as_rational l = doubleResult dflags r | tc_v == charPrimTyCon, Just i <- lit_as_integer l, i >= 0, i <= 0x10ffff = Just (Lit (MachInteger i charPrimTyCon)) | tc_v == addrPrimTyCon, Just i <- lit_as_integer l = Just (Lit (MachInteger (wrap dflags i) addrPrimTyCon)) | tc_v == boolPrimTyCon, Just r <- lit_as_rational l = Just (Lit (MachInteger (if r /= 0 then 1 else 0) boolPrimTyCon)) | otherwise = WARN(True,ppr l <+> text "as" <+> ppr tc_v) Nothing lit_as_integer (MachInteger i _) = Just i lit_as_integer (MachRational r _) | inIntRange dflags (truncate r) = Just (truncate r) lit_as_integer _ = Nothing lit_as_rational (MachRational r _) = Just r lit_as_rational l | Just i <- lit_as_integer l = Just (toRational i) lit_as_rational _ = Nothing -------------------------- cmpOp :: (Ordering -> Bool) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr cmpOp cmp dflags l1 l2 = go l1 l2 where done res | cmp res = Just trueVal | otherwise = Just falseVal -- These compares are at different types go (MachInteger i1 _) (MachInteger i2 _) = done (i1 `compare` i2) go (MachRational i1 _) (MachRational i2 _) = done (i1 `compare` i2) go l1 l2 = Nothing -------------------------- negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate negOp dflags (MachRational 0.0 _) = Nothing -- can't represent -0.0 as a Rational negOp dflags (MachRational r tc) = Just (Lit (MachRational (-r) tc)) negOp dflags (MachInteger i tc) = ASSERT(tc == intPrimTyCon) intResult dflags (-i) negOp dflags l = Nothing -------------------------- intOp2 :: (Integer->Integer->Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr intOp2 op dflags (MachInteger i1 tc1) (MachInteger i2 tc2) = ASSERT(tc1 == intPrimTyCon && tc2 == intPrimTyCon) ASSERT(inIntRange dflags i1 && inIntRange dflags i2) intResult dflags (i1 `op` i2) intOp2 dflags op l1 l2 = Nothing -- Could find LitLit intOp2Z :: (Integer->Integer->Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -- Like intOp2, but Nothing if i2=0 intOp2Z op dflags l1 l2@(MachInteger i2 _) | i2 /= 0 = intOp2 op dflags l1 l2 intOp2Z op dflags l1 l2 = Nothing -- LitLit or zero dividend intShiftOp2 :: (Integer->Integer->Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -- Shifts take an Int; hence second arg of op is Int intShiftOp2 op dflags (MachInteger i1 tc1) (MachInteger i2 tc2) | i2 >= 0 && i2 < toInteger (length (takeWhile (>0) (iterate (`quot`2) (targetMaxWord dflags)))) = ASSERT(tc1 == intPrimTyCon && tc2 == intPrimTyCon) ASSERT(inIntRange dflags i1 && inIntRange dflags i2) intResult dflags (i1 `op` i2) intShiftOp2 op dflags l1 l2 = Nothing -------------------------- wordOp2 :: (Integer->Integer->Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr wordOp2 op dflags (MachInteger w1 tc1) (MachInteger w2 tc2) = ASSERT(tc1 == wordPrimTyCon && tc2 == wordPrimTyCon) ASSERT(inWordRange dflags w1 && inWordRange dflags w2) wordResult dflags (w1 `op` w2) wordOp2 op dflags l1 l2 = Nothing -- Could find LitLit wordOp2Z :: (Integer->Integer->Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr wordOp2Z op dflags l1 l2@(MachInteger w2 _) | w2 /= 0 = wordOp2 op dflags l1 l2 wordOp2Z op dflags l1 l2 = Nothing -- LitLit or zero dividend wordShiftOp2 :: (Integer->Integer->Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -- Shifts take an Int; hence second arg of op is Int wordShiftOp2 op dflags (MachInteger x tc1) (MachInteger n tc2) | n >= 0 && n < toInteger (length (takeWhile (>0) (iterate (`quot`2) (targetMaxWord dflags)))) = ASSERT(tc1 == wordPrimTyCon && tc2 == intPrimTyCon) ASSERT(inWordRange dflags x && inIntRange dflags n) wordResult dflags (x `op` n) -- Do the shift at type Integer wordShiftOp2 op dflags l1 l2 = Nothing -------------------------- floatOp2 op dflags (MachRational f1 tc1) (MachRational f2 tc2) = ASSERT(tc1 == floatPrimTyCon && tc2 == floatPrimTyCon) floatResult dflags (f1 `op` f2) floatOp2 op dflags l1 l2 = Nothing floatOp2Z op dflags l1 l2@(MachRational f2 _) | f2 /= 0 = floatOp2 op dflags l1 l2 floatOp2Z op dflags l1 l2 = Nothing -------------------------- doubleOp2 op dflags (MachRational f1 tc1) (MachRational f2 tc2) = ASSERT(tc1 == doublePrimTyCon && tc2 == doublePrimTyCon) doubleResult dflags (f1 `op` f2) doubleOp2 op dflags l1 l2 = Nothing doubleOp2Z op dflags l1 l2@(MachRational f2 _) | f2 /= 0 = doubleOp2 op dflags l1 l2 doubleOp2Z op dflags l1 l2 = Nothing -------------------------- -- This stuff turns -- n ==# 3# -- into -- case n of -- 3# -> True -- m -> False -- -- This is a Good Thing, because it allows case-of case things -- to happen, and case-default absorption to happen. For -- example: -- -- if (n ==# 3#) || (n ==# 4#) then e1 else e2 -- will transform to -- case n of -- 3# -> e1 -- 4# -> e1 -- m -> e2 -- (modulo the usual precautions to avoid duplicating e1) litEq :: Name -> Bool -- True <=> equality, False <=> inequality -> [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 other = Nothing do_lit_eq lit expr = Just (Case expr (mkWildId (literalType lit)) boolPrimTy [(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 -- Note that we *don't* warn the user about overflow. It's not done at -- runtime either, and compilation of completely harmless things like -- ((124076834 :: Word32) + (2147483647 :: Word32)) -- would yield a warning. Instead we simply squash the value into the -- Int range w2i,i2w :: DynFlags -> Integer -> Integer w2i dflags w | w > targetMaxInt dflags = w - targetMaxWord dflags - 1 | otherwise = w i2w dflags i | i < 0 = i + targetMaxWord dflags + 1 | otherwise = i wrap :: DynFlags -> Integer -> Integer wrap dflags w = w `mod` (targetMaxWord dflags + 1) mergeBits :: (Bool -> Bool -> Bool) -> Integer -> Integer -> Integer mergeBits f x y = sum [bit | bit <- takeWhile (<=max x y) [2^i|i<-[0..]] ,odd (x `quot` bit) `f` odd (y`quot`bit)] intResult :: DynFlags -> Integer -> Maybe CoreExpr intResult dflags result = Just (mkIntVal (if inIntRange dflags result then result else w2i dflags (wrap dflags result))) wordResult :: DynFlags -> Integer -> Maybe CoreExpr wordResult dflags result = Just (mkWordVal (wrap dflags result)) floatResult :: DynFlags -> Rational -> Maybe CoreExpr floatResult dflags result = Just (mkFloatVal (roundRational (fltRadix tc) (fltMantDig tc) (fltMinExp tc) (fltMaxExp tc) result)) where tc = targetConsts dflags doubleResult :: DynFlags -> Rational -> Maybe CoreExpr doubleResult dflags result = Just (mkDoubleVal (roundRational (fltRadix tc) (dblMantDig tc) (dblMinExp tc) (dblMaxExp tc) result)) where tc = targetConsts dflags -- FIXME: This code needs to be double-checked (maybe a quickcheck test?) -- I'm a little unsure of the boundary cases -- forall x: roundRational ... x == toRational (fromRational x :: Double) roundRational :: Integer -> Int -> Int -> Int -> Rational -> Rational roundRational b mantDig minExp maxExp x = signum x * go (abs x) 0 where minExp' = minExp - mantDig - 1 maxExp' = maxExp - mantDig minMant = b^(mantDig-1) maxMant = b^mantDig go m e -- Check if the exponent is out of range (denormalized or infinity) | e <= minExp' = toRational (round (m/toRational b)) / toRational (b^(-minExp')) * toRational b | e > maxExp' = toRational maxMant * toRational (b^maxExp') -- The exponent is still good, keep moving towards the mantissa range | m < toRational minMant = go (m*toRational b) (e-1) | m >= toRational maxMant = go (m/toRational b) (e+1) -- We're in range, good | e < 0 = toRational (round m) / toRational (b^(-e)) | otherwise = toRational (round m) * toRational (b^e) \end{code} %************************************************************************ %* * \subsection{Vaguely generic functions %* * %************************************************************************ \begin{code} mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule] -- Gives the Rule the same name as the primop itself 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 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 l1 l2 rule_fn _ = Nothing trueVal = Lit (MachInteger 1 boolPrimTyCon) falseVal = Lit (MachInteger 0 boolPrimTyCon) mkIntVal i = Lit (mkMachInt i) mkWordVal w = Lit (mkMachWord w) mkFloatVal f = Lit (mkMachFloat f) mkDoubleVal d = Lit (mkMachDouble d) \end{code} %************************************************************************ %* * \subsection{Special rules for seq, dataToTag} %* * %************************************************************************ 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 [_, val_arg] | Just (dc,_) <- exprIsConApp_maybe val_arg = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) dataToTagRule other = Nothing \end{code} %************************************************************************ %* * \subsection{Built in rules} %* * %************************************************************************ \begin{code} builtinRules :: DynFlags -> [CoreRule] builtinRules dflags = preludeRules ++ [rule|primop <- allThePrimOps ,rule <-primOpRules dflags primop (idName (primOpId primop))] preludeRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma preludeRules = [ BuiltinRule FSLIT("AppendLitString") unpackStringFoldrName 4 match_append_lit, BuiltinRule FSLIT("EqString") eqStringName 2 match_eq_string, BuiltinRule FSLIT("Inline") inlineIdName 2 match_inline ] --------------------------------------------------- -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n match_append_lit [Type ty1, Lit (MachStr s1), c1, Var unpk `App` Type ty2 `App` Lit (MachStr s2) `App` c2 `App` n ] | unpk `hasKey` unpackStringFoldrIdKey && 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 other = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackString# (Lit s1)) (unpackString# (Lit s2) = s1==s2 match_eq_string [Var unpk1 `App` Lit (MachStr s1), Var unpk2 `App` Lit (MachStr s2)] | unpk1 `hasKey` unpackStringIdKey, unpk2 `hasKey` unpackStringIdKey = Just (if s1 == s2 then Var trueDataConId else Var falseDataConId) match_eq_string other = Nothing --------------------------------------------------- -- The rule is this: -- inline (f a b c) = a b c -- (if f has an unfolding) match_inline [Type _,e] | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (idUnfolding f) = Just (mkApps unf args1) match_inline other = Nothing \end{code}