X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=59562a2b2982b58892f2eb677298082e0538d68e;hp=f7a319873b41f40f1b0a4d3a6f9161f2cfe70267;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=f37e239fb5e81fc493e0ea1af98178bf1f7ceaba diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index f7a3198..59562a2 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -12,7 +12,6 @@ ToDo: (i1 + i2) only if it results in a valid Float. \begin{code} - {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} module PrelRules ( primOpRules, builtinRules ) where @@ -20,160 +19,163 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" import CoreSyn -import Id ( mkWildId, idUnfolding ) -import Literal ( Literal(..), mkMachInt, mkMachWord - , literalType - , word2IntLit, int2WordLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , float2DoubleLit, double2FloatLit - ) -import PrimOp ( PrimOp(..), primOpOcc, tagToEnumKey ) -import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) +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, exprIsConApp_maybe ) -import Type ( tyConAppTyCon, coreEqType ) +import CoreUtils ( cheapEqExpr ) +import CoreUnfold ( exprIsConApp_maybe ) +import Type import OccName ( occNameFS ) -import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, - eqStringName, unpackCStringIdKey, inlineIdName ) +import PrelNames import Maybes ( orElse ) -import Name ( Name ) +import Name ( Name, nameOccName ) import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) +import Constants -import DATA_BITS ( Bits(..) ) -#if __GLASGOW_HASKELL__ >= 500 -import DATA_WORD ( Word ) -#else -import DATA_WORD ( Word64 ) -#endif +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 - rule_name = occNameFS (primOpOcc op) - rule_name_case = rule_name `appendFS` FSLIT("->case") - -- A useful shorthand - one_rule rule_fn = [BuiltinRule { ru_name = rule_name, - ru_fn = op_name, - ru_try = rule_fn }] - case_rule rule_fn = [BuiltinRule { ru_name = rule_name_case, - ru_fn = op_name, - ru_try = rule_fn }] + one_lit = oneLit op_name + two_lits = twoLits op_name + 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 TagToEnumOp = one_rule tagToEnumRule - primop_rule DataToTagOp = one_rule dataToTagRule + primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule + primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule -- Int operations - primop_rule IntAddOp = one_rule (twoLits (intOp2 (+))) - primop_rule IntSubOp = one_rule (twoLits (intOp2 (-))) - primop_rule IntMulOp = one_rule (twoLits (intOp2 (*))) - primop_rule IntQuotOp = one_rule (twoLits (intOp2Z quot)) - primop_rule IntRemOp = one_rule (twoLits (intOp2Z rem)) - primop_rule IntNegOp = one_rule (oneLit negOp) + 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) -- Word operations -#if __GLASGOW_HASKELL__ >= 500 - primop_rule WordAddOp = one_rule (twoLits (wordOp2 (+))) - primop_rule WordSubOp = one_rule (twoLits (wordOp2 (-))) - primop_rule WordMulOp = one_rule (twoLits (wordOp2 (*))) -#endif - primop_rule WordQuotOp = one_rule (twoLits (wordOp2Z quot)) - primop_rule WordRemOp = one_rule (twoLits (wordOp2Z rem)) -#if __GLASGOW_HASKELL__ >= 407 - primop_rule AndOp = one_rule (twoLits (wordBitOp2 (.&.))) - primop_rule OrOp = one_rule (twoLits (wordBitOp2 (.|.))) - primop_rule XorOp = one_rule (twoLits (wordBitOp2 xor)) -#endif + 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) -- coercions - primop_rule Word2IntOp = one_rule (oneLit (litCoerce word2IntLit)) - primop_rule Int2WordOp = one_rule (oneLit (litCoerce int2WordLit)) - primop_rule Narrow8IntOp = one_rule (oneLit (litCoerce narrow8IntLit)) - primop_rule Narrow16IntOp = one_rule (oneLit (litCoerce narrow16IntLit)) - primop_rule Narrow32IntOp = one_rule (oneLit (litCoerce narrow32IntLit)) - primop_rule Narrow8WordOp = one_rule (oneLit (litCoerce narrow8WordLit)) - primop_rule Narrow16WordOp = one_rule (oneLit (litCoerce narrow16WordLit)) - primop_rule Narrow32WordOp = one_rule (oneLit (litCoerce narrow32WordLit)) - primop_rule OrdOp = one_rule (oneLit (litCoerce char2IntLit)) - primop_rule ChrOp = one_rule (oneLit (litCoerce int2CharLit)) - primop_rule Float2IntOp = one_rule (oneLit (litCoerce float2IntLit)) - primop_rule Int2FloatOp = one_rule (oneLit (litCoerce int2FloatLit)) - primop_rule Double2IntOp = one_rule (oneLit (litCoerce double2IntLit)) - primop_rule Int2DoubleOp = one_rule (oneLit (litCoerce int2DoubleLit)) + 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) -- SUP: Not sure what the standard says about precision in the following 2 cases - primop_rule Float2DoubleOp = one_rule (oneLit (litCoerce float2DoubleLit)) - primop_rule Double2FloatOp = one_rule (oneLit (litCoerce double2FloatLit)) + primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit) + primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit) -- Float - primop_rule FloatAddOp = one_rule (twoLits (floatOp2 (+))) - primop_rule FloatSubOp = one_rule (twoLits (floatOp2 (-))) - primop_rule FloatMulOp = one_rule (twoLits (floatOp2 (*))) - primop_rule FloatDivOp = one_rule (twoLits (floatOp2Z (/))) - primop_rule FloatNegOp = one_rule (oneLit negOp) + 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 = one_rule (twoLits (doubleOp2 (+))) - primop_rule DoubleSubOp = one_rule (twoLits (doubleOp2 (-))) - primop_rule DoubleMulOp = one_rule (twoLits (doubleOp2 (*))) - primop_rule DoubleDivOp = one_rule (twoLits (doubleOp2Z (/))) - primop_rule DoubleNegOp = one_rule (oneLit 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 -- Relational operators - primop_rule IntEqOp = one_rule (relop (==)) ++ case_rule (litEq True) - primop_rule IntNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) - primop_rule CharEqOp = one_rule (relop (==)) ++ case_rule (litEq True) - primop_rule CharNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) - - primop_rule IntGtOp = one_rule (relop (>)) - primop_rule IntGeOp = one_rule (relop (>=)) - primop_rule IntLeOp = one_rule (relop (<=)) - primop_rule IntLtOp = one_rule (relop (<)) - - primop_rule CharGtOp = one_rule (relop (>)) - primop_rule CharGeOp = one_rule (relop (>=)) - primop_rule CharLeOp = one_rule (relop (<=)) - primop_rule CharLtOp = one_rule (relop (<)) - - primop_rule FloatGtOp = one_rule (relop (>)) - primop_rule FloatGeOp = one_rule (relop (>=)) - primop_rule FloatLeOp = one_rule (relop (<=)) - primop_rule FloatLtOp = one_rule (relop (<)) - primop_rule FloatEqOp = one_rule (relop (==)) - primop_rule FloatNeOp = one_rule (relop (/=)) - - primop_rule DoubleGtOp = one_rule (relop (>)) - primop_rule DoubleGeOp = one_rule (relop (>=)) - primop_rule DoubleLeOp = one_rule (relop (<=)) - primop_rule DoubleLtOp = one_rule (relop (<)) - primop_rule DoubleEqOp = one_rule (relop (==)) - primop_rule DoubleNeOp = one_rule (relop (/=)) - - primop_rule WordGtOp = one_rule (relop (>)) - primop_rule WordGeOp = one_rule (relop (>=)) - primop_rule WordLeOp = one_rule (relop (<=)) - primop_rule WordLtOp = one_rule (relop (<)) - primop_rule WordEqOp = one_rule (relop (==)) - primop_rule WordNeOp = one_rule (relop (/=)) - - primop_rule other = [] - - - relop cmp = twoLits (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. + 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} %************************************************************************ @@ -191,6 +193,11 @@ so this could be cleaned up. 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 @@ -207,63 +214,98 @@ cmpOp cmp l1 l2 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 l1 l2 = Nothing + go _ _ = Nothing -------------------------- -negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp (MachFloat f) = Just (mkFloatVal (-f)) +negOp :: Literal -> Maybe CoreExpr -- Negate +negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp (MachFloat f) = Just (mkFloatVal (-f)) negOp (MachDouble 0.0) = Nothing negOp (MachDouble d) = Just (mkDoubleVal (-d)) negOp (MachInt i) = intResult (-i) -negOp l = Nothing +negOp _ = Nothing -------------------------- +intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2) -intOp2 op l1 l2 = Nothing -- Could find LitLit +intOp2 _ _ _ = Nothing -- Could find LitLit +intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr +-- Like intOp2, but Nothing if i2=0 intOp2Z op (MachInt i1) (MachInt i2) - | i2 /= 0 = Just (mkIntVal (i1 `op` i2)) -intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend + | i2 /= 0 = intResult (i1 `op` i2) +intOp2Z _ _ _ = Nothing -- LitLit or zero dividend + +intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr + -- Shifts take an Int; hence second arg of op is Int +intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2) +intShiftOp2 _ _ _ = Nothing + +shiftRightLogical :: Integer -> Int -> Integer +-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do +-- Do this by converting to Word and back. Obviously this won't work for big +-- values, but its ok as we use it here +shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word) + -------------------------- -#if __GLASGOW_HASKELL__ >= 500 +wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr wordOp2 op (MachWord w1) (MachWord w2) = wordResult (w1 `op` w2) -wordOp2 op l1 l2 = Nothing -- Could find LitLit -#endif +wordOp2 _ _ _ = Nothing -- Could find LitLit +wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr wordOp2Z op (MachWord w1) (MachWord w2) - | w2 /= 0 = Just (mkWordVal (w1 `op` w2)) -wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend - -#if __GLASGOW_HASKELL__ >= 500 -wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) - = Just (mkWordVal (w1 `op` w2)) -#else --- Integer is not an instance of Bits, so we operate on Word64 -wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) - = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))) -#endif -wordBitOp2 op l1 l2 = Nothing -- Could find LitLit + | w2 /= 0 = wordResult (w1 `op` w2) +wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend + +wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal + -> Maybe CoreExpr +wordBitOp2 op (MachWord w1) (MachWord w2) + = wordResult (w1 `op` w2) +wordBitOp2 _ _ _ = Nothing -- Could find LitLit + +wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr + -- Shifts take an Int; hence second arg of op is Int +wordShiftOp2 op (MachWord x) (MachInt n) + = wordResult (x `op` fromInteger n) + -- Do the shift at type Integer +wordShiftOp2 _ _ _ = Nothing -------------------------- +floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal + -> Maybe (Expr CoreBndr) floatOp2 op (MachFloat f1) (MachFloat f2) = Just (mkFloatVal (f1 `op` f2)) -floatOp2 op l1 l2 = Nothing +floatOp2 _ _ _ = Nothing +floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal + -> Maybe (Expr CoreBndr) floatOp2Z op (MachFloat f1) (MachFloat f2) - | f2 /= 0 = Just (mkFloatVal (f1 `op` f2)) -floatOp2Z op l1 l2 = Nothing + | (f1 /= 0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + = 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 op l1 l2 = Nothing +doubleOp2 _ _ _ = Nothing +doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal + -> Maybe (Expr CoreBndr) doubleOp2Z op (MachDouble f1) (MachDouble f2) - | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2)) -doubleOp2Z op l1 l2 = Nothing + | (f1 /= 0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + = Just (mkDoubleVal (f1 `op` f2)) + -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to + -- zero, but we might want to preserve the negative zero here which + -- is representable in Float/Double but not in (normalised) + -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? +doubleOp2Z _ _ _ = Nothing -------------------------- @@ -286,19 +328,25 @@ doubleOp2Z op l1 l2 = Nothing -- m -> e2 -- (modulo the usual precautions to avoid duplicating e1) -litEq :: Bool -- True <=> equality, False <=> inequality - -> RuleFun -litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr -litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr -litEq is_eq other = Nothing - -do_lit_eq is_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) boolTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) +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 _ _ = 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 + | otherwise = falseVal val_if_neq | is_eq = falseVal | otherwise = trueVal @@ -306,16 +354,14 @@ do_lit_eq is_eq lit expr -- 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, but not in a way suitable for cross-compiling... :-( +-- *target* Int/Word range. intResult :: Integer -> Maybe CoreExpr intResult result - = Just (mkIntVal (toInteger (fromInteger result :: Int))) + = Just (mkIntVal (toInteger (fromInteger result :: TargetInt))) -#if __GLASGOW_HASKELL__ >= 500 wordResult :: Integer -> Maybe CoreExpr wordResult result - = Just (mkWordVal (toInteger (fromInteger result :: Word))) -#endif + = Just (mkWordVal (toInteger (fromInteger result :: TargetWord))) \end{code} @@ -326,15 +372,30 @@ wordResult result %************************************************************************ \begin{code} -type RuleFun = [CoreExpr] -> Maybe CoreExpr - -twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun -twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2) -twoLits rule _ = Nothing +mkBasicRule :: Name -> Int + -> (IdUnfoldingFun -> [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 (convFloating l1) + rule_fn _ _ = Nothing -oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun -oneLit rule [Lit l1] = rule (convFloating l1) -oneLit rule _ = 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 -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture @@ -346,12 +407,16 @@ 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} @@ -362,12 +427,41 @@ mkDoubleVal d = Lit (convFloating (MachDouble d)) %* * %************************************************************************ +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 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +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 [Type ty, Lit (MachInt i)] +tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +tagToEnumRule _ [Type ty, _] + | not (is_enum_ty ty) -- See Note [tagToEnum#] + = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) + Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type") + where + is_enum_ty ty = case splitTyConApp_maybe ty of + Just (tc, _) -> isEnumerationTyCon tc + Nothing -> False + +tagToEnumRule _ [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of - - [] -> Nothing -- Abstract type (dc:rest) -> ASSERT( null rest ) Just (Var (dataConWorkId dc)) @@ -376,26 +470,28 @@ tagToEnumRule [Type ty, Lit (MachInt i)] tag = fromInteger i tycon = tyConAppTyCon ty -tagToEnumRule other = Nothing +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 [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] +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 -- dataToTag (tagToEnum x) ==> x -dataToTagRule [_, val_arg] - | Just (dc,_) <- exprIsConApp_maybe val_arg +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 other = Nothing +dataToTagRule _ _ = Nothing \end{code} %************************************************************************ @@ -404,28 +500,60 @@ dataToTagRule other = Nothing %* * %************************************************************************ +Note [Scoping for Builtin rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling a (base-package) module that defines one of the +functions mentioned in the RHS of a built-in 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 non-built-in rules because their dependencies +are explicit.) + + \begin{code} builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit, - BuiltinRule FSLIT("EqString") eqStringName match_eq_string, - BuiltinRule FSLIT("Inline") inlineIdName match_inline + = [ 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 } ] --------------------------------------------------- -- 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 - ] +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) +-- = unpackFoldrCString# "foobaz" c n + +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 ) @@ -434,29 +562,42 @@ match_append_lit [Type ty1, `App` c1 `App` n) -match_append_lit other = Nothing +match_append_lit _ _ = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 -match_eq_string [Var unpk1 `App` Lit (MachStr s1), - Var unpk2 `App` Lit (MachStr s2)] +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 other = Nothing +match_eq_string _ _ = Nothing --------------------------------------------------- -- The rule is this: --- inline (f a b c) = a b c --- (if f has an unfolding) -match_inline (e:args2) +-- inline f_ty (f a b c) = a b c +-- (if f has an unfolding, EVEN if it's a loop breaker) +-- +-- It's important to allow the argument to 'inline' to have args itself +-- (a) because its more forgiving to allow the programmer to write +-- inline f a b c +-- or inline (f a b c) +-- (b) because a polymorphic f wll get a type argument that the +-- programmer can't avoid +-- +-- Also, don't forget about 'inline's type argument! +match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline _ (Type _ : e : _) | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (idUnfolding f) - = Just (mkApps (mkApps unf args1) args2) + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! + = Just (mkApps unf args1) + +match_inline _ _ = Nothing +\end{code} -match_inline other = Nothing -\end{code}