X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=93cc576a81dee4cb5026777d2c132e57f8ed2d64;hp=bc8c9b81bc48e7a04abdf59ca6c6adb0833cd6bb;hb=224ef3094189bc9a33f23285b5dccbffdd8d7de0;hpb=c86161c5cf11de77e911fcb9e1e2bd1f8bd80b42 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index bc8c9b8..93cc576 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -9,10 +9,9 @@ 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. + (i1 + i2) only if it results in a valid Float. \begin{code} - {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} module PrelRules ( primOpRules, builtinRules ) where @@ -20,36 +19,28 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" import CoreSyn -import MkCore ( mkWildCase ) -import Id ( realIdUnfolding ) -import Literal ( Literal(..), mkMachInt, mkMachWord - , literalType - , word2IntLit, int2WordLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , float2DoubleLit, double2FloatLit, litFitsInChar - ) -import PrimOp ( PrimOp(..), tagToEnumKey ) -import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) -import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) -import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr ) -import CoreUnfold ( exprIsConApp_maybe ) -import Type ( tyConAppTyCon, coreEqType ) -import OccName ( occNameFS ) -import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, - eqStringName, unpackCStringIdKey, inlineIdName ) -import Maybes ( orElse ) -import Name ( Name, nameOccName ) +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 StaticFlags ( opt_SimplExcessPrecision ) import Constants import Data.Bits as Bits -import Data.Word ( Word ) +import Data.Int ( Int64 ) +import Data.Word ( Word, Word64 ) \end{code} @@ -58,39 +49,39 @@ 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 + 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) + (Lit x) +# (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 +which don't need to be built in are in GHC.Base. For example: - x +# 0 = x + x +# 0 = x \begin{code} primOpRules :: PrimOp -> Name -> [CoreRule] primOpRules op op_name = primop_rule op where - -- A useful shorthand + -- A useful shorthand 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. + -- 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 + -- ToDo: something for integer-shift ops? + -- NotOp primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule - -- Int operations + -- Int operations primop_rule IntAddOp = two_lits (intOp2 (+)) primop_rule IntSubOp = two_lits (intOp2 (-)) primop_rule IntMulOp = two_lits (intOp2 (*)) @@ -101,7 +92,7 @@ primOpRules op op_name = primop_rule op primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR) primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical) - -- Word operations + -- Word operations primop_rule WordAddOp = two_lits (wordOp2 (+)) primop_rule WordSubOp = two_lits (wordOp2 (-)) primop_rule WordMulOp = two_lits (wordOp2 (*)) @@ -113,85 +104,85 @@ primOpRules op op_name = primop_rule op primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL) primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical) - -- coercions - 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_lit (litCoerce float2DoubleLit) - primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit) - - -- Float + -- coercions + 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_lit (litCoerce float2DoubleLit) + primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit) + + -- 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 + -- 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 _ = [] + -- 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 (>) ++ boundsCmp op_name Gt + primop_rule IntGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule IntLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule IntLtOp = relop (<) ++ boundsCmp op_name Lt + + primop_rule CharGtOp = relop (>) ++ boundsCmp op_name Gt + primop_rule CharGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule CharLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule CharLtOp = relop (<) ++ boundsCmp op_name Lt + + 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 (>) ++ boundsCmp op_name Gt + primop_rule WordGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule WordLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule WordLtOp = relop (<) ++ boundsCmp op_name Lt + 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 @@ -214,9 +205,9 @@ cmpOp cmp l1 l2 = go l1 l2 where done res | cmp res = Just trueVal - | otherwise = Just falseVal + | otherwise = Just falseVal - -- These compares are at different types + -- These compares are at different types 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) @@ -228,7 +219,7 @@ cmpOp cmp l1 l2 -------------------------- -negOp :: Literal -> Maybe CoreExpr -- Negate +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 @@ -239,22 +230,22 @@ negOp _ = Nothing -------------------------- intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2) -intOp2 _ _ _ = 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 _ _ _ = 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 +-- Shifts take an Int; hence second arg of op is Int intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2) -intShiftOp2 _ _ _ = Nothing +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 +-- 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) @@ -263,25 +254,25 @@ 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 -- 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 _ _ _ = Nothing -- LitLit or zero dividend +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 +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) +-- 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 + -- Do the shift at type Integer +wordShiftOp2 _ _ _ = Nothing -------------------------- floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal @@ -293,7 +284,9 @@ floatOp2 _ _ _ = Nothing floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal -> Maybe (Expr CoreBndr) floatOp2Z op (MachFloat f1) (MachFloat f2) - | f2 /= 0 = Just (mkFloatVal (f1 `op` f2)) + | (f1 /= 0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + = Just (mkFloatVal (f1 `op` f2)) floatOp2Z _ _ _ = Nothing -------------------------- @@ -306,51 +299,104 @@ doubleOp2 _ _ _ = Nothing doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal -> Maybe (Expr CoreBndr) doubleOp2Z op (MachDouble f1) (MachDouble f2) - | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2)) + | (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 -------------------------- - -- 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 +-- 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 }] + = [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 - + rule_fn _ _ = Nothing + do_lit_eq lit expr = Just (mkWildCase expr (literalType lit) boolTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) + [(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 + | otherwise = trueVal + + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Name -> Comparison -> [CoreRule] +boundsCmp op_name op = [ rule ] + where + rule = BuiltinRule + { ru_name = occNameFS (nameOccName op_name) + `appendFS` (fsLit "min/maxBound") + , ru_fn = op_name + , ru_nargs = 2 + , ru_try = rule_fn + } + rule_fn _ [a, b] = mkRuleFn op a b + rule_fn _ _ = Nothing + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal +mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal +mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal +mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal +mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal +mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal +mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal +mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal +mkRuleFn _ _ _ = Nothing + +isMinBound :: Literal -> Bool +isMinBound (MachChar c) = c == minBound +isMinBound (MachInt i) = i == toInteger (minBound :: Int) +isMinBound (MachInt64 i) = i == toInteger (minBound :: Int64) +isMinBound (MachWord i) = i == toInteger (minBound :: Word) +isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64) +isMinBound _ = False + +isMaxBound :: Literal -> Bool +isMaxBound (MachChar c) = c == maxBound +isMaxBound (MachInt i) = i == toInteger (maxBound :: Int) +isMaxBound (MachInt64 i) = i == toInteger (maxBound :: Int64) +isMaxBound (MachWord i) = i == toInteger (maxBound :: Word) +isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64) +isMaxBound _ = False + -- Note that we *don't* warn the user about overflow. It's not done at -- runtime either, and compilation of completely harmless things like @@ -368,9 +414,9 @@ wordResult result %************************************************************************ -%* * -\subsection{Vaguely generic functions -%* * +%* * +\subsection{Vaguely generic functions} +%* * %************************************************************************ \begin{code} @@ -380,8 +426,8 @@ mkBasicRule :: Name -> Int -- 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 }] + ru_fn = op_name, + ru_nargs = n_args, ru_try = rule_fn }] oneLit :: Name -> (Literal -> Maybe CoreExpr) -> [CoreRule] @@ -392,8 +438,8 @@ oneLit op_name test rule_fn _ _ = Nothing twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr) - -> [CoreRule] -twoLits op_name test + -> [CoreRule] +twoLits op_name test = mkBasicRule op_name 2 rule_fn where rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) @@ -422,42 +468,67 @@ 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 -- 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 :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +-- If data T a = A | B | C +-- then tag2Enum# (T ty) 2# --> B ty 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)) - where + | Just (tycon, tc_args) <- splitTyConApp_maybe ty + , isEnumerationTyCon tycon + = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of + [] -> Nothing -- Abstract type + (dc:rest) -> ASSERT( null rest ) + Just (mkTyApps (Var (dataConWorkId dc)) tc_args) + | otherwise -- 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 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag - tag = fromInteger i - tycon = tyConAppTyCon ty + 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 + +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 -- dataToTag (tagToEnum x) ==> x + , ty1 `eqType` ty2 + = Just tag -- dataToTag (tagToEnum x) ==> x dataToTagRule id_unf [_, val_arg] | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg @@ -468,9 +539,9 @@ dataToTagRule _ _ = Nothing \end{code} %************************************************************************ -%* * +%* * \subsection{Built in rules} -%* * +%* * %************************************************************************ Note [Scoping for Builtin rules] @@ -479,17 +550,17 @@ 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).... + f = ...(eq String x).... - ....and lower down... + ....and lower down... - eqString = ... + eqString = ... Then a rewrite would give - f = ...(eqString x)... - ....and lower down... - eqString = ... + 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 @@ -505,44 +576,45 @@ builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_append_lit }, + ru_nargs = 4, ru_try = match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, + ru_nargs = 2, ru_try = match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = match_inline } + ru_nargs = 2, ru_try = match_inline } ] --------------------------------------------------- -- The rule is this: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c 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 && + 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 ) + = ASSERT( ty1 `eqType` ty2 ) Just (Var unpk `App` Type ty1 - `App` Lit (MachStr (s1 `appendFS` s2)) - `App` c1 - `App` n) + `App` Lit (MachStr (s1 `appendFS` s2)) + `App` c1 + `App` n) match_append_lit _ _ = Nothing --------------------------------------------------- -- The rule is this: --- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==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)] + Var unpk2 `App` Lit (MachStr s2)] | unpk1 `hasKey` unpackCStringIdKey, unpk2 `hasKey` unpackCStringIdKey = Just (if s1 == s2 then trueVal else falseVal) @@ -552,14 +624,14 @@ match_eq_string _ _ = Nothing --------------------------------------------------- -- The rule is this: --- inline f_ty (f a b c) = a b c +-- 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 +-- inline f a b c -- or inline (f a b c) --- (b) because a polymorphic f wll get a type argument that the +-- (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! @@ -567,7 +639,7 @@ match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_inline _ (Type _ : e : _) | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! + -- Ignore the IdUnfoldingFun here! = Just (mkApps unf args1) match_inline _ _ = Nothing