X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=bacd1bc8e041c198baa440153dcaedd6e6265753;hb=ac808e641e285df89b8f1bcda95b6e859bb4e4ab;hp=165d0088a7fea16d4789f77d0a23f26a083ea8a6;hpb=5943ce90c9c9d4319eec3cfe1fb3315f018e1c45;p=ghc-hetmet.git diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 165d008..bacd1bc 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -28,7 +28,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 ) @@ -119,7 +119,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) @@ -179,7 +179,7 @@ primOpRules op op_name = primop_rule op primop_rule WordEqOp = relop (==) primop_rule WordNeOp = relop (/=) - primop_rule other = [] + primop_rule _ = [] \end{code} @@ -199,6 +199,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 @@ -215,7 +220,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 -------------------------- @@ -225,23 +230,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 @@ -254,41 +259,51 @@ 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 op l1 l2 = Nothing -- Could find LitLit +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 -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) -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 -------------------------- @@ -316,13 +331,13 @@ 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 @@ -388,11 +403,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} @@ -404,6 +424,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 @@ -417,7 +438,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 @@ -426,6 +447,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 @@ -436,7 +458,7 @@ dataToTagRule [_, val_arg] = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) -dataToTagRule other = Nothing +dataToTagRule _ = Nothing \end{code} %************************************************************************ @@ -476,11 +498,11 @@ are explicit.) builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ BuiltinRule { ru_name = FSLIT("AppendLitString"), ru_fn = unpackCStringFoldrName, + = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, ru_nargs = 4, ru_try = match_append_lit }, - BuiltinRule { ru_name = FSLIT("EqString"), ru_fn = eqStringName, + BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = FSLIT("Inline"), ru_fn = inlineIdName, + BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, ru_nargs = 2, ru_try = match_inline } ] @@ -489,6 +511,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, @@ -505,19 +528,20 @@ 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 --------------------------------------------------- @@ -533,10 +557,11 @@ match_eq_string other = Nothing -- 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}