Ticket #7014: 7014.patch

File 7014.patch, 25.5 KB (added by pcapriotti, 3 years ago)
  • compiler/prelude/PrelRules.lhs

    From 47c99d5b2f80bdfc1fd05260562352aa8fc56071 Mon Sep 17 00:00:00 2001
    From: Paolo Capriotti <[email protected]>
    Date: Wed, 4 Jul 2012 11:47:55 +0100
    Subject: [PATCH] Refactor PrelRules and add more rules (#7014)
    
    Ported various rules for numeric types from GHC.Base. Added new rules
    for bitwise operations, shifts and word comparisons.
    ---
     compiler/prelude/PrelRules.lhs |  454 ++++++++++++++++++++++++----------------
     1 file changed, 269 insertions(+), 185 deletions(-)
    
    diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
    index dab34fc..11c1454 100644
    a b ToDo: 
    1212   (i1 + i2) only if it results in a valid Float.
    1313
    1414\begin{code}
     15{-# LANGUAGE Rank2Types #-}
    1516{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
    1617
    1718module PrelRules ( primOpRules, builtinRules ) where
    import Constants 
    4546import BasicTypes
    4647import Util
    4748
     49import Control.Monad
    4850import Data.Bits as Bits
    4951import Data.Int    ( Int64 )
    5052import Data.Word   ( Word, Word64 )
    example: 
    7476primOpRules :: PrimOp -> Name -> [CoreRule]
    7577primOpRules op op_name = primop_rule op
    7678  where
    77     -- A useful shorthand
    78     one_lit   = oneLit  op_name
    79     two_lits  = twoLits op_name
    80     relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
    81     -- Cunning.  cmpOp compares the values to give an Ordering.
    82     -- It applies its argument to that ordering value to turn
    83     -- the ordering into a boolean value.  (`cmp` EQ) is just the job.
     79    -- useful shorthands
     80    rules arity = mkBasicRule op_name arity . msum
     81
     82    relop :: (forall a . Ord a => a -> a -> Bool) -> [CoreRule]
     83    relop cmp = rules 2 [ binaryLit (cmpOp cmp)
     84                        , equalArgs >>
     85                          -- x `cmp` x does not depend on x, so
     86                          -- compute it for the arbitrary value 'True'
     87                          -- and use that result
     88                          return (if cmp True True
     89                                    then trueVal
     90                                    else falseVal) ]
    8491
    8592    -- ToDo: something for integer-shift ops?
    8693    --       NotOp
    8794
    88     primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
    89     primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
     95    -- common constants
     96    zeroi = mkMachInt 0
     97    onei = mkMachInt 1
     98    zerow = mkMachWord 0
     99    onew = mkMachWord 1
     100    zerof = mkMachFloat 0.0
     101    onef = mkMachFloat 1.0
     102    zerod = mkMachDouble 0.0
     103    oned = mkMachDouble 1.0
     104
     105    identity lit = leftIdentity lit `mplus` rightIdentity lit
     106    zeroElem lit = leftZero lit `mplus` rightZero lit
     107
     108    primop_rule TagToEnumOp = rules 2 [ tagToEnumRule ]
     109    primop_rule DataToTagOp = rules 2 [ dataToTagRule ]
    90110
    91111    -- Int operations
    92     primop_rule IntAddOp    = two_lits (intOp2     (+))
    93     primop_rule IntSubOp    = two_lits (intOp2     (-))
    94     primop_rule IntMulOp    = two_lits (intOp2     (*))
    95     primop_rule IntQuotOp   = two_lits (intOp2Z    quot)
    96     primop_rule IntRemOp    = two_lits (intOp2Z    rem)
    97     primop_rule IntNegOp    = one_lit  negOp
    98     primop_rule ISllOp      = two_lits (intShiftOp2 Bits.shiftL)
    99     primop_rule ISraOp      = two_lits (intShiftOp2 Bits.shiftR)
    100     primop_rule ISrlOp      = two_lits (intShiftOp2 shiftRightLogical)
     112    primop_rule IntAddOp    = rules 2 [ binaryLit (intOp2 (+))
     113                                      , identity zeroi ]
     114    primop_rule IntSubOp    = rules 2 [ binaryLit (intOp2 (-))
     115                                      , rightIdentity zeroi
     116                                      , equalArgs >> return (Lit zeroi) ]
     117    primop_rule IntMulOp    = rules 2 [ binaryLit (intOp2 (*))
     118                                      , zeroElem zeroi
     119                                      , identity onei ]
     120    primop_rule IntQuotOp   = rules 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
     121                                      , leftZero zeroi
     122                                      , rightIdentity onei
     123                                      , equalArgs >> return (Lit onei) ]
     124    primop_rule IntRemOp    = rules 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
     125                                      , leftZero zeroi
     126                                      , do l <- getLiteral 1
     127                                           guard (l == onei)
     128                                           return (Lit zeroi)
     129                                      , equalArgs >> return (Lit zeroi)
     130                                      , equalArgs >> return (Lit zeroi) ]
     131    primop_rule IntNegOp    = rules 1 [ unaryLit negOp ]
     132    primop_rule ISllOp      = rules 2 [ binaryLit (intOp2 Bits.shiftL)
     133                                      , rightIdentity zeroi ]
     134    primop_rule ISraOp      = rules 2 [ binaryLit (intOp2 Bits.shiftR)
     135                                      , rightIdentity zeroi ]
     136    primop_rule ISrlOp      = rules 2 [ binaryLit (intOp2 shiftRightLogical)
     137                                      , rightIdentity zeroi ]
    101138
    102139    -- Word operations
    103     primop_rule WordAddOp   = two_lits (wordOp2    (+))
    104     primop_rule WordSubOp   = two_lits (wordOp2    (-))
    105     primop_rule WordMulOp   = two_lits (wordOp2    (*))
    106     primop_rule WordQuotOp  = two_lits (wordOp2Z   quot)
    107     primop_rule WordRemOp   = two_lits (wordOp2Z   rem)
    108     primop_rule AndOp       = two_lits (wordBitOp2 (.&.))
    109     primop_rule OrOp        = two_lits (wordBitOp2 (.|.))
    110     primop_rule XorOp       = two_lits (wordBitOp2 xor)
    111     primop_rule SllOp       = two_lits (wordShiftOp2 Bits.shiftL)
    112     primop_rule SrlOp       = two_lits (wordShiftOp2 shiftRightLogical)
     140    primop_rule WordAddOp   = rules 2 [ binaryLit (wordOp2 (+))
     141                                      , identity zerow ]
     142    primop_rule WordSubOp   = rules 2 [ binaryLit (wordOp2 (-))
     143                                      , rightIdentity zerow
     144                                      , equalArgs >> return (Lit zerow) ]
     145    primop_rule WordMulOp   = rules 2 [ binaryLit (wordOp2 (*))
     146                                      , identity onew ]
     147    primop_rule WordQuotOp  = rules 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
     148                                      , rightIdentity onew ]
     149    primop_rule WordRemOp   = rules 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
     150                                      , rightIdentity onew ]
     151    primop_rule AndOp       = rules 2 [ binaryLit (wordOp2 (.&.))
     152                                      , zeroElem zerow ]
     153    primop_rule OrOp        = rules 2 [ binaryLit (wordOp2 (.|.))
     154                                      , identity zerow ]
     155    primop_rule XorOp       = rules 2 [ binaryLit (wordOp2 xor)
     156                                      , identity zerow
     157                                      , equalArgs >> return (Lit zerow) ]
     158    primop_rule SllOp       = rules 2 [ binaryLit (wordShiftOp2 Bits.shiftL)
     159                                      , rightIdentity zeroi ]
     160    primop_rule SrlOp       = rules 2 [ binaryLit (wordShiftOp2 shiftRightLogical)
     161                                      , rightIdentity zeroi ]
    113162
    114163    -- coercions
    115     primop_rule Word2IntOp     = one_lit (litCoerce word2IntLit)
    116     primop_rule Int2WordOp     = one_lit (litCoerce int2WordLit)
    117     primop_rule Narrow8IntOp   = one_lit (litCoerce narrow8IntLit)
    118     primop_rule Narrow16IntOp  = one_lit (litCoerce narrow16IntLit)
    119     primop_rule Narrow32IntOp  = one_lit (litCoerce narrow32IntLit)
    120     primop_rule Narrow8WordOp  = one_lit (litCoerce narrow8WordLit)
    121     primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
    122     primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
    123     primop_rule OrdOp          = one_lit (litCoerce char2IntLit)
    124     primop_rule ChrOp          = one_lit (predLitCoerce litFitsInChar int2CharLit)
    125     primop_rule Float2IntOp    = one_lit (litCoerce float2IntLit)
    126     primop_rule Int2FloatOp    = one_lit (litCoerce int2FloatLit)
    127     primop_rule Double2IntOp   = one_lit (litCoerce double2IntLit)
    128     primop_rule Int2DoubleOp   = one_lit (litCoerce int2DoubleLit)
     164    primop_rule Word2IntOp     = rules 1 [ liftLit word2IntLit ]
     165    primop_rule Int2WordOp     = rules 1 [ liftLit int2WordLit ]
     166    primop_rule Narrow8IntOp   = rules 1 [ liftLit narrow8IntLit ]
     167    primop_rule Narrow16IntOp  = rules 1 [ liftLit narrow16IntLit ]
     168    primop_rule Narrow32IntOp  = rules 1 [ liftLit narrow32IntLit ]
     169    primop_rule Narrow8WordOp  = rules 1 [ liftLit narrow8WordLit ]
     170    primop_rule Narrow16WordOp = rules 1 [ liftLit narrow16WordLit ]
     171    primop_rule Narrow32WordOp = rules 1 [ liftLit narrow32WordLit ]
     172    primop_rule OrdOp          = rules 1 [ liftLit char2IntLit ]
     173    primop_rule ChrOp          = rules 1 [ do { [Lit lit] <- getArgs
     174                                              ; guard (litFitsInChar lit)
     175                                              ; liftLit int2CharLit } ]
     176    primop_rule Float2IntOp    = rules 1 [ liftLit float2IntLit ]
     177    primop_rule Int2FloatOp    = rules 1 [ liftLit int2FloatLit ]
     178    primop_rule Double2IntOp   = rules 1 [ liftLit double2IntLit ]
     179    primop_rule Int2DoubleOp   = rules 1 [ liftLit int2DoubleLit ]
    129180    -- SUP: Not sure what the standard says about precision in the following 2 cases
    130     primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
    131     primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
     181    primop_rule Float2DoubleOp = rules 1 [ liftLit float2DoubleLit ]
     182    primop_rule Double2FloatOp = rules 1 [ liftLit double2FloatLit ]
    132183
    133184    -- Float
    134     primop_rule FloatAddOp   = two_lits (floatOp2  (+))
    135     primop_rule FloatSubOp   = two_lits (floatOp2  (-))
    136     primop_rule FloatMulOp   = two_lits (floatOp2  (*))
    137     primop_rule FloatDivOp   = two_lits (floatOp2Z (/))
    138     primop_rule FloatNegOp   = one_lit  negOp
     185    primop_rule FloatAddOp   = rules 2 [ binaryLit (floatOp2 (+))
     186                                       , identity zerof ]
     187    primop_rule FloatSubOp   = rules 2 [ binaryLit (floatOp2 (-))
     188                                       , rightIdentity zerof ]
     189    primop_rule FloatMulOp   = rules 2 [ binaryLit (floatOp2 (*))
     190                                       , identity onef ]
     191                             -- zeroElem zerof doesn't hold because of NaN
     192    primop_rule FloatDivOp   = rules 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
     193                                       , rightIdentity onef ]
     194    primop_rule FloatNegOp   = rules 1 [ unaryLit negOp ]
    139195
    140196    -- Double
    141     primop_rule DoubleAddOp   = two_lits (doubleOp2  (+))
    142     primop_rule DoubleSubOp   = two_lits (doubleOp2  (-))
    143     primop_rule DoubleMulOp   = two_lits (doubleOp2  (*))
    144     primop_rule DoubleDivOp   = two_lits (doubleOp2Z (/))
    145     primop_rule DoubleNegOp   = one_lit  negOp
     197    primop_rule DoubleAddOp   = rules 2 [ binaryLit (doubleOp2 (+))
     198                                        , identity zerod ]
     199    primop_rule DoubleSubOp   = rules 2 [ binaryLit (doubleOp2 (-))
     200                                        , rightIdentity zerod ]
     201    primop_rule DoubleMulOp   = rules 2 [ binaryLit (doubleOp2 (*))
     202                                        , identity oned ]
     203                              -- zeroElem zerod doesn't hold because of NaN
     204    primop_rule DoubleDivOp   = rules 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
     205                                        , rightIdentity oned ]
     206    primop_rule DoubleNegOp   = rules 1 [ unaryLit negOp ]
    146207
    147208    -- Relational operators
    148209    primop_rule IntEqOp    = relop (==) ++ litEq op_name True
    primOpRules op op_name = primop_rule op 
    181242    primop_rule WordEqOp   = relop (==)
    182243    primop_rule WordNeOp   = relop (/=)
    183244
    184     primop_rule SeqOp      = mkBasicRule op_name 4 seqRule
    185     primop_rule SparkOp    = mkBasicRule op_name 4 sparkRule
     245    primop_rule SeqOp      = rules 4 [ seqRule ]
     246    primop_rule SparkOp    = rules 4 [ sparkRule ]
    186247
    187248    primop_rule _          = []
    188249\end{code}
    primOpRules op op_name = primop_rule op 
    193254%*                                                                      *
    194255%************************************************************************
    195256
    196 ToDo: the reason these all return Nothing is because there used to be
    197 the possibility of an argument being a litlit.  Litlits are now gone,
    198 so this could be cleaned up.
    199 
    200257\begin{code}
    201 --------------------------
    202 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
    203 litCoerce fn lit = Just (Lit (fn lit))
    204 
    205 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
    206 predLitCoerce p fn lit
    207    | p lit     = Just (Lit (fn lit))
    208    | otherwise = Nothing
    209 
    210 --------------------------
    211 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
    212 cmpOp cmp l1 l2
    213   = go l1 l2
     258cmpOp :: (forall a . Ord a => a -> a -> Bool)
     259      -> Literal -> Literal -> Maybe CoreExpr
     260cmpOp cmp = go
    214261  where
    215     done res | cmp res   = Just trueVal
    216              | otherwise = Just falseVal
     262    done True  = Just trueVal
     263    done False = Just falseVal
    217264
    218265    -- These compares are at different types
    219     go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
    220     go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
    221     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
    222     go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
    223     go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
    224     go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
    225     go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
     266    go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
     267    go (MachInt i1)    (MachInt i2)    = done (i1 `cmp` i2)
     268    go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `cmp` i2)
     269    go (MachWord i1)   (MachWord i2)   = done (i1 `cmp` i2)
     270    go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
     271    go (MachFloat i1)  (MachFloat i2)  = done (i1 `cmp` i2)
     272    go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
    226273    go _               _               = Nothing
    227274
    228275--------------------------
    negOp (MachInt i) = intResult (-i) 
    236283negOp _                = Nothing
    237284
    238285--------------------------
    239 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
    240 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
     286intOp2 :: (Integral a, Integral b)
     287       => (a -> b -> Integer)
     288       -> Literal -> Literal -> Maybe CoreExpr
     289intOp2 op (MachInt i1) (MachInt i2) = intResult (fromInteger i1 `op` fromInteger i2)
    241290intOp2 _  _            _            = Nothing  -- Could find LitLit
    242291
    243 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
    244 -- Like intOp2, but Nothing if i2=0
    245 intOp2Z op (MachInt i1) (MachInt i2)
    246   | i2 /= 0 = intResult (i1 `op` i2)
    247 intOp2Z _ _ _ = Nothing  -- LitLit or zero dividend
    248 
    249 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
    250 -- Shifts take an Int; hence second arg of op is Int
    251 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
    252 intShiftOp2 _  _            _            = Nothing
    253 
    254292shiftRightLogical :: Integer -> Int -> Integer
    255293-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
    256294-- Do this by converting to Word and back.  Obviously this won't work for big
    shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word) 
    259297
    260298
    261299--------------------------
    262 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
    263 wordOp2 op (MachWord w1) (MachWord w2)
    264   = wordResult (w1 `op` w2)
     300wordOp2 :: (Integral a, Integral b)
     301        => (a -> b -> Integer)
     302        -> Literal -> Literal -> Maybe CoreExpr
     303wordOp2 op (MachWord w1) (MachWord w2) = wordResult (fromInteger w1 `op` fromInteger w2)
    265304wordOp2 _ _ _ = Nothing  -- Could find LitLit
    266305
    267 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
    268 wordOp2Z op (MachWord w1) (MachWord w2)
    269   | w2 /= 0 = wordResult (w1 `op` w2)
    270 wordOp2Z _ _ _ = Nothing  -- LitLit or zero dividend
    271 
    272 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
    273            -> Maybe CoreExpr
    274 wordBitOp2 op (MachWord w1) (MachWord w2)
    275   = wordResult (w1 `op` w2)
    276 wordBitOp2 _ _ _ = Nothing  -- Could find LitLit
    277 
    278306wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
    279307-- Shifts take an Int; hence second arg of op is Int
    280308wordShiftOp2 op (MachWord x) (MachInt n)
    floatOp2 op (MachFloat f1) (MachFloat f2) 
    289317  = Just (mkFloatVal (f1 `op` f2))
    290318floatOp2 _ _ _ = Nothing
    291319
    292 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
    293           -> Maybe (Expr CoreBndr)
    294 floatOp2Z op (MachFloat f1) (MachFloat f2)
    295   | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
    296   && f2 /= 0             -- avoid NaN and Infinity/-Infinity
    297   = Just (mkFloatVal (f1 `op` f2))
    298 floatOp2Z _ _ _ = Nothing
    299 
    300320--------------------------
    301321doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
    302322          -> Maybe (Expr CoreBndr)
    doubleOp2 op (MachDouble f1) (MachDouble f2) 
    304324  = Just (mkDoubleVal (f1 `op` f2))
    305325doubleOp2 _ _ _ = Nothing
    306326
    307 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
    308            -> Maybe (Expr CoreBndr)
    309 doubleOp2Z op (MachDouble f1) (MachDouble f2)
    310   | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
    311   && f2 /= 0             -- avoid NaN and Infinity/-Infinity
    312   = Just (mkDoubleVal (f1 `op` f2))
    313   -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
    314   -- zero, but we might want to preserve the negative zero here which
    315   -- is representable in Float/Double but not in (normalised)
    316   -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
    317 doubleOp2Z _ _ _ = Nothing
    318 
    319 
    320327--------------------------
    321328-- This stuff turns
    322329--      n ==# 3#
    wordResult result 
    431438%************************************************************************
    432439
    433440\begin{code}
    434 mkBasicRule :: Name -> Int
    435             -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
    436             -> [CoreRule]
     441mkBasicRule :: Name -> Int -> RuleM CoreExpr -> [CoreRule]
    437442-- Gives the Rule the same name as the primop itself
    438 mkBasicRule op_name n_args rule_fn
     443mkBasicRule op_name n_args rm
    439444  = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
    440445                   ru_fn = op_name,
    441                    ru_nargs = n_args, ru_try = \_ -> rule_fn }]
    442 
    443 oneLit :: Name -> (Literal -> Maybe CoreExpr)
    444        -> [CoreRule]
    445 oneLit op_name test
    446   = mkBasicRule op_name 1 rule_fn
    447   where
    448     rule_fn _ [Lit l1] = test (convFloating l1)
    449     rule_fn _ _        = Nothing
    450 
    451 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
    452         -> [CoreRule]
    453 twoLits op_name test
    454   = mkBasicRule op_name 2 rule_fn
    455   where
    456     rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
    457     rule_fn _ _                = Nothing
     446                   ru_nargs = n_args,
     447                   ru_try = \_ -> runRuleM rm }]
     448
     449newtype RuleM r = RuleM
     450  { runRuleM :: IdUnfoldingFun -> [CoreExpr] -> Maybe r }
     451
     452instance Monad RuleM where
     453  return x = RuleM $ \_ _ -> Just x
     454  RuleM f >>= g = RuleM $ \iu e -> case f iu e of
     455    Nothing -> Nothing
     456    Just r -> runRuleM (g r) iu e
     457  fail _ = mzero
     458
     459instance MonadPlus RuleM where
     460  mzero = RuleM $ \_ _ -> Nothing
     461  mplus (RuleM f1) (RuleM f2) = RuleM $ \iu args ->
     462    f1 iu args `mplus` f2 iu args
     463
     464liftMaybe :: Maybe a -> RuleM a
     465liftMaybe Nothing = mzero
     466liftMaybe (Just x) = return x
     467
     468liftLit :: (Literal -> Literal) -> RuleM CoreExpr
     469liftLit f = do
     470  [Lit lit] <- getArgs
     471  return $ Lit (f lit)
     472
     473getArgs :: RuleM [CoreExpr]
     474getArgs = RuleM $ \_ args -> Just args
     475
     476getIdUnfoldingFun :: RuleM IdUnfoldingFun
     477getIdUnfoldingFun = RuleM $ \iu _ -> Just iu
     478
     479getLiteral :: Int -> RuleM Literal
     480getLiteral n = RuleM $ \_ exprs -> case drop n exprs of
     481  (Lit l:_) -> Just l
     482  _ -> Nothing
     483
     484unaryLit :: (Literal -> Maybe CoreExpr) -> RuleM CoreExpr
     485unaryLit op = do
     486  [Lit l] <- getArgs
     487  liftMaybe $ op (convFloating l)
     488
     489binaryLit :: (Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
     490binaryLit op = do
     491  [Lit l1, Lit l2] <- getArgs
     492  liftMaybe $ convFloating l1 `op` convFloating l2
     493
     494leftIdentity :: Literal -> RuleM CoreExpr
     495leftIdentity id_lit = do
     496  [Lit l1, e2] <- getArgs
     497  guard $ l1 == id_lit
     498  return e2
     499
     500rightIdentity :: Literal -> RuleM CoreExpr
     501rightIdentity id_lit = do
     502  [e1, Lit l2] <- getArgs
     503  guard $ l2 == id_lit
     504  return e1
     505
     506leftZero :: Literal -> RuleM CoreExpr
     507leftZero zero = do
     508  [Lit l1, _] <- getArgs
     509  guard $ l1 == zero
     510  return $ Lit zero
     511
     512rightZero :: Literal -> RuleM CoreExpr
     513rightZero zero = do
     514  [_, Lit l2] <- getArgs
     515  guard $ l2 == zero
     516  return $ Lit zero
     517
     518equalArgs :: RuleM ()
     519equalArgs = do
     520  [e1, e2] <- getArgs
     521  guard $ e1 `cheapEqExpr` e2
     522
     523nonZeroLit :: Int -> RuleM ()
     524nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
    458525
    459526-- When excess precision is not requested, cut down the precision of the
    460527-- Rational value to that of Float/Double. We confuse host architecture
    convFloating (MachDouble d) | not opt_SimplExcessPrecision = 
    466533   MachDouble (toRational ((fromRational d) :: Double))
    467534convFloating l = l
    468535
     536guardFloatDiv :: RuleM ()
     537guardFloatDiv = do
     538  [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
     539  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
     540       && f2 /= 0            -- avoid NaN and Infinity/-Infinity
     541
     542guardDoubleDiv :: RuleM ()
     543guardDoubleDiv = do
     544  [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
     545  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
     546       && d2 /= 0            -- avoid NaN and Infinity/-Infinity
     547-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
     548-- zero, but we might want to preserve the negative zero here which
     549-- is representable in Float/Double but not in (normalised)
     550-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
     551
    469552trueVal, falseVal :: Expr CoreBndr
    470553trueVal       = Var trueDataConId
    471554falseVal      = Var falseDataConId
    rewrite rule rewrites a bad instance of tagToEnum# to an error call, 
    514597and emits a warning.
    515598
    516599\begin{code}
    517 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
     600tagToEnumRule :: RuleM CoreExpr
    518601-- If     data T a = A | B | C
    519602-- then   tag2Enum# (T ty) 2# -->  B ty
    520 tagToEnumRule _ [Type ty, Lit (MachInt i)]
    521   | Just (tycon, tc_args) <- splitTyConApp_maybe ty
    522   , isEnumerationTyCon tycon
    523   = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
    524         []        -> Nothing  -- Abstract type
    525         (dc:rest) -> ASSERT( null rest )
    526                      Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
    527   | otherwise  -- See Note [tagToEnum#]
    528   = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
    529     Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
    530   where
    531     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
    532     tag = fromInteger i
    533 
    534 tagToEnumRule _ _ = Nothing
     603tagToEnumRule = do
     604  [Type ty, Lit (MachInt i)] <- getArgs
     605  case splitTyConApp_maybe ty of
     606    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
     607      let tag = fromInteger i
     608          correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
     609      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
     610      ASSERT (null rest) return ()
     611      return $ mkTyApps (Var (dataConWorkId dc)) tc_args
     612
     613    -- See Note [tagToEnum#]
     614    _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
     615         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
    535616\end{code}
    536617
    537618
    For dataToTag#, we can reduce if either 
    541622        (b) the argument is a variable whose unfolding is a known constructor
    542623
    543624\begin{code}
    544 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
    545 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
    546   | tag_to_enum `hasKey` tagToEnumKey
    547   , ty1 `eqType` ty2
    548   = Just tag  -- dataToTag (tagToEnum x)   ==>   x
    549 
    550 dataToTagRule id_unf [_, val_arg]
    551   | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
    552   = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
    553     Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
    554 
    555 dataToTagRule _ _ = Nothing
     625dataToTagRule :: RuleM CoreExpr
     626dataToTagRule = a `mplus` b
     627  where
     628    a = do
     629      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
     630      guard $ tag_to_enum `hasKey` tagToEnumKey
     631      guard $ ty1 `eqType` ty2
     632      return tag -- dataToTag (tagToEnum x)   ==>   x
     633    b = do
     634      [_, val_arg] <- getArgs
     635      id_unf <- getIdUnfoldingFun
     636      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg
     637      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
     638      return $ mkIntVal (toInteger (dataConTag dc - fIRST_TAG))
    556639\end{code}
    557640
    558641%************************************************************************
    dataToTagRule _ _ = Nothing 
    563646
    564647\begin{code}
    565648-- seq# :: forall a s . a -> State# s -> (# State# s, a #)
    566 seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
    567 seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a
    568    = Just (mkConApp (tupleCon UnboxedTuple 2)
    569                     [Type (mkStatePrimTy ty_s), ty_a, s, a])
    570 seqRule _ _ = Nothing
     649seqRule :: RuleM CoreExpr
     650seqRule = do
     651  [ty_a, Type ty_s, a, s] <- getArgs
     652  guard $ exprIsHNF a
     653  return $ mkConApp (tupleCon UnboxedTuple 2)
     654    [Type (mkStatePrimTy ty_s), ty_a, s, a]
    571655
    572656-- spark# :: forall a s . a -> State# s -> (# State# s, a #)
    573 sparkRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
     657sparkRule :: RuleM CoreExpr
    574658sparkRule = seqRule -- reduce on HNF, just the same
    575659  -- XXX perhaps we shouldn't do this, because a spark eliminated by
    576660  -- this rule won't be counted as a dud at runtime?