X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=67eb06f9d975514ece9902170ddf40c3ce6e6d8e;hb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;hp=07756704f6a7b44d0e9e4ed62eabd7102e803252;hpb=32995434659d9c3adb5e33d76a4a6c5daa5fc4a8;p=ghc-hetmet.git diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 0775670..67eb06f 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -20,7 +20,8 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" import CoreSyn -import Id ( mkWildId, idUnfolding ) +import MkCore ( mkWildCase ) +import Id ( idUnfolding ) import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit @@ -28,7 +29,7 @@ import Literal ( Literal(..), mkMachInt, mkMachWord , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , float2DoubleLit, double2FloatLit + , float2DoubleLit, double2FloatLit, litFitsInChar ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) @@ -44,13 +45,8 @@ import Name ( Name, nameOccName ) import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) - -import Data.Bits as Bits ( Bits(..) ) -#if __GLASGOW_HASKELL__ >= 500 +import Data.Bits as Bits import Data.Word ( Word ) -#else -import Data.Word ( Word64 ) -#endif \end{code} @@ -103,18 +99,14 @@ primOpRules op op_name = primop_rule op primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical) -- Word operations -#if __GLASGOW_HASKELL__ >= 500 primop_rule WordAddOp = two_lits (wordOp2 (+)) primop_rule WordSubOp = two_lits (wordOp2 (-)) primop_rule WordMulOp = two_lits (wordOp2 (*)) -#endif primop_rule WordQuotOp = two_lits (wordOp2Z quot) primop_rule WordRemOp = two_lits (wordOp2Z rem) -#if __GLASGOW_HASKELL__ >= 407 primop_rule AndOp = two_lits (wordBitOp2 (.&.)) primop_rule OrOp = two_lits (wordBitOp2 (.|.)) primop_rule XorOp = two_lits (wordBitOp2 xor) -#endif primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL) primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical) @@ -128,7 +120,7 @@ primOpRules op op_name = primop_rule op 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 (litCoerce int2CharLit) + 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) @@ -188,7 +180,7 @@ primOpRules op op_name = primop_rule op primop_rule WordEqOp = relop (==) primop_rule WordNeOp = relop (/=) - primop_rule other = [] + primop_rule _ = [] \end{code} @@ -208,6 +200,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 @@ -224,7 +221,7 @@ 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 -------------------------- @@ -234,23 +231,23 @@ 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 = intResult (i1 `op` i2) -intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend +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 op l1 l2 = Nothing +intShiftOp2 _ _ _ = Nothing shiftRightLogical :: Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do @@ -260,52 +257,54 @@ 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 = wordResult (w1 `op` w2) -wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend +wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend -#if __GLASGOW_HASKELL__ >= 500 -wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) +wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal + -> Maybe CoreExpr +wordBitOp2 op (MachWord w1) (MachWord w2) = wordResult (w1 `op` w2) -#else --- Integer is not an instance of Bits, so we operate on Word64 -wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) - = wordResult ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)) -#endif -wordBitOp2 op l1 l2 = Nothing -- Could find LitLit +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 op l1 l2 = Nothing +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 +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 +doubleOp2Z _ _ _ = Nothing -------------------------- @@ -333,16 +332,16 @@ litEq :: Name -> [CoreRule] litEq op_name is_eq = [BuiltinRule { ru_name = occNameFS (nameOccName op_name) - `appendFS` FSLIT("->case"), + `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 + rule_fn _ = Nothing do_lit_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) boolTy + = Just (mkWildCase expr (literalType lit) boolTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) val_if_eq | is_eq = trueVal @@ -359,11 +358,9 @@ intResult :: Integer -> Maybe CoreExpr intResult result = Just (mkIntVal (toInteger (fromInteger result :: Int))) -#if __GLASGOW_HASKELL__ >= 500 wordResult :: Integer -> Maybe CoreExpr wordResult result = Just (mkWordVal (toInteger (fromInteger result :: Word))) -#endif \end{code} @@ -407,11 +404,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} @@ -423,6 +425,7 @@ mkDoubleVal d = Lit (convFloating (MachDouble d)) %************************************************************************ \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 @@ -436,7 +439,7 @@ 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 @@ -445,6 +448,7 @@ For dataToTag#, we can reduce if either (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 @@ -455,7 +459,7 @@ dataToTagRule [_, val_arg] = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) -dataToTagRule other = Nothing +dataToTagRule _ = Nothing \end{code} %************************************************************************ @@ -464,13 +468,43 @@ 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 4 match_append_lit, - BuiltinRule FSLIT("EqString") eqStringName 2 match_eq_string, - BuiltinRule FSLIT("Inline") inlineIdName 1 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 } ] @@ -478,6 +512,7 @@ builtinRules -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n +match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_append_lit [Type ty1, Lit (MachStr s1), c1, @@ -494,29 +529,40 @@ 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 :: [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 +-- inline f_ty (f a b c) = a b c -- (if f has an unfolding) -match_inline (e:_) +-- +-- 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 :: [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 other = Nothing -\end{code} +match_inline _ = Nothing +\end{code}