compiler/prelude/PrelRules.hs

   1 {-
   2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3
   4 \section[ConFold]{Constant Folder}
   5
   6 Conceptually, constant folding should be parameterized with the kind
   7 of target machine to get identical behaviour during compilation time
   8 and runtime. We cheat a little bit here...
   9
  10 ToDo:
  11    check boundaries before folding, e.g. we can fold the Float addition
  12    (i1 + i2) only if it results in a valid Float.
  13 -}
  14
  15 {-# LANGUAGE CPP, RankNTypes #-}
  16 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
  17
  18 module PrelRules ( primOpRules, builtinRules ) where
  19
  20 #include "HsVersions.h"
  21 #include "../includes/MachDeps.h"
  22
  23 import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
  24
  25 import CoreSyn
  26 import MkCore
  27 import Id
  28 import Literal
  29 import CoreSubst   ( exprIsLiteral_maybe )
  30 import PrimOp      ( PrimOp(..), tagToEnumKey )
  31 import TysWiredIn
  32 import TysPrim
  33 import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
  34 import DataCon     ( dataConTag, dataConTyCon, dataConWorkId )
  35 import CoreUtils   ( cheapEqExpr, exprIsHNF )
  36 import CoreUnfold  ( exprIsConApp_maybe )
  37 import Type
  38 import OccName     ( occNameFS )
  39 import PrelNames
  40 import Maybes      ( orElse )
  41 import Name        ( Name, nameOccName )
  42 import Outputable
  43 import FastString
  44 import BasicTypes
  45 import DynFlags
  46 import Platform
  47 import Util
  48 import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
  49
  50 import Control.Applicative ( Alternative(..) )
  51
  52 import Control.Monad
  53 #if __GLASGOW_HASKELL__ > 710
  54 import qualified Control.Monad.Fail as MonadFail
  55 #endif
  56 import Data.Bits as Bits
  57 import qualified Data.ByteString as BS
  58 import Data.Int
  59 import Data.Ratio
  60 import Data.Word
  61
  62 {-
  63 Note [Constant folding]
  64 ~~~~~~~~~~~~~~~~~~~~~~~
  65 primOpRules generates a rewrite rule for each primop
  66 These rules do what is often called "constant folding"
  67 E.g. the rules for +# might say
  68         4 +# 5 = 9
  69 Well, of course you'd need a lot of rules if you did it
  70 like that, so we use a BuiltinRule instead, so that we
  71 can match in any two literal values.  So the rule is really
  72 more like
  73         (Lit x) +# (Lit y) = Lit (x+#y)
  74 where the (+#) on the rhs is done at compile time
  75
  76 That is why these rules are built in here.
  77 -}
  78
  79 primOpRules :: Name -> PrimOp -> Maybe CoreRule
  80     -- ToDo: something for integer-shift ops?
  81     --       NotOp
  82 primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
  83 primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
  84
  85 -- Int operations
  86 primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
  87                                                , identityDynFlags zeroi ]
  88 primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
  89                                                , rightIdentityDynFlags zeroi
  90                                                , equalArgs >> retLit zeroi ]
  91 primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
  92                                                , zeroElem zeroi
  93                                                , identityDynFlags onei ]
  94 primOpRules nm IntQuotOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
  95                                                , leftZero zeroi
  96                                                , rightIdentityDynFlags onei
  97                                                , equalArgs >> retLit onei ]
  98 primOpRules nm IntRemOp    = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
  99                                                , leftZero zeroi
 100                                                , do l <- getLiteral 1
 101                                                     dflags <- getDynFlags
 102                                                     guard (l == onei dflags)
 103                                                     retLit zeroi
 104                                                , equalArgs >> retLit zeroi
 105                                                , equalArgs >> retLit zeroi ]
 106 primOpRules nm AndIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
 107                                                , idempotent
 108                                                , zeroElem zeroi ]
 109 primOpRules nm OrIOp       = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
 110                                                , idempotent
 111                                                , identityDynFlags zeroi ]
 112 primOpRules nm XorIOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
 113                                                , identityDynFlags zeroi
 114                                                , equalArgs >> retLit zeroi ]
 115 primOpRules nm NotIOp      = mkPrimOpRule nm 1 [ unaryLit complementOp
 116                                                , inversePrimOp NotIOp ]
 117 primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp
 118                                                , inversePrimOp IntNegOp ]
 119 primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
 120                                                , rightIdentityDynFlags zeroi ]
 121 primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
 122                                                , rightIdentityDynFlags zeroi ]
 123 primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)
 124                                                , rightIdentityDynFlags zeroi ]
 125
 126 -- Word operations
 127 primOpRules nm WordAddOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
 128                                                , identityDynFlags zerow ]
 129 primOpRules nm WordSubOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
 130                                                , rightIdentityDynFlags zerow
 131                                                , equalArgs >> retLit zerow ]
 132 primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
 133                                                , identityDynFlags onew ]
 134 primOpRules nm WordQuotOp  = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
 135                                                , rightIdentityDynFlags onew ]
 136 primOpRules nm WordRemOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
 137                                                , rightIdentityDynFlags onew ]
 138 primOpRules nm AndOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
 139                                                , idempotent
 140                                                , zeroElem zerow ]
 141 primOpRules nm OrOp        = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
 142                                                , idempotent
 143                                                , identityDynFlags zerow ]
 144 primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
 145                                                , identityDynFlags zerow
 146                                                , equalArgs >> retLit zerow ]
 147 primOpRules nm NotOp       = mkPrimOpRule nm 1 [ unaryLit complementOp
 148                                                , inversePrimOp NotOp ]
 149 primOpRules nm SllOp       = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]
 150 primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]
 151
 152 -- coercions
 153 primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
 154                                                   , inversePrimOp Int2WordOp ]
 155 primOpRules nm Int2WordOp     = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
 156                                                   , inversePrimOp Word2IntOp ]
 157 primOpRules nm Narrow8IntOp   = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
 158                                                   , subsumedByPrimOp Narrow8IntOp
 159                                                   , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
 160                                                   , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
 161 primOpRules nm Narrow16IntOp  = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
 162                                                   , subsumedByPrimOp Narrow8IntOp
 163                                                   , subsumedByPrimOp Narrow16IntOp
 164                                                   , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
 165 primOpRules nm Narrow32IntOp  = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
 166                                                   , subsumedByPrimOp Narrow8IntOp
 167                                                   , subsumedByPrimOp Narrow16IntOp
 168                                                   , subsumedByPrimOp Narrow32IntOp
 169                                                   , removeOp32 ]
 170 primOpRules nm Narrow8WordOp  = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
 171                                                   , subsumedByPrimOp Narrow8WordOp
 172                                                   , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
 173                                                   , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
 174 primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
 175                                                   , subsumedByPrimOp Narrow8WordOp
 176                                                   , subsumedByPrimOp Narrow16WordOp
 177                                                   , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
 178 primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
 179                                                   , subsumedByPrimOp Narrow8WordOp
 180                                                   , subsumedByPrimOp Narrow16WordOp
 181                                                   , subsumedByPrimOp Narrow32WordOp
 182                                                   , removeOp32 ]
 183 primOpRules nm OrdOp          = mkPrimOpRule nm 1 [ liftLit char2IntLit
 184                                                   , inversePrimOp ChrOp ]
 185 primOpRules nm ChrOp          = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
 186                                                        guard (litFitsInChar lit)
 187                                                        liftLit int2CharLit
 188                                                   , inversePrimOp OrdOp ]
 189 primOpRules nm Float2IntOp    = mkPrimOpRule nm 1 [ liftLit float2IntLit ]
 190 primOpRules nm Int2FloatOp    = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]
 191 primOpRules nm Double2IntOp   = mkPrimOpRule nm 1 [ liftLit double2IntLit ]
 192 primOpRules nm Int2DoubleOp   = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]
 193 -- SUP: Not sure what the standard says about precision in the following 2 cases
 194 primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]
 195 primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]
 196
 197 -- Float
 198 primOpRules nm FloatAddOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
 199                                                 , identity zerof ]
 200 primOpRules nm FloatSubOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
 201                                                 , rightIdentity zerof ]
 202 primOpRules nm FloatMulOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
 203                                                 , identity onef
 204                                                 , strengthReduction twof FloatAddOp  ]
 205                          -- zeroElem zerof doesn't hold because of NaN
 206 primOpRules nm FloatDivOp   = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
 207                                                 , rightIdentity onef ]
 208 primOpRules nm FloatNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
 209                                                 , inversePrimOp FloatNegOp ]
 210
 211 -- Double
 212 primOpRules nm DoubleAddOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
 213                                                  , identity zerod ]
 214 primOpRules nm DoubleSubOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
 215                                                  , rightIdentity zerod ]
 216 primOpRules nm DoubleMulOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
 217                                                  , identity oned
 218                                                  , strengthReduction twod DoubleAddOp  ]
 219                           -- zeroElem zerod doesn't hold because of NaN
 220 primOpRules nm DoubleDivOp   = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
 221                                                  , rightIdentity oned ]
 222 primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
 223                                                  , inversePrimOp DoubleNegOp ]
 224
 225 -- Relational operators
 226
 227 primOpRules nm IntEqOp    = mkRelOpRule nm (==) [ litEq True ]
 228 primOpRules nm IntNeOp    = mkRelOpRule nm (/=) [ litEq False ]
 229 primOpRules nm CharEqOp   = mkRelOpRule nm (==) [ litEq True ]
 230 primOpRules nm CharNeOp   = mkRelOpRule nm (/=) [ litEq False ]
 231
 232 primOpRules nm IntGtOp    = mkRelOpRule nm (>)  [ boundsCmp Gt ]
 233 primOpRules nm IntGeOp    = mkRelOpRule nm (>=) [ boundsCmp Ge ]
 234 primOpRules nm IntLeOp    = mkRelOpRule nm (<=) [ boundsCmp Le ]
 235 primOpRules nm IntLtOp    = mkRelOpRule nm (<)  [ boundsCmp Lt ]
 236
 237 primOpRules nm CharGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
 238 primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
 239 primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
 240 primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
 241
 242 primOpRules nm FloatGtOp  = mkFloatingRelOpRule nm (>)
 243 primOpRules nm FloatGeOp  = mkFloatingRelOpRule nm (>=)
 244 primOpRules nm FloatLeOp  = mkFloatingRelOpRule nm (<=)
 245 primOpRules nm FloatLtOp  = mkFloatingRelOpRule nm (<)
 246 primOpRules nm FloatEqOp  = mkFloatingRelOpRule nm (==)
 247 primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=)
 248
 249 primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)
 250 primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)
 251 primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)
 252 primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)
 253 primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)
 254 primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)
 255
 256 primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
 257 primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
 258 primOpRules nm WordLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
 259 primOpRules nm WordLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
 260 primOpRules nm WordEqOp   = mkRelOpRule nm (==) [ litEq True ]
 261 primOpRules nm WordNeOp   = mkRelOpRule nm (/=) [ litEq False ]
 262
 263 primOpRules nm AddrAddOp  = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]
 264
 265 primOpRules nm SeqOp      = mkPrimOpRule nm 4 [ seqRule ]
 266 primOpRules nm SparkOp    = mkPrimOpRule nm 4 [ sparkRule ]
 267
 268 primOpRules _  _          = Nothing
 269
 270 {-
 271 ************************************************************************
 272 *                                                                      *
 273 \subsection{Doing the business}
 274 *                                                                      *
 275 ************************************************************************
 276 -}
 277
 278 -- useful shorthands
 279 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
 280 mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
 281
 282 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
 283             -> [RuleM CoreExpr] -> Maybe CoreRule
 284 mkRelOpRule nm cmp extra
 285   = mkPrimOpRule nm 2 $
 286     binaryCmpLit cmp : equal_rule : extra
 287   where
 288         -- x `cmp` x does not depend on x, so
 289         -- compute it for the arbitrary value 'True'
 290         -- and use that result
 291     equal_rule = do { equalArgs
 292                     ; dflags <- getDynFlags
 293                     ; return (if cmp True True
 294                               then trueValInt  dflags
 295                               else falseValInt dflags) }
 296
 297 {- Note [Rules for floating-point comparisons]
 298 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 299 We need different rules for floating-point values because for floats
 300 it is not true that x = x (for NaNs); so we do not want the equal_rule
 301 rule that mkRelOpRule uses.
 302
 303 Note also that, in the case of equality/inequality, we do /not/
 304 want to switch to a case-expression.  For example, we do not want
 305 to convert
 306    case (eqFloat# x 3.8#) of
 307      True -> this
 308      False -> that
 309 to
 310   case x of
 311     3.8#::Float# -> this
 312     _            -> that
 313 See Trac #9238.  Reason: comparing floating-point values for equality
 314 delicate, and we don't want to implement that delicacy in the code for
 315 case expressions.  So we make it an invariant of Core that a case
 316 expression never scrutinises a Float# or Double#.
 317
 318 This transformation is what the litEq rule does;
 319 see Note [The litEq rule: converting equality to case].
 320 So we /refrain/ from using litEq for mkFloatingRelOpRule.
 321 -}
 322
 323 mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
 324                     -> Maybe CoreRule
 325 -- See Note [Rules for floating-point comparisons]
 326 mkFloatingRelOpRule nm cmp
 327   = mkPrimOpRule nm 2 [binaryCmpLit cmp]
 328
 329 -- common constants
 330 zeroi, onei, zerow, onew :: DynFlags -> Literal
 331 zeroi dflags = mkMachInt  dflags 0
 332 onei  dflags = mkMachInt  dflags 1
 333 zerow dflags = mkMachWord dflags 0
 334 onew  dflags = mkMachWord dflags 1
 335
 336 zerof, onef, twof, zerod, oned, twod :: Literal
 337 zerof = mkMachFloat 0.0
 338 onef  = mkMachFloat 1.0
 339 twof  = mkMachFloat 2.0
 340 zerod = mkMachDouble 0.0
 341 oned  = mkMachDouble 1.0
 342 twod  = mkMachDouble 2.0
 343
 344 cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
 345       -> Literal -> Literal -> Maybe CoreExpr
 346 cmpOp dflags cmp = go
 347   where
 348     done True  = Just $ trueValInt  dflags
 349     done False = Just $ falseValInt dflags
 350
 351     -- These compares are at different types
 352     go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
 353     go (MachInt i1)    (MachInt i2)    = done (i1 `cmp` i2)
 354     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `cmp` i2)
 355     go (MachWord i1)   (MachWord i2)   = done (i1 `cmp` i2)
 356     go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
 357     go (MachFloat i1)  (MachFloat i2)  = done (i1 `cmp` i2)
 358     go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
 359     go _               _               = Nothing
 360
 361 --------------------------
 362
 363 negOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Negate
 364 negOp _      (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
 365 negOp dflags (MachFloat f)    = Just (mkFloatVal dflags (-f))
 366 negOp _      (MachDouble 0.0) = Nothing
 367 negOp dflags (MachDouble d)   = Just (mkDoubleVal dflags (-d))
 368 negOp dflags (MachInt i)      = intResult dflags (-i)
 369 negOp _      _                = Nothing
 370
 371 complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement
 372 complementOp dflags (MachWord i) = wordResult dflags (complement i)
 373 complementOp dflags (MachInt i)  = intResult  dflags (complement i)
 374 complementOp _      _            = Nothing
 375
 376 --------------------------
 377 intOp2 :: (Integral a, Integral b)
 378        => (a -> b -> Integer)
 379        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
 380 intOp2 = intOp2' . const
 381
 382 intOp2' :: (Integral a, Integral b)
 383         => (DynFlags -> a -> b -> Integer)
 384         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
 385 intOp2' op dflags (MachInt i1) (MachInt i2) =
 386   let o = op dflags
 387   in  intResult dflags (fromInteger i1 `o` fromInteger i2)
 388 intOp2' _  _      _            _            = Nothing  -- Could find LitLit
 389
 390 shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
 391 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
 392 -- Do this by converting to Word and back.  Obviously this won't work for big
 393 -- values, but its ok as we use it here
 394 shiftRightLogical dflags x n
 395   | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32)
 396   | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64)
 397   | otherwise = panic "shiftRightLogical: unsupported word size"
 398
 399 --------------------------
 400 retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
 401 retLit l = do dflags <- getDynFlags
 402               return $ Lit $ l dflags
 403
 404 wordOp2 :: (Integral a, Integral b)
 405         => (a -> b -> Integer)
 406         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
 407 wordOp2 op dflags (MachWord w1) (MachWord w2)
 408     = wordResult dflags (fromInteger w1 `op` fromInteger w2)
 409 wordOp2 _ _ _ _ = Nothing  -- Could find LitLit
 410
 411 wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
 412                  -- Shifts take an Int; hence third arg of op is Int
 413 -- See Note [Guarding against silly shifts]
 414 wordShiftRule shift_op
 415   = do { dflags <- getDynFlags
 416        ; [e1, Lit (MachInt shift_len)] <- getArgs
 417        ; case e1 of
 418            _ | shift_len == 0
 419              -> return e1
 420              | shift_len < 0 || wordSizeInBits dflags < shift_len
 421              -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
 422                                         ("Bad shift length" ++ show shift_len))
 423            Lit (MachWord x)
 424              -> let op = shift_op dflags
 425                 in  liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
 426                     -- Do the shift at type Integer, but shift length is Int
 427            _ -> mzero }
 428
 429 wordSizeInBits :: DynFlags -> Integer
 430 wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
 431
 432 --------------------------
 433 floatOp2 :: (Rational -> Rational -> Rational)
 434          -> DynFlags -> Literal -> Literal
 435          -> Maybe (Expr CoreBndr)
 436 floatOp2 op dflags (MachFloat f1) (MachFloat f2)
 437   = Just (mkFloatVal dflags (f1 `op` f2))
 438 floatOp2 _ _ _ _ = Nothing
 439
 440 --------------------------
 441 doubleOp2 :: (Rational -> Rational -> Rational)
 442           -> DynFlags -> Literal -> Literal
 443           -> Maybe (Expr CoreBndr)
 444 doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
 445   = Just (mkDoubleVal dflags (f1 `op` f2))
 446 doubleOp2 _ _ _ _ = Nothing
 447
 448 --------------------------
 449 {- Note [The litEq rule: converting equality to case]
 450 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 451 This stuff turns
 452      n ==# 3#
 453 into
 454      case n of
 455        3# -> True
 456        m  -> False
 457
 458 This is a Good Thing, because it allows case-of case things
 459 to happen, and case-default absorption to happen.  For
 460 example:
 461
 462      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 463 will transform to
 464      case n of
 465        3# -> e1
 466        4# -> e1
 467        m  -> e2
 468 (modulo the usual precautions to avoid duplicating e1)
 469 -}
 470
 471 litEq :: Bool  -- True <=> equality, False <=> inequality
 472       -> RuleM CoreExpr
 473 litEq is_eq = msum
 474   [ do [Lit lit, expr] <- getArgs
 475        dflags <- getDynFlags
 476        do_lit_eq dflags lit expr
 477   , do [expr, Lit lit] <- getArgs
 478        dflags <- getDynFlags
 479        do_lit_eq dflags lit expr ]
 480   where
 481     do_lit_eq dflags lit expr = do
 482       guard (not (litIsLifted lit))
 483       return (mkWildCase expr (literalType lit) intPrimTy
 484                     [(DEFAULT,    [], val_if_neq),
 485                      (LitAlt lit, [], val_if_eq)])
 486       where
 487         val_if_eq  | is_eq     = trueValInt  dflags
 488                    | otherwise = falseValInt dflags
 489         val_if_neq | is_eq     = falseValInt dflags
 490                    | otherwise = trueValInt  dflags
 491
 492
 493 -- | Check if there is comparison with minBound or maxBound, that is
 494 -- always true or false. For instance, an Int cannot be smaller than its
 495 -- minBound, so we can replace such comparison with False.
 496 boundsCmp :: Comparison -> RuleM CoreExpr
 497 boundsCmp op = do
 498   dflags <- getDynFlags
 499   [a, b] <- getArgs
 500   liftMaybe $ mkRuleFn dflags op a b
 501
 502 data Comparison = Gt | Ge | Lt | Le
 503
 504 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
 505 mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
 506 mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt  dflags
 507 mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt  dflags
 508 mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
 509 mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt  dflags
 510 mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
 511 mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
 512 mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt  dflags
 513 mkRuleFn _ _ _ _                                       = Nothing
 514
 515 isMinBound :: DynFlags -> Literal -> Bool
 516 isMinBound _      (MachChar c)   = c == minBound
 517 isMinBound dflags (MachInt i)    = i == tARGET_MIN_INT dflags
 518 isMinBound _      (MachInt64 i)  = i == toInteger (minBound :: Int64)
 519 isMinBound _      (MachWord i)   = i == 0
 520 isMinBound _      (MachWord64 i) = i == 0
 521 isMinBound _      _              = False
 522
 523 isMaxBound :: DynFlags -> Literal -> Bool
 524 isMaxBound _      (MachChar c)   = c == maxBound
 525 isMaxBound dflags (MachInt i)    = i == tARGET_MAX_INT dflags
 526 isMaxBound _      (MachInt64 i)  = i == toInteger (maxBound :: Int64)
 527 isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
 528 isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)
 529 isMaxBound _      _              = False
 530
 531
 532 -- Note that we *don't* warn the user about overflow. It's not done at
 533 -- runtime either, and compilation of completely harmless things like
 534 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 535 -- would yield a warning. Instead we simply squash the value into the
 536 -- *target* Int/Word range.
 537 intResult :: DynFlags -> Integer -> Maybe CoreExpr
 538 intResult dflags result = Just (mkIntVal dflags result')
 539     where result' = case platformWordSize (targetPlatform dflags) of
 540                     4 -> toInteger (fromInteger result :: Int32)
 541                     8 -> toInteger (fromInteger result :: Int64)
 542                     w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
 543
 544 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
 545 wordResult dflags result = Just (mkWordVal dflags result')
 546     where result' = case platformWordSize (targetPlatform dflags) of
 547                     4 -> toInteger (fromInteger result :: Word32)
 548                     8 -> toInteger (fromInteger result :: Word64)
 549                     w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
 550
 551 inversePrimOp :: PrimOp -> RuleM CoreExpr
 552 inversePrimOp primop = do
 553   [Var primop_id `App` e] <- getArgs
 554   matchPrimOpId primop primop_id
 555   return e
 556
 557 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
 558 this `subsumesPrimOp` that = do
 559   [Var primop_id `App` e] <- getArgs
 560   matchPrimOpId that primop_id
 561   return (Var (mkPrimOpId this) `App` e)
 562
 563 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
 564 subsumedByPrimOp primop = do
 565   [e@(Var primop_id `App` _)] <- getArgs
 566   matchPrimOpId primop primop_id
 567   return e
 568
 569 idempotent :: RuleM CoreExpr
 570 idempotent = do [e1, e2] <- getArgs
 571                 guard $ cheapEqExpr e1 e2
 572                 return e1
 573
 574 {-
 575 Note [Guarding against silly shifts]
 576 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 577 Consider this code:
 578
 579   import Data.Bits( (.|.), shiftL )
 580   chunkToBitmap :: [Bool] -> Word32
 581   chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
 582
 583 This optimises to:
 584 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
 585     case w1_sCT of _ {
 586       [] -> 0##;
 587       : x_aAW xs_aAX ->
 588         case x_aAW of _ {
 589           GHC.Types.False ->
 590             case w_sCS of wild2_Xh {
 591               __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
 592               9223372036854775807 -> 0## };
 593           GHC.Types.True ->
 594             case GHC.Prim.>=# w_sCS 64 of _ {
 595               GHC.Types.False ->
 596                 case w_sCS of wild3_Xh {
 597                   __DEFAULT ->
 598                     case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
 599                       GHC.Prim.or# (GHC.Prim.narrow32Word#
 600                                       (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
 601                                    ww_sCW
 602                      };
 603                   9223372036854775807 ->
 604                     GHC.Prim.narrow32Word#
 605 !!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
 606                 };
 607               GHC.Types.True ->
 608                 case w_sCS of wild3_Xh {
 609                   __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
 610                   9223372036854775807 -> 0##
 611                 } } } }
 612
 613 Note the massive shift on line "!!!!".  It can't happen, because we've checked
 614 that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!
 615 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
 616 can't constant fold it, but if it gets to the assember we get
 617      Error: operand type mismatch for `shl'
 618
 619 So the best thing to do is to rewrite the shift with a call to error,
 620 when the second arg is stupid.
 621
 622 ************************************************************************
 623 *                                                                      *
 624 \subsection{Vaguely generic functions}
 625 *                                                                      *
 626 ************************************************************************
 627 -}
 628
 629 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
 630 -- Gives the Rule the same name as the primop itself
 631 mkBasicRule op_name n_args rm
 632   = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
 633                   ru_fn = op_name,
 634                   ru_nargs = n_args,
 635                   ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
 636
 637 newtype RuleM r = RuleM
 638   { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
 639
 640 instance Functor RuleM where
 641     fmap = liftM
 642
 643 instance Applicative RuleM where
 644     pure x = RuleM $ \_ _ _ -> Just x
 645     (<*>) = ap
 646
 647 instance Monad RuleM where
 648   RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
 649     Nothing -> Nothing
 650     Just r -> runRuleM (g r) dflags iu e
 651   fail _ = mzero
 652
 653 #if __GLASGOW_HASKELL__ > 710
 654 instance MonadFail.MonadFail RuleM where
 655     fail _ = mzero
 656 #endif
 657
 658 instance Alternative RuleM where
 659   empty = RuleM $ \_ _ _ -> Nothing
 660   RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
 661     f1 dflags iu args <|> f2 dflags iu args
 662
 663 instance MonadPlus RuleM
 664
 665 instance HasDynFlags RuleM where
 666     getDynFlags = RuleM $ \dflags _ _ -> Just dflags
 667
 668 liftMaybe :: Maybe a -> RuleM a
 669 liftMaybe Nothing = mzero
 670 liftMaybe (Just x) = return x
 671
 672 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
 673 liftLit f = liftLitDynFlags (const f)
 674
 675 liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
 676 liftLitDynFlags f = do
 677   dflags <- getDynFlags
 678   [Lit lit] <- getArgs
 679   return $ Lit (f dflags lit)
 680
 681 removeOp32 :: RuleM CoreExpr
 682 removeOp32 = do
 683   dflags <- getDynFlags
 684   if wordSizeInBits dflags == 32
 685   then do
 686     [e] <- getArgs
 687     return e
 688   else mzero
 689
 690 getArgs :: RuleM [CoreExpr]
 691 getArgs = RuleM $ \_ _ args -> Just args
 692
 693 getInScopeEnv :: RuleM InScopeEnv
 694 getInScopeEnv = RuleM $ \_ iu _ -> Just iu
 695
 696 -- return the n-th argument of this rule, if it is a literal
 697 -- argument indices start from 0
 698 getLiteral :: Int -> RuleM Literal
 699 getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
 700   (Lit l:_) -> Just l
 701   _ -> Nothing
 702
 703 unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
 704 unaryLit op = do
 705   dflags <- getDynFlags
 706   [Lit l] <- getArgs
 707   liftMaybe $ op dflags (convFloating dflags l)
 708
 709 binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
 710 binaryLit op = do
 711   dflags <- getDynFlags
 712   [Lit l1, Lit l2] <- getArgs
 713   liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
 714
 715 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
 716 binaryCmpLit op = do
 717   dflags <- getDynFlags
 718   binaryLit (\_ -> cmpOp dflags op)
 719
 720 leftIdentity :: Literal -> RuleM CoreExpr
 721 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
 722
 723 rightIdentity :: Literal -> RuleM CoreExpr
 724 rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
 725
 726 identity :: Literal -> RuleM CoreExpr
 727 identity lit = leftIdentity lit `mplus` rightIdentity lit
 728
 729 leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
 730 leftIdentityDynFlags id_lit = do
 731   dflags <- getDynFlags
 732   [Lit l1, e2] <- getArgs
 733   guard $ l1 == id_lit dflags
 734   return e2
 735
 736 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
 737 rightIdentityDynFlags id_lit = do
 738   dflags <- getDynFlags
 739   [e1, Lit l2] <- getArgs
 740   guard $ l2 == id_lit dflags
 741   return e1
 742
 743 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
 744 identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
 745
 746 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
 747 leftZero zero = do
 748   dflags <- getDynFlags
 749   [Lit l1, _] <- getArgs
 750   guard $ l1 == zero dflags
 751   return $ Lit l1
 752
 753 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
 754 rightZero zero = do
 755   dflags <- getDynFlags
 756   [_, Lit l2] <- getArgs
 757   guard $ l2 == zero dflags
 758   return $ Lit l2
 759
 760 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
 761 zeroElem lit = leftZero lit `mplus` rightZero lit
 762
 763 equalArgs :: RuleM ()
 764 equalArgs = do
 765   [e1, e2] <- getArgs
 766   guard $ e1 `cheapEqExpr` e2
 767
 768 nonZeroLit :: Int -> RuleM ()
 769 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
 770
 771 -- When excess precision is not requested, cut down the precision of the
 772 -- Rational value to that of Float/Double. We confuse host architecture
 773 -- and target architecture here, but it's convenient (and wrong :-).
 774 convFloating :: DynFlags -> Literal -> Literal
 775 convFloating dflags (MachFloat  f) | not (gopt Opt_ExcessPrecision dflags) =
 776    MachFloat  (toRational (fromRational f :: Float ))
 777 convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
 778    MachDouble (toRational (fromRational d :: Double))
 779 convFloating _ l = l
 780
 781 guardFloatDiv :: RuleM ()
 782 guardFloatDiv = do
 783   [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
 784   guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
 785        && f2 /= 0            -- avoid NaN and Infinity/-Infinity
 786
 787 guardDoubleDiv :: RuleM ()
 788 guardDoubleDiv = do
 789   [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
 790   guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
 791        && d2 /= 0            -- avoid NaN and Infinity/-Infinity
 792 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
 793 -- zero, but we might want to preserve the negative zero here which
 794 -- is representable in Float/Double but not in (normalised)
 795 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
 796
 797 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
 798 strengthReduction two_lit add_op = do -- Note [Strength reduction]
 799   arg <- msum [ do [arg, Lit mult_lit] <- getArgs
 800                    guard (mult_lit == two_lit)
 801                    return arg
 802               , do [Lit mult_lit, arg] <- getArgs
 803                    guard (mult_lit == two_lit)
 804                    return arg ]
 805   return $ Var (mkPrimOpId add_op) `App` arg `App` arg
 806
 807 -- Note [Strength reduction]
 808 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
 809 --
 810 -- This rule turns floating point multiplications of the form 2.0 * x and
 811 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
 812 -- See #7116
 813
 814 -- Note [What's true and false]
 815 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 816 --
 817 -- trueValInt and falseValInt represent true and false values returned by
 818 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
 819 -- True is represented as an unboxed 1# literal, while false is represented
 820 -- as 0# literal.
 821 -- We still need Bool data constructors (True and False) to use in a rule
 822 -- for constant folding of equal Strings
 823
 824 trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
 825 trueValInt  dflags = Lit $ onei  dflags -- see Note [What's true and false]
 826 falseValInt dflags = Lit $ zeroi dflags
 827
 828 trueValBool, falseValBool :: Expr CoreBndr
 829 trueValBool   = Var trueDataConId -- see Note [What's true and false]
 830 falseValBool  = Var falseDataConId
 831
 832 ltVal, eqVal, gtVal :: Expr CoreBndr
 833 ltVal = Var ltDataConId
 834 eqVal = Var eqDataConId
 835 gtVal = Var gtDataConId
 836
 837 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
 838 mkIntVal dflags i = Lit (mkMachInt dflags i)
 839 mkWordVal :: DynFlags -> Integer -> Expr CoreBndr
 840 mkWordVal dflags w = Lit (mkMachWord dflags w)
 841 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
 842 mkFloatVal dflags f = Lit (convFloating dflags (MachFloat  f))
 843 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
 844 mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
 845
 846 matchPrimOpId :: PrimOp -> Id -> RuleM ()
 847 matchPrimOpId op id = do
 848   op' <- liftMaybe $ isPrimOpId_maybe id
 849   guard $ op == op'
 850
 851 {-
 852 ************************************************************************
 853 *                                                                      *
 854 \subsection{Special rules for seq, tagToEnum, dataToTag}
 855 *                                                                      *
 856 ************************************************************************
 857
 858 Note [tagToEnum#]
 859 ~~~~~~~~~~~~~~~~~
 860 Nasty check to ensure that tagToEnum# is applied to a type that is an
 861 enumeration TyCon.  Unification may refine the type later, but this
 862 check won't see that, alas.  It's crude but it works.
 863
 864 Here's are two cases that should fail
 865         f :: forall a. a
 866         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
 867
 868         g :: Int
 869         g = tagToEnum# 0        -- Int is not an enumeration
 870
 871 We used to make this check in the type inference engine, but it's quite
 872 ugly to do so, because the delayed constraint solving means that we don't
 873 really know what's going on until the end. It's very much a corner case
 874 because we don't expect the user to call tagToEnum# at all; we merely
 875 generate calls in derived instances of Enum.  So we compromise: a
 876 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
 877 and emits a warning.
 878 -}
 879
 880 tagToEnumRule :: RuleM CoreExpr
 881 -- If     data T a = A | B | C
 882 -- then   tag2Enum# (T ty) 2# -->  B ty
 883 tagToEnumRule = do
 884   [Type ty, Lit (MachInt i)] <- getArgs
 885   case splitTyConApp_maybe ty of
 886     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
 887       let tag = fromInteger i
 888           correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
 889       (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
 890       ASSERT(null rest) return ()
 891       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
 892
 893     -- See Note [tagToEnum#]
 894     _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
 895          return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
 896
 897 {-
 898 For dataToTag#, we can reduce if either
 899
 900         (a) the argument is a constructor
 901         (b) the argument is a variable whose unfolding is a known constructor
 902 -}
 903
 904 dataToTagRule :: RuleM CoreExpr
 905 dataToTagRule = a `mplus` b
 906   where
 907     a = do
 908       [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
 909       guard $ tag_to_enum `hasKey` tagToEnumKey
 910       guard $ ty1 `eqType` ty2
 911       return tag -- dataToTag (tagToEnum x)   ==>   x
 912     b = do
 913       dflags <- getDynFlags
 914       [_, val_arg] <- getArgs
 915       in_scope <- getInScopeEnv
 916       (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
 917       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
 918       return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
 919
 920 {-
 921 ************************************************************************
 922 *                                                                      *
 923 \subsection{Rules for seq# and spark#}
 924 *                                                                      *
 925 ************************************************************************
 926 -}
 927
 928 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
 929 seqRule :: RuleM CoreExpr
 930 seqRule = do
 931   [Type ty_a, Type ty_s, a, s] <- getArgs
 932   guard $ exprIsHNF a
 933   return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a]
 934
 935 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
 936 sparkRule :: RuleM CoreExpr
 937 sparkRule = seqRule -- reduce on HNF, just the same
 938   -- XXX perhaps we shouldn't do this, because a spark eliminated by
 939   -- this rule won't be counted as a dud at runtime?
 940
 941 {-
 942 ************************************************************************
 943 *                                                                      *
 944 \subsection{Built in rules}
 945 *                                                                      *
 946 ************************************************************************
 947
 948 Note [Scoping for Builtin rules]
 949 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 950 When compiling a (base-package) module that defines one of the
 951 functions mentioned in the RHS of a built-in rule, there's a danger
 952 that we'll see
 953
 954         f = ...(eq String x)....
 955
 956         ....and lower down...
 957
 958         eqString = ...
 959
 960 Then a rewrite would give
 961
 962         f = ...(eqString x)...
 963         ....and lower down...
 964         eqString = ...
 965
 966 and lo, eqString is not in scope.  This only really matters when we get to code
 967 generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole
 968 set of bindings, which sorts out the dependency.  Without -O we don't do any rule
 969 rewriting so again we are fine.
 970
 971 (This whole thing doesn't show up for non-built-in rules because their dependencies
 972 are explicit.)
 973 -}
 974
 975 builtinRules :: [CoreRule]
 976 -- Rules for non-primops that can't be expressed using a RULE pragma
 977 builtinRules
 978   = [BuiltinRule { ru_name = fsLit "AppendLitString",
 979                    ru_fn = unpackCStringFoldrName,
 980                    ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
 981      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
 982                    ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
 983      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
 984                    ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
 985      BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
 986                    ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }
 987      ]
 988  ++ builtinIntegerRules
 989
 990 builtinIntegerRules :: [CoreRule]
 991 builtinIntegerRules =
 992  [rule_IntToInteger   "smallInteger"        smallIntegerName,
 993   rule_WordToInteger  "wordToInteger"       wordToIntegerName,
 994   rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,
 995   rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,
 996   rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,
 997   rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,
 998   rule_convert        "integerToWord64"     integerToWord64Name     (\_ -> mkWord64LitWord64),
 999   rule_convert        "integerToInt64"      integerToInt64Name      (\_ -> mkInt64LitInt64),
1000   rule_binop          "plusInteger"         plusIntegerName         (+),
1001   rule_binop          "minusInteger"        minusIntegerName        (-),
1002   rule_binop          "timesInteger"        timesIntegerName        (*),
1003   rule_unop           "negateInteger"       negateIntegerName       negate,
1004   rule_binop_Prim     "eqInteger#"          eqIntegerPrimName       (==),
1005   rule_binop_Prim     "neqInteger#"         neqIntegerPrimName      (/=),
1006   rule_unop           "absInteger"          absIntegerName          abs,
1007   rule_unop           "signumInteger"       signumIntegerName       signum,
1008   rule_binop_Prim     "leInteger#"          leIntegerPrimName       (<=),
1009   rule_binop_Prim     "gtInteger#"          gtIntegerPrimName       (>),
1010   rule_binop_Prim     "ltInteger#"          ltIntegerPrimName       (<),
1011   rule_binop_Prim     "geInteger#"          geIntegerPrimName       (>=),
1012   rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
1013   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
1014   rule_convert        "floatFromInteger"    floatFromIntegerName    (\_ -> mkFloatLitFloat),
1015   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
1016   rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,
1017   rule_convert        "doubleFromInteger"   doubleFromIntegerName   (\_ -> mkDoubleLitDouble),
1018   rule_rationalTo     "rationalToFloat"     rationalToFloatName     mkFloatExpr,
1019   rule_rationalTo     "rationalToDouble"    rationalToDoubleName    mkDoubleExpr,
1020   rule_binop          "gcdInteger"          gcdIntegerName          gcd,
1021   rule_binop          "lcmInteger"          lcmIntegerName          lcm,
1022   rule_binop          "andInteger"          andIntegerName          (.&.),
1023   rule_binop          "orInteger"           orIntegerName           (.|.),
1024   rule_binop          "xorInteger"          xorIntegerName          xor,
1025   rule_unop           "complementInteger"   complementIntegerName   complement,
1026   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
1027   rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
1028   rule_bitInteger     "bitInteger"          bitIntegerName,
1029   -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
1030   rule_divop_one      "quotInteger"         quotIntegerName         quot,
1031   rule_divop_one      "remInteger"          remIntegerName          rem,
1032   rule_divop_one      "divInteger"          divIntegerName          div,
1033   rule_divop_one      "modInteger"          modIntegerName          mod,
1034   rule_divop_both     "divModInteger"       divModIntegerName       divMod,
1035   rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
1036   -- These rules below don't actually have to be built in, but if we
1037   -- put them in the Haskell source then we'd have to duplicate them
1038   -- between all Integer implementations
1039   rule_XToIntegerToX "smallIntegerToInt"       integerToIntName    smallIntegerName,
1040   rule_XToIntegerToX "wordToIntegerToWord"     integerToWordName   wordToIntegerName,
1041   rule_XToIntegerToX "int64ToIntegerToInt64"   integerToInt64Name  int64ToIntegerName,
1042   rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
1043   rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,
1044   rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,
1045   rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
1046   ]
1047     where rule_convert str name convert
1048            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1049                            ru_try = match_Integer_convert convert }
1050           rule_IntToInteger str name
1051            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1052                            ru_try = match_IntToInteger }
1053           rule_WordToInteger str name
1054            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1055                            ru_try = match_WordToInteger }
1056           rule_Int64ToInteger str name
1057            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1058                            ru_try = match_Int64ToInteger }
1059           rule_Word64ToInteger str name
1060            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1061                            ru_try = match_Word64ToInteger }
1062           rule_unop str name op
1063            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1064                            ru_try = match_Integer_unop op }
1065           rule_bitInteger str name
1066            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1067                            ru_try = match_IntToInteger_unop (bit . fromIntegral) }
1068           rule_binop str name op
1069            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1070                            ru_try = match_Integer_binop op }
1071           rule_divop_both str name op
1072            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1073                            ru_try = match_Integer_divop_both op }
1074           rule_divop_one str name op
1075            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1076                            ru_try = match_Integer_divop_one op }
1077           rule_Int_binop str name op
1078            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1079                            ru_try = match_Integer_Int_binop op }
1080           rule_binop_Prim str name op
1081            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1082                            ru_try = match_Integer_binop_Prim op }
1083           rule_binop_Ordering str name op
1084            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1085                            ru_try = match_Integer_binop_Ordering op }
1086           rule_encodeFloat str name op
1087            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1088                            ru_try = match_Integer_Int_encodeFloat op }
1089           rule_decodeDouble str name
1090            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1091                            ru_try = match_decodeDouble }
1092           rule_XToIntegerToX str name toIntegerName
1093            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1094                            ru_try = match_XToIntegerToX toIntegerName }
1095           rule_smallIntegerTo str name primOp
1096            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1097                            ru_try = match_smallIntegerTo primOp }
1098           rule_rationalTo str name mkLit
1099            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1100                            ru_try = match_rationalTo mkLit }
1101
1102 ---------------------------------------------------
1103 -- The rule is this:
1104 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
1105 --      =  unpackFoldrCString# "foobaz" c n
1106
1107 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1108 match_append_lit [Type ty1,
1109                     Lit (MachStr s1),
1110                     c1,
1111                     Var unpk `App` Type ty2
1112                              `App` Lit (MachStr s2)
1113                              `App` c2
1114                              `App` n
1115                    ]
1116   | unpk `hasKey` unpackCStringFoldrIdKey &&
1117     c1 `cheapEqExpr` c2
1118   = ASSERT( ty1 `eqType` ty2 )
1119     Just (Var unpk `App` Type ty1
1120                    `App` Lit (MachStr (s1 `BS.append` s2))
1121                    `App` c1
1122                    `App` n)
1123
1124 match_append_lit _ = Nothing
1125
1126 ---------------------------------------------------
1127 -- The rule is this:
1128 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
1129
1130 match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1131 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
1132                         Var unpk2 `App` Lit (MachStr s2)]
1133   | unpk1 `hasKey` unpackCStringIdKey,
1134     unpk2 `hasKey` unpackCStringIdKey
1135   = Just (if s1 == s2 then trueValBool else falseValBool)
1136
1137 match_eq_string _ _ = Nothing
1138
1139
1140 ---------------------------------------------------
1141 -- The rule is this:
1142 --      inline f_ty (f a b c) = <f's unfolding> a b c
1143 -- (if f has an unfolding, EVEN if it's a loop breaker)
1144 --
1145 -- It's important to allow the argument to 'inline' to have args itself
1146 -- (a) because its more forgiving to allow the programmer to write
1147 --       inline f a b c
1148 --   or  inline (f a b c)
1149 -- (b) because a polymorphic f wll get a type argument that the
1150 --     programmer can't avoid
1151 --
1152 -- Also, don't forget about 'inline's type argument!
1153 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1154 match_inline (Type _ : e : _)
1155   | (Var f, args1) <- collectArgs e,
1156     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
1157              -- Ignore the IdUnfoldingFun here!
1158   = Just (mkApps unf args1)
1159
1160 match_inline _ = Nothing
1161
1162
1163 -- See Note [magicDictId magic] in `basicTypes/MkId.hs`
1164 -- for a description of what is going on here.
1165 match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1166 match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
1167   | Just (fieldTy, _)   <- splitFunTy_maybe $ dropForAlls $ idType wrap
1168   , Just (dictTy, _)    <- splitFunTy_maybe fieldTy
1169   , Just dictTc         <- tyConAppTyCon_maybe dictTy
1170   , Just (_,_,co)       <- unwrapNewTyCon_maybe dictTc
1171   = Just
1172   $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
1173       `App` y
1174
1175 match_magicDict _ = Nothing
1176
1177 -------------------------------------------------
1178 -- Integer rules
1179 --   smallInteger  (79::Int#)  = 79::Integer
1180 --   wordToInteger (79::Word#) = 79::Integer
1181 -- Similarly Int64, Word64
1182
1183 match_IntToInteger :: RuleFun
1184 match_IntToInteger = match_IntToInteger_unop id
1185
1186 match_WordToInteger :: RuleFun
1187 match_WordToInteger _ id_unf id [xl]
1188   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
1189   = case splitFunTy_maybe (idType id) of
1190     Just (_, integerTy) ->
1191         Just (Lit (LitInteger x integerTy))
1192     _ ->
1193         panic "match_WordToInteger: Id has the wrong type"
1194 match_WordToInteger _ _ _ _ = Nothing
1195
1196 match_Int64ToInteger :: RuleFun
1197 match_Int64ToInteger _ id_unf id [xl]
1198   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
1199   = case splitFunTy_maybe (idType id) of
1200     Just (_, integerTy) ->
1201         Just (Lit (LitInteger x integerTy))
1202     _ ->
1203         panic "match_Int64ToInteger: Id has the wrong type"
1204 match_Int64ToInteger _ _ _ _ = Nothing
1205
1206 match_Word64ToInteger :: RuleFun
1207 match_Word64ToInteger _ id_unf id [xl]
1208   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
1209   = case splitFunTy_maybe (idType id) of
1210     Just (_, integerTy) ->
1211         Just (Lit (LitInteger x integerTy))
1212     _ ->
1213         panic "match_Word64ToInteger: Id has the wrong type"
1214 match_Word64ToInteger _ _ _ _ = Nothing
1215
1216 -------------------------------------------------
1217 match_Integer_convert :: Num a
1218                       => (DynFlags -> a -> Expr CoreBndr)
1219                       -> RuleFun
1220 match_Integer_convert convert dflags id_unf _ [xl]
1221   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1222   = Just (convert dflags (fromInteger x))
1223 match_Integer_convert _ _ _ _ _ = Nothing
1224
1225 match_Integer_unop :: (Integer -> Integer) -> RuleFun
1226 match_Integer_unop unop _ id_unf _ [xl]
1227   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1228   = Just (Lit (LitInteger (unop x) i))
1229 match_Integer_unop _ _ _ _ _ = Nothing
1230
1231 {- Note [Rewriting bitInteger]
1232
1233 For most types the bitInteger operation can be implemented in terms of shifts.
1234 The integer-gmp package, however, can do substantially better than this if
1235 allowed to provide its own implementation. However, in so doing it previously lost
1236 constant-folding (see Trac #8832). The bitInteger rule above provides constant folding
1237 specifically for this function.
1238
1239 There is, however, a bit of trickiness here when it comes to ranges. While the
1240 AST encodes all integers (even MachInts) as Integers, `bit` expects the bit
1241 index to be given as an Int. Hence we coerce to an Int in the rule definition.
1242 This will behave a bit funny for constants larger than the word size, but the user
1243 should expect some funniness given that they will have at very least ignored a
1244 warning in this case.
1245 -}
1246
1247 match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
1248 match_IntToInteger_unop unop _ id_unf fn [xl]
1249   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
1250   = case splitFunTy_maybe (idType fn) of
1251     Just (_, integerTy) ->
1252         Just (Lit (LitInteger (unop x) integerTy))
1253     _ ->
1254         panic "match_IntToInteger_unop: Id has the wrong type"
1255 match_IntToInteger_unop _ _ _ _ _ = Nothing
1256
1257 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
1258 match_Integer_binop binop _ id_unf _ [xl,yl]
1259   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1260   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1261   = Just (Lit (LitInteger (x `binop` y) i))
1262 match_Integer_binop _ _ _ _ _ = Nothing
1263
1264 -- This helper is used for the quotRem and divMod functions
1265 match_Integer_divop_both
1266    :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
1267 match_Integer_divop_both divop _ id_unf _ [xl,yl]
1268   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
1269   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1270   , y /= 0
1271   , (r,s) <- x `divop` y
1272   = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
1273 match_Integer_divop_both _ _ _ _ _ = Nothing
1274
1275 -- This helper is used for the quot and rem functions
1276 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
1277 match_Integer_divop_one divop _ id_unf _ [xl,yl]
1278   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1279   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1280   , y /= 0
1281   = Just (Lit (LitInteger (x `divop` y) i))
1282 match_Integer_divop_one _ _ _ _ _ = Nothing
1283
1284 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
1285 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
1286   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1287   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1288   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
1289 match_Integer_Int_binop _ _ _ _ _ = Nothing
1290
1291 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
1292 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
1293   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1294   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1295   = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
1296 match_Integer_binop_Prim _ _ _ _ _ = Nothing
1297
1298 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
1299 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
1300   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1301   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1302   = Just $ case x `binop` y of
1303              LT -> ltVal
1304              EQ -> eqVal
1305              GT -> gtVal
1306 match_Integer_binop_Ordering _ _ _ _ _ = Nothing
1307
1308 match_Integer_Int_encodeFloat :: RealFloat a
1309                               => (a -> Expr CoreBndr)
1310                               -> RuleFun
1311 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
1312   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1313   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1314   = Just (mkLit $ encodeFloat x (fromInteger y))
1315 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
1316
1317 ---------------------------------------------------
1318 -- constant folding for Float/Double
1319 --
1320 -- This turns
1321 --      rationalToFloat n d
1322 -- into a literal Float, and similarly for Doubles.
1323 --
1324 -- it's important to not match d == 0, because that may represent a
1325 -- literal "0/0" or similar, and we can't produce a literal value for
1326 -- NaN or +-Inf
1327 match_rationalTo :: RealFloat a
1328                  => (a -> Expr CoreBndr)
1329                  -> RuleFun
1330 match_rationalTo mkLit _ id_unf _ [xl, yl]
1331   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1332   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1333   , y /= 0
1334   = Just (mkLit (fromRational (x % y)))
1335 match_rationalTo _ _ _ _ _ = Nothing
1336
1337 match_decodeDouble :: RuleFun
1338 match_decodeDouble _ id_unf fn [xl]
1339   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1340   = case splitFunTy_maybe (idType fn) of
1341     Just (_, res)
1342       | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res
1343       -> case decodeFloat (fromRational x :: Double) of
1344            (y, z) ->
1345              Just $ mkCoreUbxTup [integerTy, intHashTy]
1346                                  [Lit (LitInteger y integerTy),
1347                                   Lit (MachInt (toInteger z))]
1348     _ ->
1349         pprPanic "match_decodeDouble: Id has the wrong type"
1350           (ppr fn <+> dcolon <+> ppr (idType fn))
1351 match_decodeDouble _ _ _ _ = Nothing
1352
1353 match_XToIntegerToX :: Name -> RuleFun
1354 match_XToIntegerToX n _ _ _ [App (Var x) y]
1355   | idName x == n
1356   = Just y
1357 match_XToIntegerToX _ _ _ _ _ = Nothing
1358
1359 match_smallIntegerTo :: PrimOp -> RuleFun
1360 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
1361   | idName x == smallIntegerName
1362   = Just $ App (Var (mkPrimOpId primOp)) y
1363 match_smallIntegerTo _ _ _ _ _ = Nothing