Ticket #7014: 7014.patch

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

    From 47c99d5b2f80bdfc1fd05260562352aa8fc56071 Mon Sep 17 00:00:00 2001
    From: Paolo Capriotti <p.capriotti@gmail.com>
    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?