never executed always true always false
    1 {-
    2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    3 
    4 Conceptually, constant folding should be parameterized with the kind
    5 of target machine to get identical behaviour during compilation time
    6 and runtime. We cheat a little bit here...
    7 
    8 ToDo:
    9    check boundaries before folding, e.g. we can fold the Float addition
   10    (i1 + i2) only if it results in a valid Float.
   11 -}
   12 
   13 {-# LANGUAGE AllowAmbiguousTypes #-}
   14 {-# LANGUAGE DeriveFunctor #-}
   15 {-# LANGUAGE LambdaCase #-}
   16 {-# LANGUAGE MultiWayIf #-}
   17 {-# LANGUAGE PatternSynonyms #-}
   18 {-# LANGUAGE RankNTypes #-}
   19 {-# LANGUAGE ScopedTypeVariables #-}
   20 {-# LANGUAGE TypeApplications #-}
   21 {-# LANGUAGE ViewPatterns #-}
   22 
   23 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}
   24 
   25 -- | Constant Folder
   26 module GHC.Core.Opt.ConstantFold
   27    ( primOpRules
   28    , builtinRules
   29    , caseRules
   30    )
   31 where
   32 
   33 import GHC.Prelude
   34 
   35 import GHC.Platform
   36 
   37 import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, voidPrimId )
   38 import GHC.Types.Id
   39 import GHC.Types.Literal
   40 import GHC.Types.Var.Set
   41 import GHC.Types.Var.Env
   42 import GHC.Types.Name.Occurrence ( occNameFS )
   43 import GHC.Types.Tickish
   44 import GHC.Types.Name ( Name, nameOccName )
   45 import GHC.Types.Basic
   46 
   47 import GHC.Core
   48 import GHC.Core.Make
   49 import GHC.Core.SimpleOpt (  exprIsConApp_maybe, exprIsLiteral_maybe )
   50 import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
   51 import GHC.Core.Utils  ( eqExpr, cheapEqExpr, exprIsHNF, exprType
   52                        , stripTicksTop, stripTicksTopT, mkTicks )
   53 import GHC.Core.Multiplicity
   54 import GHC.Core.FVs
   55 import GHC.Core.Type
   56 import GHC.Core.TyCon
   57    ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
   58    , isNewTyCon, tyConDataCons
   59    , tyConFamilySize )
   60 
   61 import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
   62 import GHC.Builtin.Types
   63 import GHC.Builtin.Types.Prim
   64 import GHC.Builtin.Names
   65 
   66 import GHC.Data.FastString
   67 import GHC.Data.Maybe      ( orElse )
   68 
   69 import GHC.Utils.Outputable
   70 import GHC.Utils.Misc
   71 import GHC.Utils.Panic
   72 import GHC.Utils.Panic.Plain
   73 import GHC.Utils.Trace
   74 
   75 import Control.Applicative ( Alternative(..) )
   76 import Control.Monad
   77 import Data.Functor (($>))
   78 import qualified Data.ByteString as BS
   79 import Data.Ratio
   80 import Data.Word
   81 import Data.Maybe (fromMaybe, fromJust)
   82 
   83 {-
   84 Note [Constant folding]
   85 ~~~~~~~~~~~~~~~~~~~~~~~
   86 primOpRules generates a rewrite rule for each primop
   87 These rules do what is often called "constant folding"
   88 E.g. the rules for +# might say
   89         4 +# 5 = 9
   90 Well, of course you'd need a lot of rules if you did it
   91 like that, so we use a BuiltinRule instead, so that we
   92 can match in any two literal values.  So the rule is really
   93 more like
   94         (Lit x) +# (Lit y) = Lit (x+#y)
   95 where the (+#) on the rhs is done at compile time
   96 
   97 That is why these rules are built in here.
   98 -}
   99 
  100 primOpRules ::  Name -> PrimOp -> Maybe CoreRule
  101 primOpRules nm = \case
  102    TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]
  103    DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]
  104 
  105    -- Int8 operations
  106    Int8AddOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+))
  107                                     , identity zeroI8
  108                                     , addFoldingRules Int8AddOp int8Ops
  109                                     ]
  110    Int8SubOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (-))
  111                                     , rightIdentity zeroI8
  112                                     , equalArgs $> Lit zeroI8
  113                                     , subFoldingRules Int8SubOp int8Ops
  114                                     ]
  115    Int8MulOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (*))
  116                                     , zeroElem
  117                                     , identity oneI8
  118                                     , mulFoldingRules Int8MulOp int8Ops
  119                                     ]
  120    Int8QuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot)
  121                                     , leftZero
  122                                     , rightIdentity oneI8
  123                                     , equalArgs $> Lit oneI8 ]
  124    Int8RemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem)
  125                                     , leftZero
  126                                     , oneLit 1 $> Lit zeroI8
  127                                     , equalArgs $> Lit zeroI8 ]
  128    Int8NegOp   -> mkPrimOpRule nm 1 [ unaryLit negOp
  129                                     , semiInversePrimOp Int8NegOp ]
  130    Int8SllOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftL)
  131                                     , rightIdentity zeroI8 ]
  132    Int8SraOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftR)
  133                                     , rightIdentity zeroI8 ]
  134    Int8SrlOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 $ const $ shiftRightLogical @Word8
  135                                     , rightIdentity zeroI8 ]
  136 
  137    -- Word8 operations
  138    Word8AddOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (+))
  139                                     , identity zeroW8
  140                                     , addFoldingRules Word8AddOp word8Ops
  141                                     ]
  142    Word8SubOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (-))
  143                                     , rightIdentity zeroW8
  144                                     , equalArgs $> Lit zeroW8
  145                                     , subFoldingRules Word8SubOp word8Ops
  146                                     ]
  147    Word8MulOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (*))
  148                                     , identity oneW8
  149                                     , mulFoldingRules Word8MulOp word8Ops
  150                                     ]
  151    Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot)
  152                                     , rightIdentity oneW8 ]
  153    Word8RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem)
  154                                     , leftZero
  155                                     , oneLit 1 $> Lit zeroW8
  156                                     , equalArgs $> Lit zeroW8 ]
  157    Word8AndOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.&.))
  158                                     , idempotent
  159                                     , zeroElem
  160                                     , identity (mkLitWord8 0xFF)
  161                                     , sameArgIdempotentCommut Word8AndOp
  162                                     , andFoldingRules word8Ops
  163                                     ]
  164    Word8OrOp   -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.|.))
  165                                     , idempotent
  166                                     , identity zeroW8
  167                                     , sameArgIdempotentCommut Word8OrOp
  168                                     , orFoldingRules word8Ops
  169                                     ]
  170    Word8XorOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 xor)
  171                                     , identity zeroW8
  172                                     , equalArgs $> Lit zeroW8 ]
  173    Word8NotOp  -> mkPrimOpRule nm 1 [ unaryLit complementOp
  174                                     , semiInversePrimOp Word8NotOp ]
  175    Word8SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 (const shiftL) ]
  176    Word8SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 $ const $ shiftRightLogical @Word8 ]
  177 
  178 
  179    -- Int16 operations
  180    Int16AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (+))
  181                                     , identity zeroI16
  182                                     , addFoldingRules Int16AddOp int16Ops
  183                                     ]
  184    Int16SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (-))
  185                                     , rightIdentity zeroI16
  186                                     , equalArgs $> Lit zeroI16
  187                                     , subFoldingRules Int16SubOp int16Ops
  188                                     ]
  189    Int16MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (*))
  190                                     , zeroElem
  191                                     , identity oneI16
  192                                     , mulFoldingRules Int16MulOp int16Ops
  193                                     ]
  194    Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot)
  195                                     , leftZero
  196                                     , rightIdentity oneI16
  197                                     , equalArgs $> Lit oneI16 ]
  198    Int16RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem)
  199                                     , leftZero
  200                                     , oneLit 1 $> Lit zeroI16
  201                                     , equalArgs $> Lit zeroI16 ]
  202    Int16NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp
  203                                     , semiInversePrimOp Int16NegOp ]
  204    Int16SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftL)
  205                                     , rightIdentity zeroI16 ]
  206    Int16SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftR)
  207                                     , rightIdentity zeroI16 ]
  208    Int16SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 $ const $ shiftRightLogical @Word16
  209                                     , rightIdentity zeroI16 ]
  210 
  211    -- Word16 operations
  212    Word16AddOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (+))
  213                                     , identity zeroW16
  214                                     , addFoldingRules Word16AddOp word16Ops
  215                                     ]
  216    Word16SubOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (-))
  217                                     , rightIdentity zeroW16
  218                                     , equalArgs $> Lit zeroW16
  219                                     , subFoldingRules Word16SubOp word16Ops
  220                                     ]
  221    Word16MulOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (*))
  222                                     , identity oneW16
  223                                     , mulFoldingRules Word16MulOp word16Ops
  224                                     ]
  225    Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot)
  226                                     , rightIdentity oneW16 ]
  227    Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem)
  228                                     , leftZero
  229                                     , oneLit 1 $> Lit zeroW16
  230                                     , equalArgs $> Lit zeroW16 ]
  231    Word16AndOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.&.))
  232                                     , idempotent
  233                                     , zeroElem
  234                                     , identity (mkLitWord16 0xFFFF)
  235                                     , sameArgIdempotentCommut Word16AndOp
  236                                     , andFoldingRules word16Ops
  237                                     ]
  238    Word16OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.|.))
  239                                     , idempotent
  240                                     , identity zeroW16
  241                                     , sameArgIdempotentCommut Word16OrOp
  242                                     , orFoldingRules word16Ops
  243                                     ]
  244    Word16XorOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 xor)
  245                                     , identity zeroW16
  246                                     , equalArgs $> Lit zeroW16 ]
  247    Word16NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
  248                                     , semiInversePrimOp Word16NotOp ]
  249    Word16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 (const shiftL) ]
  250    Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 $ const $ shiftRightLogical @Word16 ]
  251 
  252 
  253    -- Int32 operations
  254    Int32AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (+))
  255                                     , identity zeroI32
  256                                     , addFoldingRules Int32AddOp int32Ops
  257                                     ]
  258    Int32SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (-))
  259                                     , rightIdentity zeroI32
  260                                     , equalArgs $> Lit zeroI32
  261                                     , subFoldingRules Int32SubOp int32Ops
  262                                     ]
  263    Int32MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (*))
  264                                     , zeroElem
  265                                     , identity oneI32
  266                                     , mulFoldingRules Int32MulOp int32Ops
  267                                     ]
  268    Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot)
  269                                     , leftZero
  270                                     , rightIdentity oneI32
  271                                     , equalArgs $> Lit oneI32 ]
  272    Int32RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem)
  273                                     , leftZero
  274                                     , oneLit 1 $> Lit zeroI32
  275                                     , equalArgs $> Lit zeroI32 ]
  276    Int32NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp
  277                                     , semiInversePrimOp Int32NegOp ]
  278    Int32SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftL)
  279                                     , rightIdentity zeroI32 ]
  280    Int32SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftR)
  281                                     , rightIdentity zeroI32 ]
  282    Int32SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 $ const $ shiftRightLogical @Word32
  283                                     , rightIdentity zeroI32 ]
  284 
  285    -- Word32 operations
  286    Word32AddOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (+))
  287                                     , identity zeroW32
  288                                     , addFoldingRules Word32AddOp word32Ops
  289                                     ]
  290    Word32SubOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (-))
  291                                     , rightIdentity zeroW32
  292                                     , equalArgs $> Lit zeroW32
  293                                     , subFoldingRules Word32SubOp word32Ops
  294                                     ]
  295    Word32MulOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (*))
  296                                     , identity oneW32
  297                                     , mulFoldingRules Word32MulOp word32Ops
  298                                     ]
  299    Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot)
  300                                     , rightIdentity oneW32 ]
  301    Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem)
  302                                     , leftZero
  303                                     , oneLit 1 $> Lit zeroW32
  304                                     , equalArgs $> Lit zeroW32 ]
  305    Word32AndOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.&.))
  306                                     , idempotent
  307                                     , zeroElem
  308                                     , identity (mkLitWord32 0xFFFFFFFF)
  309                                     , sameArgIdempotentCommut Word32AndOp
  310                                     , andFoldingRules word32Ops
  311                                     ]
  312    Word32OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.|.))
  313                                     , idempotent
  314                                     , identity zeroW32
  315                                     , sameArgIdempotentCommut Word32OrOp
  316                                     , orFoldingRules word32Ops
  317                                     ]
  318    Word32XorOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 xor)
  319                                     , identity zeroW32
  320                                     , equalArgs $> Lit zeroW32 ]
  321    Word32NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
  322                                     , semiInversePrimOp Word32NotOp ]
  323    Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 (const shiftL) ]
  324    Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 $ const $ shiftRightLogical @Word32 ]
  325 
  326    -- Int64 operations
  327    Int64AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (+))
  328                                     , identity zeroI64
  329                                     , addFoldingRules Int64AddOp int64Ops
  330                                     ]
  331    Int64SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (-))
  332                                     , rightIdentity zeroI64
  333                                     , equalArgs $> Lit zeroI64
  334                                     , subFoldingRules Int64SubOp int64Ops
  335                                     ]
  336    Int64MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (*))
  337                                     , zeroElem
  338                                     , identity oneI64
  339                                     , mulFoldingRules Int64MulOp int64Ops
  340                                     ]
  341    Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot)
  342                                     , leftZero
  343                                     , rightIdentity oneI64
  344                                     , equalArgs $> Lit oneI64 ]
  345    Int64RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem)
  346                                     , leftZero
  347                                     , oneLit 1 $> Lit zeroI64
  348                                     , equalArgs $> Lit zeroI64 ]
  349    Int64NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp
  350                                     , semiInversePrimOp Int64NegOp ]
  351    Int64SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftL)
  352                                     , rightIdentity zeroI64 ]
  353    Int64SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftR)
  354                                     , rightIdentity zeroI64 ]
  355    Int64SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 $ const $ shiftRightLogical @Word64
  356                                     , rightIdentity zeroI64 ]
  357 
  358    -- Word64 operations
  359    Word64AddOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (+))
  360                                     , identity zeroW64
  361                                     , addFoldingRules Word64AddOp word64Ops
  362                                     ]
  363    Word64SubOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (-))
  364                                     , rightIdentity zeroW64
  365                                     , equalArgs $> Lit zeroW64
  366                                     , subFoldingRules Word64SubOp word64Ops
  367                                     ]
  368    Word64MulOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (*))
  369                                     , identity oneW64
  370                                     , mulFoldingRules Word64MulOp word64Ops
  371                                     ]
  372    Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot)
  373                                     , rightIdentity oneW64 ]
  374    Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem)
  375                                     , leftZero
  376                                     , oneLit 1 $> Lit zeroW64
  377                                     , equalArgs $> Lit zeroW64 ]
  378    Word64AndOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.&.))
  379                                     , idempotent
  380                                     , zeroElem
  381                                     , identity (mkLitWord64 0xFFFFFFFFFFFFFFFF)
  382                                     , sameArgIdempotentCommut Word64AndOp
  383                                     , andFoldingRules word64Ops
  384                                     ]
  385    Word64OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.))
  386                                     , idempotent
  387                                     , identity zeroW64
  388                                     , sameArgIdempotentCommut Word64OrOp
  389                                     , orFoldingRules word64Ops
  390                                     ]
  391    Word64XorOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 xor)
  392                                     , identity zeroW64
  393                                     , equalArgs $> Lit zeroW64 ]
  394    Word64NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp
  395                                     , semiInversePrimOp Word64NotOp ]
  396    Word64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 (const shiftL) ]
  397    Word64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 $ const $ shiftRightLogical @Word64 ]
  398 
  399    -- Int operations
  400    IntAddOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
  401                                     , identityPlatform zeroi
  402                                     , addFoldingRules IntAddOp intOps
  403                                     ]
  404    IntSubOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
  405                                     , rightIdentityPlatform zeroi
  406                                     , equalArgs >> retLit zeroi
  407                                     , subFoldingRules IntSubOp intOps
  408                                     ]
  409    IntAddCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))
  410                                     , identityCPlatform zeroi ]
  411    IntSubCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))
  412                                     , rightIdentityCPlatform zeroi
  413                                     , equalArgs >> retLitNoC zeroi ]
  414    IntMulOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
  415                                     , zeroElem
  416                                     , identityPlatform onei
  417                                     , mulFoldingRules IntMulOp intOps
  418                                     ]
  419    IntMul2Op   -> mkPrimOpRule nm 2 [ do
  420                                         [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs
  421                                         platform <- getPlatform
  422                                         let r = l1 * l2
  423                                         pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
  424                                           [ Lit (if platformInIntRange platform r then zeroi platform else onei platform)
  425                                           , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform)
  426                                           , mkIntLitWrap platform r
  427                                           ]
  428 
  429                                     , zeroElem >>= \z ->
  430                                         pure (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
  431                                                            [z,z,z])
  432 
  433                                       -- timesInt2# 1# other
  434                                       -- ~~~>
  435                                       -- (# 0#, 0# -# (other >># (WORD_SIZE_IN_BITS-1)), other #)
  436                                       -- The second element is the sign bit
  437                                       -- repeated to fill a word.
  438                                     , identityPlatform onei >>= \other -> do
  439                                         platform <- getPlatform
  440                                         pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]
  441                                           [ Lit (zeroi platform)
  442                                           , mkCoreApps (Var (mkPrimOpId IntSubOp))
  443                                               [ Lit (zeroi platform)
  444                                               , mkCoreApps (Var (mkPrimOpId IntSrlOp))
  445                                                 [ other
  446                                                 , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1))
  447                                                 ]
  448                                               ]
  449                                           , other
  450                                           ]
  451                                     ]
  452    IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
  453                                     , leftZero
  454                                     , rightIdentityPlatform onei
  455                                     , equalArgs >> retLit onei ]
  456    IntRemOp    -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
  457                                     , leftZero
  458                                     , oneLit 1 >> retLit zeroi
  459                                     , equalArgs >> retLit zeroi ]
  460    IntAndOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
  461                                     , idempotent
  462                                     , zeroElem
  463                                     , identityPlatform (\p -> mkLitInt p (-1))
  464                                     , sameArgIdempotentCommut IntAndOp
  465                                     , andFoldingRules intOps
  466                                     ]
  467    IntOrOp     -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
  468                                     , idempotent
  469                                     , identityPlatform zeroi
  470                                     , sameArgIdempotentCommut IntOrOp
  471                                     , orFoldingRules intOps
  472                                     ]
  473    IntXorOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
  474                                     , identityPlatform zeroi
  475                                     , equalArgs >> retLit zeroi ]
  476    IntNotOp    -> mkPrimOpRule nm 1 [ unaryLit complementOp
  477                                     , semiInversePrimOp IntNotOp ]
  478    IntNegOp    -> mkPrimOpRule nm 1 [ unaryLit negOp
  479                                     , semiInversePrimOp IntNegOp ]
  480    IntSllOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftL)
  481                                     , rightIdentityPlatform zeroi ]
  482    IntSraOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftR)
  483                                     , rightIdentityPlatform zeroi ]
  484    IntSrlOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogicalNative
  485                                     , rightIdentityPlatform zeroi ]
  486 
  487    -- Word operations
  488    WordAddOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
  489                                     , identityPlatform zerow
  490                                     , addFoldingRules WordAddOp wordOps
  491                                     ]
  492    WordSubOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
  493                                     , rightIdentityPlatform zerow
  494                                     , equalArgs >> retLit zerow
  495                                     , subFoldingRules WordSubOp wordOps
  496                                     ]
  497    WordAddCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))
  498                                     , identityCPlatform zerow ]
  499    WordSubCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))
  500                                     , rightIdentityCPlatform zerow
  501                                     , equalArgs >> retLitNoC zerow ]
  502    WordMulOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
  503                                     , identityPlatform onew
  504                                     , mulFoldingRules WordMulOp wordOps
  505                                     ]
  506    WordQuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
  507                                     , rightIdentityPlatform onew ]
  508    WordRemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
  509                                     , leftZero
  510                                     , oneLit 1 >> retLit zerow
  511                                     , equalArgs >> retLit zerow ]
  512    WordAndOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
  513                                     , idempotent
  514                                     , zeroElem
  515                                     , identityPlatform (\p -> mkLitWord p (platformMaxWord p))
  516                                     , sameArgIdempotentCommut WordAndOp
  517                                     , andFoldingRules wordOps
  518                                     ]
  519    WordOrOp    -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
  520                                     , idempotent
  521                                     , identityPlatform zerow
  522                                     , sameArgIdempotentCommut WordOrOp
  523                                     , orFoldingRules wordOps
  524                                     ]
  525    WordXorOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
  526                                     , identityPlatform zerow
  527                                     , equalArgs >> retLit zerow ]
  528    WordNotOp   -> mkPrimOpRule nm 1 [ unaryLit complementOp
  529                                     , semiInversePrimOp WordNotOp ]
  530    WordSllOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]
  531    WordSrlOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogicalNative ]
  532 
  533    PopCnt8Op   -> mkPrimOpRule nm 1 [ pop_count @Word8  ]
  534    PopCnt16Op  -> mkPrimOpRule nm 1 [ pop_count @Word16 ]
  535    PopCnt32Op  -> mkPrimOpRule nm 1 [ pop_count @Word32 ]
  536    PopCnt64Op  -> mkPrimOpRule nm 1 [ pop_count @Word64 ]
  537    PopCntOp    -> mkPrimOpRule nm 1 [ getWordSize >>= \case
  538                                         PW4 -> pop_count @Word32
  539                                         PW8 -> pop_count @Word64
  540                                     ]
  541 
  542    Ctz8Op      -> mkPrimOpRule nm 1 [ ctz @Word8  ]
  543    Ctz16Op     -> mkPrimOpRule nm 1 [ ctz @Word16 ]
  544    Ctz32Op     -> mkPrimOpRule nm 1 [ ctz @Word32 ]
  545    Ctz64Op     -> mkPrimOpRule nm 1 [ ctz @Word64 ]
  546    CtzOp       -> mkPrimOpRule nm 1 [ getWordSize >>= \case
  547                                         PW4 -> ctz @Word32
  548                                         PW8 -> ctz @Word64
  549                                     ]
  550 
  551    Clz8Op      -> mkPrimOpRule nm 1 [ clz @Word8  ]
  552    Clz16Op     -> mkPrimOpRule nm 1 [ clz @Word16 ]
  553    Clz32Op     -> mkPrimOpRule nm 1 [ clz @Word32 ]
  554    Clz64Op     -> mkPrimOpRule nm 1 [ clz @Word64 ]
  555    ClzOp       -> mkPrimOpRule nm 1 [ getWordSize >>= \case
  556                                         PW4 -> clz @Word32
  557                                         PW8 -> clz @Word64
  558                                     ]
  559 
  560    -- coercions
  561 
  562    Int8ToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
  563    Int16ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
  564    Int32ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
  565    Int64ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
  566    IntToInt8Op    -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit
  567                                        , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ]
  568    IntToInt16Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit
  569                                        , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ]
  570    IntToInt32Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit
  571                                        , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ]
  572    IntToInt64Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ]
  573 
  574    Word8ToWordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
  575                                        , extendNarrowPassthrough WordToWord8Op 0xFF
  576                                        ]
  577    Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
  578                                        , extendNarrowPassthrough WordToWord16Op 0xFFFF
  579                                        ]
  580    Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
  581                                        , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF
  582                                        ]
  583    Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]
  584 
  585    WordToWord8Op  -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit
  586                                        , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ]
  587    WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit
  588                                        , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ]
  589    WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit
  590                                        , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ]
  591    WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ]
  592 
  593    Word8ToInt8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) ]
  594    Int8ToWord8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8) ]
  595    Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16) ]
  596    Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16) ]
  597    Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32) ]
  598    Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32) ]
  599    Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64) ]
  600    Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64) ]
  601 
  602    WordToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt) ]
  603    IntToWordOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord) ]
  604 
  605    Narrow8IntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt8)
  606                                        , subsumedByPrimOp Narrow8IntOp
  607                                        , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
  608                                        , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp
  609                                        , narrowSubsumesAnd IntAndOp Narrow8IntOp 8 ]
  610    Narrow16IntOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt16)
  611                                        , subsumedByPrimOp Narrow8IntOp
  612                                        , subsumedByPrimOp Narrow16IntOp
  613                                        , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp
  614                                        , narrowSubsumesAnd IntAndOp Narrow16IntOp 16 ]
  615    Narrow32IntOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt32)
  616                                        , subsumedByPrimOp Narrow8IntOp
  617                                        , subsumedByPrimOp Narrow16IntOp
  618                                        , subsumedByPrimOp Narrow32IntOp
  619                                        , removeOp32
  620                                        , narrowSubsumesAnd IntAndOp Narrow32IntOp 32 ]
  621    Narrow8WordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord8)
  622                                        , subsumedByPrimOp Narrow8WordOp
  623                                        , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
  624                                        , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp
  625                                        , narrowSubsumesAnd WordAndOp Narrow8WordOp 8 ]
  626    Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord16)
  627                                        , subsumedByPrimOp Narrow8WordOp
  628                                        , subsumedByPrimOp Narrow16WordOp
  629                                        , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp
  630                                        , narrowSubsumesAnd WordAndOp Narrow16WordOp 16 ]
  631    Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord32)
  632                                        , subsumedByPrimOp Narrow8WordOp
  633                                        , subsumedByPrimOp Narrow16WordOp
  634                                        , subsumedByPrimOp Narrow32WordOp
  635                                        , removeOp32
  636                                        , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ]
  637 
  638    OrdOp          -> mkPrimOpRule nm 1 [ liftLit charToIntLit
  639                                        , semiInversePrimOp ChrOp ]
  640    ChrOp          -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
  641                                             guard (litFitsInChar lit)
  642                                             liftLit intToCharLit
  643                                        , semiInversePrimOp OrdOp ]
  644    FloatToIntOp    -> mkPrimOpRule nm 1 [ liftLit floatToIntLit ]
  645    IntToFloatOp    -> mkPrimOpRule nm 1 [ liftLit intToFloatLit ]
  646    DoubleToIntOp   -> mkPrimOpRule nm 1 [ liftLit doubleToIntLit ]
  647    IntToDoubleOp   -> mkPrimOpRule nm 1 [ liftLit intToDoubleLit ]
  648    -- SUP: Not sure what the standard says about precision in the following 2 cases
  649    FloatToDoubleOp -> mkPrimOpRule nm 1 [ liftLit floatToDoubleLit ]
  650    DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ]
  651 
  652    -- Float
  653    FloatAddOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
  654                                           , identity zerof ]
  655    FloatSubOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
  656                                           , rightIdentity zerof ]
  657    FloatMulOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
  658                                           , identity onef
  659                                           , strengthReduction twof FloatAddOp  ]
  660              -- zeroElem zerof doesn't hold because of NaN
  661    FloatDivOp        -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
  662                                           , rightIdentity onef ]
  663    FloatNegOp        -> mkPrimOpRule nm 1 [ unaryLit negOp
  664                                           , semiInversePrimOp FloatNegOp ]
  665    FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ]
  666 
  667    -- Double
  668    DoubleAddOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
  669                                              , identity zerod ]
  670    DoubleSubOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
  671                                              , rightIdentity zerod ]
  672    DoubleMulOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
  673                                              , identity oned
  674                                              , strengthReduction twod DoubleAddOp  ]
  675               -- zeroElem zerod doesn't hold because of NaN
  676    DoubleDivOp          -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
  677                                              , rightIdentity oned ]
  678    DoubleNegOp          -> mkPrimOpRule nm 1 [ unaryLit negOp
  679                                              , semiInversePrimOp DoubleNegOp ]
  680    DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]
  681 
  682    -- Relational operators, equality
  683 
  684    Int8EqOp   -> mkRelOpRule nm (==) [ litEq True ]
  685    Int8NeOp   -> mkRelOpRule nm (/=) [ litEq False ]
  686 
  687    Int16EqOp  -> mkRelOpRule nm (==) [ litEq True ]
  688    Int16NeOp  -> mkRelOpRule nm (/=) [ litEq False ]
  689 
  690    Int32EqOp  -> mkRelOpRule nm (==) [ litEq True ]
  691    Int32NeOp  -> mkRelOpRule nm (/=) [ litEq False ]
  692 
  693    IntEqOp    -> mkRelOpRule nm (==) [ litEq True ]
  694    IntNeOp    -> mkRelOpRule nm (/=) [ litEq False ]
  695 
  696    Word8EqOp  -> mkRelOpRule nm (==) [ litEq True ]
  697    Word8NeOp  -> mkRelOpRule nm (/=) [ litEq False ]
  698 
  699    Word16EqOp -> mkRelOpRule nm (==) [ litEq True ]
  700    Word16NeOp -> mkRelOpRule nm (/=) [ litEq False ]
  701 
  702    Word32EqOp -> mkRelOpRule nm (==) [ litEq True ]
  703    Word32NeOp -> mkRelOpRule nm (/=) [ litEq False ]
  704 
  705    WordEqOp   -> mkRelOpRule nm (==) [ litEq True ]
  706    WordNeOp   -> mkRelOpRule nm (/=) [ litEq False ]
  707 
  708    CharEqOp   -> mkRelOpRule nm (==) [ litEq True ]
  709    CharNeOp   -> mkRelOpRule nm (/=) [ litEq False ]
  710 
  711    FloatEqOp  -> mkFloatingRelOpRule nm (==)
  712    FloatNeOp  -> mkFloatingRelOpRule nm (/=)
  713 
  714    DoubleEqOp -> mkFloatingRelOpRule nm (==)
  715    DoubleNeOp -> mkFloatingRelOpRule nm (/=)
  716 
  717    -- Relational operators, ordering
  718 
  719    Int8GtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  720    Int8GeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  721    Int8LeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  722    Int8LtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  723 
  724    Int16GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  725    Int16GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  726    Int16LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  727    Int16LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  728 
  729    Int32GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  730    Int32GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  731    Int32LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  732    Int32LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  733 
  734    IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  735    IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  736    IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  737    IntLtOp    -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  738 
  739    Word8GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  740    Word8GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  741    Word8LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  742    Word8LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  743 
  744    Word16GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  745    Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  746    Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  747    Word16LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  748 
  749    Word32GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  750    Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  751    Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  752    Word32LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  753 
  754    WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  755    WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  756    WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  757    WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  758 
  759    CharGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]
  760    CharGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
  761    CharLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]
  762    CharLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]
  763 
  764    FloatGtOp  -> mkFloatingRelOpRule nm (>)
  765    FloatGeOp  -> mkFloatingRelOpRule nm (>=)
  766    FloatLeOp  -> mkFloatingRelOpRule nm (<=)
  767    FloatLtOp  -> mkFloatingRelOpRule nm (<)
  768 
  769    DoubleGtOp -> mkFloatingRelOpRule nm (>)
  770    DoubleGeOp -> mkFloatingRelOpRule nm (>=)
  771    DoubleLeOp -> mkFloatingRelOpRule nm (<=)
  772    DoubleLtOp -> mkFloatingRelOpRule nm (<)
  773 
  774    -- Misc
  775 
  776    AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]
  777 
  778    SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]
  779    SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]
  780 
  781    _          -> Nothing
  782 
  783 {-
  784 ************************************************************************
  785 *                                                                      *
  786 \subsection{Doing the business}
  787 *                                                                      *
  788 ************************************************************************
  789 -}
  790 
  791 -- useful shorthands
  792 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
  793 mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
  794 
  795 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
  796             -> [RuleM CoreExpr] -> Maybe CoreRule
  797 mkRelOpRule nm cmp extra
  798   = mkPrimOpRule nm 2 $
  799     binaryCmpLit cmp : equal_rule : extra
  800   where
  801         -- x `cmp` x does not depend on x, so
  802         -- compute it for the arbitrary value 'True'
  803         -- and use that result
  804     equal_rule = do { equalArgs
  805                     ; platform <- getPlatform
  806                     ; return (if cmp True True
  807                               then trueValInt  platform
  808                               else falseValInt platform) }
  809 
  810 {- Note [Rules for floating-point comparisons]
  811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  812 We need different rules for floating-point values because for floats
  813 it is not true that x = x (for NaNs); so we do not want the equal_rule
  814 rule that mkRelOpRule uses.
  815 
  816 Note also that, in the case of equality/inequality, we do /not/
  817 want to switch to a case-expression.  For example, we do not want
  818 to convert
  819    case (eqFloat# x 3.8#) of
  820      True -> this
  821      False -> that
  822 to
  823   case x of
  824     3.8#::Float# -> this
  825     _            -> that
  826 See #9238.  Reason: comparing floating-point values for equality
  827 delicate, and we don't want to implement that delicacy in the code for
  828 case expressions.  So we make it an invariant of Core that a case
  829 expression never scrutinises a Float# or Double#.
  830 
  831 This transformation is what the litEq rule does;
  832 see Note [The litEq rule: converting equality to case].
  833 So we /refrain/ from using litEq for mkFloatingRelOpRule.
  834 -}
  835 
  836 mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
  837                     -> Maybe CoreRule
  838 -- See Note [Rules for floating-point comparisons]
  839 mkFloatingRelOpRule nm cmp
  840   = mkPrimOpRule nm 2 [binaryCmpLit cmp]
  841 
  842 -- common constants
  843 zeroi, onei, zerow, onew :: Platform -> Literal
  844 zeroi platform = mkLitInt  platform 0
  845 onei  platform = mkLitInt  platform 1
  846 zerow platform = mkLitWord platform 0
  847 onew  platform = mkLitWord platform 1
  848 
  849 zeroI8, oneI8, zeroW8, oneW8 :: Literal
  850 zeroI8 = mkLitInt8  0
  851 oneI8  = mkLitInt8  1
  852 zeroW8 = mkLitWord8 0
  853 oneW8  = mkLitWord8 1
  854 
  855 zeroI16, oneI16, zeroW16, oneW16 :: Literal
  856 zeroI16 = mkLitInt16  0
  857 oneI16  = mkLitInt16  1
  858 zeroW16 = mkLitWord16 0
  859 oneW16  = mkLitWord16 1
  860 
  861 zeroI32, oneI32, zeroW32, oneW32 :: Literal
  862 zeroI32 = mkLitInt32  0
  863 oneI32  = mkLitInt32  1
  864 zeroW32 = mkLitWord32 0
  865 oneW32  = mkLitWord32 1
  866 
  867 zeroI64, oneI64, zeroW64, oneW64 :: Literal
  868 zeroI64 = mkLitInt64  0
  869 oneI64  = mkLitInt64  1
  870 zeroW64 = mkLitWord64 0
  871 oneW64  = mkLitWord64 1
  872 
  873 zerof, onef, twof, zerod, oned, twod :: Literal
  874 zerof = mkLitFloat 0.0
  875 onef  = mkLitFloat 1.0
  876 twof  = mkLitFloat 2.0
  877 zerod = mkLitDouble 0.0
  878 oned  = mkLitDouble 1.0
  879 twod  = mkLitDouble 2.0
  880 
  881 cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool)
  882       -> Literal -> Literal -> Maybe CoreExpr
  883 cmpOp platform cmp = go
  884   where
  885     done True  = Just $ trueValInt  platform
  886     done False = Just $ falseValInt platform
  887 
  888     -- These compares are at different types
  889     go (LitChar i1)   (LitChar i2)   = done (i1 `cmp` i2)
  890     go (LitFloat i1)  (LitFloat i2)  = done (i1 `cmp` i2)
  891     go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)
  892     go (LitNumber nt1 i1) (LitNumber nt2 i2)
  893       | nt1 /= nt2 = Nothing
  894       | otherwise  = done (i1 `cmp` i2)
  895     go _               _               = Nothing
  896 
  897 --------------------------
  898 
  899 negOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Negate
  900 negOp env = \case
  901    (LitFloat 0.0)  -> Nothing  -- can't represent -0.0 as a Rational
  902    (LitFloat f)    -> Just (mkFloatVal env (-f))
  903    (LitDouble 0.0) -> Nothing
  904    (LitDouble d)   -> Just (mkDoubleVal env (-d))
  905    (LitNumber nt i)
  906       | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i)))
  907    _ -> Nothing
  908 
  909 complementOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Binary complement
  910 complementOp env (LitNumber nt i) =
  911    Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i)))
  912 complementOp _      _            = Nothing
  913 
  914 int8Op2
  915   :: (Integral a, Integral b)
  916   => (a -> b -> Integer)
  917   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  918 int8Op2 op _ (LitNumber LitNumInt8 i1) (LitNumber LitNumInt8 i2) =
  919   int8Result (fromInteger i1 `op` fromInteger i2)
  920 int8Op2 _ _ _ _ = Nothing
  921 
  922 int16Op2
  923   :: (Integral a, Integral b)
  924   => (a -> b -> Integer)
  925   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  926 int16Op2 op _ (LitNumber LitNumInt16 i1) (LitNumber LitNumInt16 i2) =
  927   int16Result (fromInteger i1 `op` fromInteger i2)
  928 int16Op2 _ _ _ _ = Nothing
  929 
  930 int32Op2
  931   :: (Integral a, Integral b)
  932   => (a -> b -> Integer)
  933   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  934 int32Op2 op _ (LitNumber LitNumInt32 i1) (LitNumber LitNumInt32 i2) =
  935   int32Result (fromInteger i1 `op` fromInteger i2)
  936 int32Op2 _ _ _ _ = Nothing
  937 
  938 int64Op2
  939   :: (Integral a, Integral b)
  940   => (a -> b -> Integer)
  941   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  942 int64Op2 op _ (LitNumber LitNumInt64 i1) (LitNumber LitNumInt64 i2) =
  943   int64Result (fromInteger i1 `op` fromInteger i2)
  944 int64Op2 _ _ _ _ = Nothing
  945 
  946 intOp2 :: (Integral a, Integral b)
  947        => (a -> b -> Integer)
  948        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  949 intOp2 = intOp2' . const
  950 
  951 intOp2' :: (Integral a, Integral b)
  952         => (RuleOpts -> a -> b -> Integer)
  953         -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  954 intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =
  955   let o = op env
  956   in  intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2)
  957 intOp2' _ _ _ _ = Nothing
  958 
  959 intOpC2 :: (Integral a, Integral b)
  960         => (a -> b -> Integer)
  961         -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  962 intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =
  963   intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2)
  964 intOpC2 _ _ _ _ = Nothing
  965 
  966 shiftRightLogical :: forall t. (Integral t, Bits t) => Integer -> Int -> Integer
  967 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: t)
  968 
  969 -- | Shift right, putting zeros in rather than sign-propagating as
  970 -- 'Bits.shiftR' would do. Do this by converting to the appropriate Word
  971 -- and back. Obviously this won't work for too-big values, but its ok as
  972 -- we use it here.
  973 shiftRightLogicalNative :: Platform -> Integer -> Int -> Integer
  974 shiftRightLogicalNative platform =
  975     case platformWordSize platform of
  976       PW4 -> shiftRightLogical @Word32
  977       PW8 -> shiftRightLogical @Word64
  978 
  979 --------------------------
  980 retLit :: (Platform -> Literal) -> RuleM CoreExpr
  981 retLit l = do platform <- getPlatform
  982               return $ Lit $ l platform
  983 
  984 retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr
  985 retLitNoC l = do platform <- getPlatform
  986                  let lit = l platform
  987                  let ty = literalType lit
  988                  return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)]
  989 
  990 word8Op2
  991   :: (Integral a, Integral b)
  992   => (a -> b -> Integer)
  993   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
  994 word8Op2 op _ (LitNumber LitNumWord8 i1) (LitNumber LitNumWord8 i2) =
  995   word8Result (fromInteger i1 `op` fromInteger i2)
  996 word8Op2 _ _ _ _ = Nothing
  997 
  998 word16Op2
  999   :: (Integral a, Integral b)
 1000   => (a -> b -> Integer)
 1001   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
 1002 word16Op2 op _ (LitNumber LitNumWord16 i1) (LitNumber LitNumWord16 i2) =
 1003   word16Result (fromInteger i1 `op` fromInteger i2)
 1004 word16Op2 _ _ _ _ = Nothing
 1005 
 1006 word32Op2
 1007   :: (Integral a, Integral b)
 1008   => (a -> b -> Integer)
 1009   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
 1010 word32Op2 op _ (LitNumber LitNumWord32 i1) (LitNumber LitNumWord32 i2) =
 1011   word32Result (fromInteger i1 `op` fromInteger i2)
 1012 word32Op2 _ _ _ _ = Nothing
 1013 
 1014 word64Op2
 1015   :: (Integral a, Integral b)
 1016   => (a -> b -> Integer)
 1017   -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
 1018 word64Op2 op _ (LitNumber LitNumWord64 i1) (LitNumber LitNumWord64 i2) =
 1019   word64Result (fromInteger i1 `op` fromInteger i2)
 1020 word64Op2 _ _ _ _ = Nothing
 1021 
 1022 wordOp2 :: (Integral a, Integral b)
 1023         => (a -> b -> Integer)
 1024         -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
 1025 wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2)
 1026     = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)
 1027 wordOp2 _ _ _ _ = Nothing
 1028 
 1029 wordOpC2 :: (Integral a, Integral b)
 1030         => (a -> b -> Integer)
 1031         -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
 1032 wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) =
 1033   wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)
 1034 wordOpC2 _ _ _ _ = Nothing
 1035 
 1036 shiftRule :: LitNumType
 1037           -> (Platform -> Integer -> Int -> Integer)
 1038           -> RuleM CoreExpr
 1039 -- Shifts take an Int; hence third arg of op is Int
 1040 -- Used for shift primops
 1041 --    IntSllOp, IntSraOp, IntSrlOp :: Int# -> Int# -> Int#
 1042 --    SllOp, SrlOp                 :: Word# -> Int# -> Word#
 1043 shiftRule lit_num_ty shift_op = do
 1044   platform <- getPlatform
 1045   [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs
 1046 
 1047   bit_size <- case litNumBitSize platform lit_num_ty of
 1048    Nothing -> mzero
 1049    Just bs -> pure (toInteger bs)
 1050 
 1051   case e1 of
 1052     _ | shift_len == 0 -> pure e1
 1053 
 1054       -- See Note [Guarding against silly shifts]
 1055     _ | shift_len < 0 || shift_len > bit_size
 1056       -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0
 1057            -- Be sure to use lit_num_ty here, so we get a correctly typed zero.
 1058            -- See #18589
 1059 
 1060     Lit (LitNumber nt x)
 1061        | 0 < shift_len && shift_len <= bit_size
 1062        -> assert (nt == lit_num_ty) $
 1063           let op = shift_op platform
 1064               -- Do the shift at type Integer, but shift length is Int.
 1065               -- Using host's Int is ok even if target's Int has a different size
 1066               -- because we test that shift_len <= bit_size (which is at most 64)
 1067               y  = x `op` fromInteger shift_len
 1068           in pure $ Lit $ mkLitNumberWrap platform nt y
 1069 
 1070     _ -> mzero
 1071 
 1072 --------------------------
 1073 floatOp2 :: (Rational -> Rational -> Rational)
 1074          -> RuleOpts -> Literal -> Literal
 1075          -> Maybe (Expr CoreBndr)
 1076 floatOp2 op env (LitFloat f1) (LitFloat f2)
 1077   = Just (mkFloatVal env (f1 `op` f2))
 1078 floatOp2 _ _ _ _ = Nothing
 1079 
 1080 --------------------------
 1081 floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
 1082 floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e)))
 1083   = Just $ mkCoreUbxTup [intPrimTy, intPrimTy]
 1084                         [ mkIntVal (roPlatform env) (toInteger m)
 1085                         , mkIntVal (roPlatform env) (toInteger e) ]
 1086 floatDecodeOp _   _
 1087   = Nothing
 1088 
 1089 --------------------------
 1090 doubleOp2 :: (Rational -> Rational -> Rational)
 1091           -> RuleOpts -> Literal -> Literal
 1092           -> Maybe (Expr CoreBndr)
 1093 doubleOp2 op env (LitDouble f1) (LitDouble f2)
 1094   = Just (mkDoubleVal env (f1 `op` f2))
 1095 doubleOp2 _ _ _ _ = Nothing
 1096 
 1097 --------------------------
 1098 doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
 1099 doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))
 1100   = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]
 1101                         [ Lit (mkLitINT64 (toInteger m))
 1102                         , mkIntVal platform (toInteger e) ]
 1103   where
 1104     platform = roPlatform env
 1105     (iNT64Ty, mkLitINT64)
 1106       | platformWordSizeInBits platform < 64
 1107       = (int64PrimTy, mkLitInt64Wrap)
 1108       | otherwise
 1109       = (intPrimTy  , mkLitIntWrap platform)
 1110 doubleDecodeOp _   _
 1111   = Nothing
 1112 
 1113 --------------------------
 1114 {- Note [The litEq rule: converting equality to case]
 1115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1116 This stuff turns
 1117      n ==# 3#
 1118 into
 1119      case n of
 1120        3# -> True
 1121        m  -> False
 1122 
 1123 This is a Good Thing, because it allows case-of case things
 1124 to happen, and case-default absorption to happen.  For
 1125 example:
 1126 
 1127      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 1128 will transform to
 1129      case n of
 1130        3# -> e1
 1131        4# -> e1
 1132        m  -> e2
 1133 (modulo the usual precautions to avoid duplicating e1)
 1134 -}
 1135 
 1136 litEq :: Bool  -- True <=> equality, False <=> inequality
 1137       -> RuleM CoreExpr
 1138 litEq is_eq = msum
 1139   [ do [Lit lit, expr] <- getArgs
 1140        platform <- getPlatform
 1141        do_lit_eq platform lit expr
 1142   , do [expr, Lit lit] <- getArgs
 1143        platform <- getPlatform
 1144        do_lit_eq platform lit expr ]
 1145   where
 1146     do_lit_eq platform lit expr = do
 1147       guard (not (litIsLifted lit))
 1148       return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy
 1149                     [ Alt DEFAULT      [] val_if_neq
 1150                     , Alt (LitAlt lit) [] val_if_eq])
 1151       where
 1152         val_if_eq  | is_eq     = trueValInt  platform
 1153                    | otherwise = falseValInt platform
 1154         val_if_neq | is_eq     = falseValInt platform
 1155                    | otherwise = trueValInt  platform
 1156 
 1157 
 1158 -- | Check if there is comparison with minBound or maxBound, that is
 1159 -- always true or false. For instance, an Int cannot be smaller than its
 1160 -- minBound, so we can replace such comparison with False.
 1161 boundsCmp :: Comparison -> RuleM CoreExpr
 1162 boundsCmp op = do
 1163   platform <- getPlatform
 1164   [a, b] <- getArgs
 1165   liftMaybe $ mkRuleFn platform op a b
 1166 
 1167 data Comparison = Gt | Ge | Lt | Le
 1168 
 1169 mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
 1170 mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform
 1171 mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt  platform
 1172 mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt  platform
 1173 mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform
 1174 mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt  platform
 1175 mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform
 1176 mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform
 1177 mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt  platform
 1178 mkRuleFn _ _ _ _                                           = Nothing
 1179 
 1180 -- | Create an Int literal expression while ensuring the given Integer is in the
 1181 -- target Int range
 1182 int8Result :: Integer -> Maybe CoreExpr
 1183 int8Result result = Just (int8Result' result)
 1184 
 1185 int8Result' :: Integer -> CoreExpr
 1186 int8Result' result = Lit (mkLitInt8Wrap result)
 1187 
 1188 -- | Create an Int literal expression while ensuring the given Integer is in the
 1189 -- target Int range
 1190 int16Result :: Integer -> Maybe CoreExpr
 1191 int16Result result = Just (int16Result' result)
 1192 
 1193 int16Result' :: Integer -> CoreExpr
 1194 int16Result' result = Lit (mkLitInt16Wrap result)
 1195 
 1196 -- | Create an Int literal expression while ensuring the given Integer is in the
 1197 -- target Int range
 1198 int32Result :: Integer -> Maybe CoreExpr
 1199 int32Result result = Just (int32Result' result)
 1200 
 1201 int32Result' :: Integer -> CoreExpr
 1202 int32Result' result = Lit (mkLitInt32Wrap result)
 1203 
 1204 intResult :: Platform -> Integer -> Maybe CoreExpr
 1205 intResult platform result = Just (intResult' platform result)
 1206 
 1207 intResult' :: Platform -> Integer -> CoreExpr
 1208 intResult' platform result = Lit (mkLitIntWrap platform result)
 1209 
 1210 -- | Create an unboxed pair of an Int literal expression, ensuring the given
 1211 -- Integer is in the target Int range and the corresponding overflow flag
 1212 -- (@0#@/@1#@) if it wasn't.
 1213 intCResult :: Platform -> Integer -> Maybe CoreExpr
 1214 intCResult platform result = Just (mkPair [Lit lit, Lit c])
 1215   where
 1216     mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
 1217     (lit, b) = mkLitIntWrapC platform result
 1218     c = if b then onei platform else zeroi platform
 1219 
 1220 -- | Create a Word literal expression while ensuring the given Integer is in the
 1221 -- target Word range
 1222 word8Result :: Integer -> Maybe CoreExpr
 1223 word8Result result = Just (word8Result' result)
 1224 
 1225 word8Result' :: Integer -> CoreExpr
 1226 word8Result' result = Lit (mkLitWord8Wrap result)
 1227 
 1228 -- | Create a Word literal expression while ensuring the given Integer is in the
 1229 -- target Word range
 1230 word16Result :: Integer -> Maybe CoreExpr
 1231 word16Result result = Just (word16Result' result)
 1232 
 1233 word16Result' :: Integer -> CoreExpr
 1234 word16Result' result = Lit (mkLitWord16Wrap result)
 1235 
 1236 -- | Create a Word literal expression while ensuring the given Integer is in the
 1237 -- target Word range
 1238 word32Result :: Integer -> Maybe CoreExpr
 1239 word32Result result = Just (word32Result' result)
 1240 
 1241 word32Result' :: Integer -> CoreExpr
 1242 word32Result' result = Lit (mkLitWord32Wrap result)
 1243 
 1244 -- | Create a Word literal expression while ensuring the given Integer is in the
 1245 -- target Word range
 1246 wordResult :: Platform -> Integer -> Maybe CoreExpr
 1247 wordResult platform result = Just (wordResult' platform result)
 1248 
 1249 wordResult' :: Platform -> Integer -> CoreExpr
 1250 wordResult' platform result = Lit (mkLitWordWrap platform result)
 1251 
 1252 -- | Create an unboxed pair of a Word literal expression, ensuring the given
 1253 -- Integer is in the target Word range and the corresponding carry flag
 1254 -- (@0#@/@1#@) if it wasn't.
 1255 wordCResult :: Platform -> Integer -> Maybe CoreExpr
 1256 wordCResult platform result = Just (mkPair [Lit lit, Lit c])
 1257   where
 1258     mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
 1259     (lit, b) = mkLitWordWrapC platform result
 1260     c = if b then onei platform else zeroi platform
 1261 
 1262 int64Result :: Integer -> Maybe CoreExpr
 1263 int64Result result = Just (int64Result' result)
 1264 
 1265 int64Result' :: Integer -> CoreExpr
 1266 int64Result' result = Lit (mkLitInt64Wrap result)
 1267 
 1268 word64Result :: Integer -> Maybe CoreExpr
 1269 word64Result result = Just (word64Result' result)
 1270 
 1271 word64Result' :: Integer -> CoreExpr
 1272 word64Result' result = Lit (mkLitWord64Wrap result)
 1273 
 1274 
 1275 -- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'.
 1276 semiInversePrimOp :: PrimOp -> RuleM CoreExpr
 1277 semiInversePrimOp primop = do
 1278   [Var primop_id `App` e] <- getArgs
 1279   matchPrimOpId primop primop_id
 1280   return e
 1281 
 1282 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
 1283 this `subsumesPrimOp` that = do
 1284   [Var primop_id `App` e] <- getArgs
 1285   matchPrimOpId that primop_id
 1286   return (Var (mkPrimOpId this) `App` e)
 1287 
 1288 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
 1289 subsumedByPrimOp primop = do
 1290   [e@(Var primop_id `App` _)] <- getArgs
 1291   matchPrimOpId primop primop_id
 1292   return e
 1293 
 1294 -- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF`
 1295 extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr
 1296 extendNarrowPassthrough narrow_primop n = do
 1297   [Var primop_id `App` x] <- getArgs
 1298   matchPrimOpId narrow_primop primop_id
 1299   return (Var (mkPrimOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n))
 1300 
 1301 -- | narrow subsumes bitwise `and` with full mask (cf #16402):
 1302 --
 1303 --       narrowN (x .&. m)
 1304 --       m .&. (2^N-1) = 2^N-1
 1305 --       ==> narrowN x
 1306 --
 1307 -- e.g.  narrow16 (x .&. 0xFFFF)
 1308 --       ==> narrow16 x
 1309 --
 1310 narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr
 1311 narrowSubsumesAnd and_primop narrw n = do
 1312   [Var primop_id `App` x `App` y] <- getArgs
 1313   matchPrimOpId and_primop primop_id
 1314   let mask = bit n -1
 1315       g v (Lit (LitNumber _ m)) = do
 1316          guard (m .&. mask == mask)
 1317          return (Var (mkPrimOpId narrw) `App` v)
 1318       g _ _ = mzero
 1319   g x y <|> g y x
 1320 
 1321 idempotent :: RuleM CoreExpr
 1322 idempotent = do [e1, e2] <- getArgs
 1323                 guard $ cheapEqExpr e1 e2
 1324                 return e1
 1325 
 1326 -- | Match
 1327 --       (op (op v e) e)
 1328 --    or (op e (op v e))
 1329 --    or (op (op e v) e)
 1330 --    or (op e (op e v))
 1331 --  and return the innermost (op v e) or (op e v).
 1332 sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr
 1333 sameArgIdempotentCommut op = do
 1334   [a,b] <- getArgs
 1335   case (a,b) of
 1336     (is_binop op -> Just (e1,e2), e3)
 1337       | cheapEqExpr e2 e3 -> return a
 1338       | cheapEqExpr e1 e3 -> return a
 1339     (e3, is_binop op -> Just (e1,e2))
 1340       | cheapEqExpr e2 e3 -> return b
 1341       | cheapEqExpr e1 e3 -> return b
 1342     _ -> mzero
 1343 
 1344 {-
 1345 Note [Guarding against silly shifts]
 1346 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1347 Consider this code:
 1348 
 1349   import Data.Bits( (.|.), shiftL )
 1350   chunkToBitmap :: [Bool] -> Word32
 1351   chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
 1352 
 1353 This optimises to:
 1354 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
 1355     case w1_sCT of _ {
 1356       [] -> 0##;
 1357       : x_aAW xs_aAX ->
 1358         case x_aAW of _ {
 1359           GHC.Types.False ->
 1360             case w_sCS of wild2_Xh {
 1361               __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
 1362               9223372036854775807 -> 0## };
 1363           GHC.Types.True ->
 1364             case GHC.Prim.>=# w_sCS 64 of _ {
 1365               GHC.Types.False ->
 1366                 case w_sCS of wild3_Xh {
 1367                   __DEFAULT ->
 1368                     case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
 1369                       GHC.Prim.or# (GHC.Prim.narrow32Word#
 1370                                       (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
 1371                                    ww_sCW
 1372                      };
 1373                   9223372036854775807 ->
 1374                     GHC.Prim.narrow32Word#
 1375 !!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
 1376                 };
 1377               GHC.Types.True ->
 1378                 case w_sCS of wild3_Xh {
 1379                   __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
 1380                   9223372036854775807 -> 0##
 1381                 } } } }
 1382 
 1383 Note the massive shift on line "!!!!".  It can't happen, because we've checked
 1384 that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!
 1385 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
 1386 can't constant fold it, but if it gets to the assembler we get
 1387      Error: operand type mismatch for `shl'
 1388 
 1389 So the best thing to do is to rewrite the shift with a call to error,
 1390 when the second arg is large. However, in general we cannot do this; consider
 1391 this case
 1392 
 1393     let x = I# (uncheckedIShiftL# n 80)
 1394     in ...
 1395 
 1396 Here x contains an invalid shift and consequently we would like to rewrite it
 1397 as follows:
 1398 
 1399     let x = I# (error "invalid shift)
 1400     in ...
 1401 
 1402 This was originally done in the fix to #16449 but this breaks the let/app
 1403 invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.
 1404 For the reasons discussed in Note [Checking versus non-checking primops] (in
 1405 the PrimOp module) there is no safe way rewrite the argument of I# such that
 1406 it bottoms.
 1407 
 1408 Consequently we instead take advantage of the fact that large shifts are
 1409 undefined behavior (see associated documentation in primops.txt.pp) and
 1410 transform the invalid shift into an "obviously incorrect" value.
 1411 
 1412 There are two cases:
 1413 
 1414 - Shifting fixed-width things: the primops IntSll, Sll, etc
 1415   These are handled by shiftRule.
 1416 
 1417   We are happy to shift by any amount up to wordSize but no more.
 1418 
 1419 - Shifting Bignums (Integer, Natural): these are handled by bignum_shift.
 1420 
 1421   Here we could in principle shift by any amount, but we arbitrary
 1422   limit the shift to 4 bits; in particular we do not want shift by a
 1423   huge amount, which can happen in code like that above.
 1424 
 1425 The two cases are more different in their code paths that is comfortable,
 1426 but that is only a historical accident.
 1427 
 1428 
 1429 ************************************************************************
 1430 *                                                                      *
 1431 \subsection{Vaguely generic functions}
 1432 *                                                                      *
 1433 ************************************************************************
 1434 -}
 1435 
 1436 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
 1437 -- Gives the Rule the same name as the primop itself
 1438 mkBasicRule op_name n_args rm
 1439   = BuiltinRule { ru_name  = occNameFS (nameOccName op_name),
 1440                   ru_fn    = op_name,
 1441                   ru_nargs = n_args,
 1442                   ru_try   = runRuleM rm }
 1443 
 1444 newtype RuleM r = RuleM
 1445   { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r }
 1446   deriving (Functor)
 1447 
 1448 instance Applicative RuleM where
 1449     pure x = RuleM $ \_ _ _ _ -> Just x
 1450     (<*>) = ap
 1451 
 1452 instance Monad RuleM where
 1453   RuleM f >>= g
 1454     = RuleM $ \env iu fn args ->
 1455               case f env iu fn args of
 1456                 Nothing -> Nothing
 1457                 Just r  -> runRuleM (g r) env iu fn args
 1458 
 1459 instance MonadFail RuleM where
 1460     fail _ = mzero
 1461 
 1462 instance Alternative RuleM where
 1463   empty = RuleM $ \_ _ _ _ -> Nothing
 1464   RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args ->
 1465     f1 env iu fn args <|> f2 env iu fn args
 1466 
 1467 instance MonadPlus RuleM
 1468 
 1469 getPlatform :: RuleM Platform
 1470 getPlatform = roPlatform <$> getRuleOpts
 1471 
 1472 getWordSize :: RuleM PlatformWordSize
 1473 getWordSize = platformWordSize <$> getPlatform
 1474 
 1475 getRuleOpts :: RuleM RuleOpts
 1476 getRuleOpts = RuleM $ \rule_opts _ _ _ -> Just rule_opts
 1477 
 1478 liftMaybe :: Maybe a -> RuleM a
 1479 liftMaybe Nothing = mzero
 1480 liftMaybe (Just x) = return x
 1481 
 1482 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
 1483 liftLit f = liftLitPlatform (const f)
 1484 
 1485 liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr
 1486 liftLitPlatform f = do
 1487   platform <- getPlatform
 1488   [Lit lit] <- getArgs
 1489   return $ Lit (f platform lit)
 1490 
 1491 removeOp32 :: RuleM CoreExpr
 1492 removeOp32 = do
 1493   platform <- getPlatform
 1494   case platformWordSize platform of
 1495     PW4 -> do
 1496       [e] <- getArgs
 1497       return e
 1498     PW8 ->
 1499       mzero
 1500 
 1501 getArgs :: RuleM [CoreExpr]
 1502 getArgs = RuleM $ \_ _ _ args -> Just args
 1503 
 1504 getInScopeEnv :: RuleM InScopeEnv
 1505 getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu
 1506 
 1507 getFunction :: RuleM Id
 1508 getFunction = RuleM $ \_ _ fn _ -> Just fn
 1509 
 1510 isLiteral :: CoreExpr -> RuleM Literal
 1511 isLiteral e = do
 1512     env <- getInScopeEnv
 1513     case exprIsLiteral_maybe env e of
 1514         Nothing -> mzero
 1515         Just l  -> pure l
 1516 
 1517 -- | Match BigNat#, Integer and Natural literals
 1518 isBignumLiteral :: CoreExpr -> RuleM Integer
 1519 isBignumLiteral e = isNumberLiteral e <|> isIntegerLiteral e <|> isNaturalLiteral e
 1520 
 1521 -- | Match numeric literals
 1522 isNumberLiteral :: CoreExpr -> RuleM Integer
 1523 isNumberLiteral e = isLiteral e >>= \case
 1524   LitNumber _ x -> pure x
 1525   _             -> mzero
 1526 
 1527 -- | Match the application of a DataCon to a numeric literal.
 1528 --
 1529 -- Can be used to match e.g.:
 1530 --  IS 123#
 1531 --  IP bigNatLiteral
 1532 --  W# 123##
 1533 isLitNumConApp :: CoreExpr -> RuleM (DataCon,Integer)
 1534 isLitNumConApp e = do
 1535   env <- getInScopeEnv
 1536   case exprIsConApp_maybe env e of
 1537     Just (_env,_fb,dc,_tys,[arg]) -> case exprIsLiteral_maybe env arg of
 1538       Just (LitNumber _ i) -> pure (dc,i)
 1539       _                    -> mzero
 1540     _ -> mzero
 1541 
 1542 isIntegerLiteral :: CoreExpr -> RuleM Integer
 1543 isIntegerLiteral e = do
 1544   (dc,i) <- isLitNumConApp e
 1545   if | dc == integerISDataCon -> pure i
 1546      | dc == integerINDataCon -> pure (negate i)
 1547      | dc == integerIPDataCon -> pure i
 1548      | otherwise              -> mzero
 1549 
 1550 isBigIntegerLiteral :: CoreExpr -> RuleM Integer
 1551 isBigIntegerLiteral e = do
 1552   (dc,i) <- isLitNumConApp e
 1553   if | dc == integerINDataCon -> pure (negate i)
 1554      | dc == integerIPDataCon -> pure i
 1555      | otherwise              -> mzero
 1556 
 1557 isNaturalLiteral :: CoreExpr -> RuleM Integer
 1558 isNaturalLiteral e = do
 1559   (dc,i) <- isLitNumConApp e
 1560   if | dc == naturalNSDataCon -> pure i
 1561      | dc == naturalNBDataCon -> pure i
 1562      | otherwise              -> mzero
 1563 
 1564 -- return the n-th argument of this rule, if it is a literal
 1565 -- argument indices start from 0
 1566 getLiteral :: Int -> RuleM Literal
 1567 getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of
 1568   (Lit l:_) -> Just l
 1569   _ -> Nothing
 1570 
 1571 unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
 1572 unaryLit op = do
 1573   env <- getRuleOpts
 1574   [Lit l] <- getArgs
 1575   liftMaybe $ op env (convFloating env l)
 1576 
 1577 binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
 1578 binaryLit op = do
 1579   env <- getRuleOpts
 1580   [Lit l1, Lit l2] <- getArgs
 1581   liftMaybe $ op env (convFloating env l1) (convFloating env l2)
 1582 
 1583 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
 1584 binaryCmpLit op = do
 1585   platform <- getPlatform
 1586   binaryLit (\_ -> cmpOp platform op)
 1587 
 1588 leftIdentity :: Literal -> RuleM CoreExpr
 1589 leftIdentity id_lit = leftIdentityPlatform (const id_lit)
 1590 
 1591 rightIdentity :: Literal -> RuleM CoreExpr
 1592 rightIdentity id_lit = rightIdentityPlatform (const id_lit)
 1593 
 1594 identity :: Literal -> RuleM CoreExpr
 1595 identity lit = leftIdentity lit `mplus` rightIdentity lit
 1596 
 1597 leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
 1598 leftIdentityPlatform id_lit = do
 1599   platform <- getPlatform
 1600   [Lit l1, e2] <- getArgs
 1601   guard $ l1 == id_lit platform
 1602   return e2
 1603 
 1604 -- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
 1605 -- addition to the result, we have to indicate that no carry/overflow occurred.
 1606 leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
 1607 leftIdentityCPlatform id_lit = do
 1608   platform <- getPlatform
 1609   [Lit l1, e2] <- getArgs
 1610   guard $ l1 == id_lit platform
 1611   let no_c = Lit (zeroi platform)
 1612   return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])
 1613 
 1614 rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
 1615 rightIdentityPlatform id_lit = do
 1616   platform <- getPlatform
 1617   [e1, Lit l2] <- getArgs
 1618   guard $ l2 == id_lit platform
 1619   return e1
 1620 
 1621 -- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
 1622 -- addition to the result, we have to indicate that no carry/overflow occurred.
 1623 rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
 1624 rightIdentityCPlatform id_lit = do
 1625   platform <- getPlatform
 1626   [e1, Lit l2] <- getArgs
 1627   guard $ l2 == id_lit platform
 1628   let no_c = Lit (zeroi platform)
 1629   return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])
 1630 
 1631 identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
 1632 identityPlatform lit =
 1633   leftIdentityPlatform lit `mplus` rightIdentityPlatform lit
 1634 
 1635 -- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
 1636 -- to the result, we have to indicate that no carry/overflow occurred.
 1637 identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
 1638 identityCPlatform lit =
 1639   leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit
 1640 
 1641 leftZero :: RuleM CoreExpr
 1642 leftZero = do
 1643   [Lit l1, _] <- getArgs
 1644   guard $ isZeroLit l1
 1645   return $ Lit l1
 1646 
 1647 rightZero :: RuleM CoreExpr
 1648 rightZero = do
 1649   [_, Lit l2] <- getArgs
 1650   guard $ isZeroLit l2
 1651   return $ Lit l2
 1652 
 1653 zeroElem :: RuleM CoreExpr
 1654 zeroElem = leftZero `mplus` rightZero
 1655 
 1656 equalArgs :: RuleM ()
 1657 equalArgs = do
 1658   [e1, e2] <- getArgs
 1659   guard $ e1 `cheapEqExpr` e2
 1660 
 1661 nonZeroLit :: Int -> RuleM ()
 1662 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
 1663 
 1664 oneLit :: Int -> RuleM ()
 1665 oneLit n = getLiteral n >>= guard . isOneLit
 1666 
 1667 lift_bits_op :: forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr
 1668 lift_bits_op op = do
 1669   platform <- getPlatform
 1670   [Lit (LitNumber _ l)] <- getArgs
 1671   pure $ mkWordLit platform $ op (fromInteger l :: a)
 1672 
 1673 pop_count :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
 1674 pop_count = lift_bits_op @a (fromIntegral . popCount)
 1675 
 1676 ctz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
 1677 ctz = lift_bits_op @a (fromIntegral . countTrailingZeros)
 1678 
 1679 clz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
 1680 clz = lift_bits_op @a (fromIntegral . countLeadingZeros)
 1681 
 1682 -- When excess precision is not requested, cut down the precision of the
 1683 -- Rational value to that of Float/Double. We confuse host architecture
 1684 -- and target architecture here, but it's convenient (and wrong :-).
 1685 convFloating :: RuleOpts -> Literal -> Literal
 1686 convFloating env (LitFloat  f) | not (roExcessRationalPrecision env) =
 1687    LitFloat  (toRational (fromRational f :: Float ))
 1688 convFloating env (LitDouble d) | not (roExcessRationalPrecision env) =
 1689    LitDouble (toRational (fromRational d :: Double))
 1690 convFloating _ l = l
 1691 
 1692 guardFloatDiv :: RuleM ()
 1693 guardFloatDiv = do
 1694   [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs
 1695   guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
 1696        && f2 /= 0            -- avoid NaN and Infinity/-Infinity
 1697 
 1698 guardDoubleDiv :: RuleM ()
 1699 guardDoubleDiv = do
 1700   [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs
 1701   guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
 1702        && d2 /= 0            -- avoid NaN and Infinity/-Infinity
 1703 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
 1704 -- zero, but we might want to preserve the negative zero here which
 1705 -- is representable in Float/Double but not in (normalised)
 1706 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
 1707 
 1708 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
 1709 strengthReduction two_lit add_op = do -- Note [Strength reduction]
 1710   arg <- msum [ do [arg, Lit mult_lit] <- getArgs
 1711                    guard (mult_lit == two_lit)
 1712                    return arg
 1713               , do [Lit mult_lit, arg] <- getArgs
 1714                    guard (mult_lit == two_lit)
 1715                    return arg ]
 1716   return $ Var (mkPrimOpId add_op) `App` arg `App` arg
 1717 
 1718 -- Note [Strength reduction]
 1719 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
 1720 --
 1721 -- This rule turns floating point multiplications of the form 2.0 * x and
 1722 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
 1723 -- See #7116
 1724 
 1725 -- Note [What's true and false]
 1726 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1727 --
 1728 -- trueValInt and falseValInt represent true and false values returned by
 1729 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
 1730 -- True is represented as an unboxed 1# literal, while false is represented
 1731 -- as 0# literal.
 1732 -- We still need Bool data constructors (True and False) to use in a rule
 1733 -- for constant folding of equal Strings
 1734 
 1735 trueValInt, falseValInt :: Platform -> Expr CoreBndr
 1736 trueValInt  platform = Lit $ onei  platform -- see Note [What's true and false]
 1737 falseValInt platform = Lit $ zeroi platform
 1738 
 1739 trueValBool, falseValBool :: Expr CoreBndr
 1740 trueValBool   = Var trueDataConId -- see Note [What's true and false]
 1741 falseValBool  = Var falseDataConId
 1742 
 1743 ltVal, eqVal, gtVal :: Expr CoreBndr
 1744 ltVal = Var ordLTDataConId
 1745 eqVal = Var ordEQDataConId
 1746 gtVal = Var ordGTDataConId
 1747 
 1748 mkIntVal :: Platform -> Integer -> Expr CoreBndr
 1749 mkIntVal platform i = Lit (mkLitInt platform i)
 1750 mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr
 1751 mkFloatVal env f = Lit (convFloating env (LitFloat  f))
 1752 mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr
 1753 mkDoubleVal env d = Lit (convFloating env (LitDouble d))
 1754 
 1755 matchPrimOpId :: PrimOp -> Id -> RuleM ()
 1756 matchPrimOpId op id = do
 1757   op' <- liftMaybe $ isPrimOpId_maybe id
 1758   guard $ op == op'
 1759 
 1760 {-
 1761 ************************************************************************
 1762 *                                                                      *
 1763 \subsection{Special rules for seq, tagToEnum, dataToTag}
 1764 *                                                                      *
 1765 ************************************************************************
 1766 
 1767 Note [tagToEnum#]
 1768 ~~~~~~~~~~~~~~~~~
 1769 Nasty check to ensure that tagToEnum# is applied to a type that is an
 1770 enumeration TyCon.  Unification may refine the type later, but this
 1771 check won't see that, alas.  It's crude but it works.
 1772 
 1773 Here's are two cases that should fail
 1774         f :: forall a. a
 1775         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
 1776 
 1777         g :: Int
 1778         g = tagToEnum# 0        -- Int is not an enumeration
 1779 
 1780 We used to make this check in the type inference engine, but it's quite
 1781 ugly to do so, because the delayed constraint solving means that we don't
 1782 really know what's going on until the end. It's very much a corner case
 1783 because we don't expect the user to call tagToEnum# at all; we merely
 1784 generate calls in derived instances of Enum.  So we compromise: a
 1785 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
 1786 and emits a warning.
 1787 -}
 1788 
 1789 tagToEnumRule :: RuleM CoreExpr
 1790 -- If     data T a = A | B | C
 1791 -- then   tagToEnum# (T ty) 2# -->  B ty
 1792 tagToEnumRule = do
 1793   [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs
 1794   case splitTyConApp_maybe ty of
 1795     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
 1796       let tag = fromInteger i
 1797           correct_tag dc = (dataConTagZ dc) == tag
 1798       (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
 1799       massert (null rest)
 1800       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
 1801 
 1802     -- See Note [tagToEnum#]
 1803     _ -> warnPprTrace True (text "tagToEnum# on non-enumeration type" <+> ppr ty) $
 1804          return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
 1805 
 1806 ------------------------------
 1807 dataToTagRule :: RuleM CoreExpr
 1808 -- See Note [dataToTag#] in primops.txt.pp
 1809 dataToTagRule = a `mplus` b
 1810   where
 1811     -- dataToTag (tagToEnum x)   ==>   x
 1812     a = do
 1813       [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
 1814       guard $ tag_to_enum `hasKey` tagToEnumKey
 1815       guard $ ty1 `eqType` ty2
 1816       return tag
 1817 
 1818     -- dataToTag (K e1 e2)  ==>   tag-of K
 1819     -- This also works (via exprIsConApp_maybe) for
 1820     --   dataToTag x
 1821     -- where x's unfolding is a constructor application
 1822     b = do
 1823       dflags <- getPlatform
 1824       [_, val_arg] <- getArgs
 1825       in_scope <- getInScopeEnv
 1826       (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
 1827       massert (not (isNewTyCon (dataConTyCon dc)))
 1828       return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))
 1829 
 1830 {- Note [dataToTag# magic]
 1831 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 1832 The primop dataToTag# is unusual because it evaluates its argument.
 1833 Only `SeqOp` shares that property.  (Other primops do not do anything
 1834 as fancy as argument evaluation.)  The special handling for dataToTag#
 1835 is:
 1836 
 1837 * GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,
 1838   (actually in app_ok).  Most primops with lifted arguments do not
 1839   evaluate those arguments, but DataToTagOp and SeqOp are two
 1840   exceptions.  We say that they are /never/ ok-for-speculation,
 1841   regardless of the evaluated-ness of their argument.
 1842   See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]
 1843 
 1844 * There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,
 1845   that evaluates its argument and then extracts the tag from
 1846   the returned value.
 1847 
 1848 * An application like (dataToTag# (Just x)) is optimised by
 1849   dataToTagRule in GHC.Core.Opt.ConstantFold.
 1850 
 1851 * A case expression like
 1852      case (dataToTag# e) of <alts>
 1853   gets transformed t
 1854      case e of <transformed alts>
 1855   by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]
 1856 
 1857 See #15696 for a long saga.
 1858 -}
 1859 
 1860 {- *********************************************************************
 1861 *                                                                      *
 1862              unsafeEqualityProof
 1863 *                                                                      *
 1864 ********************************************************************* -}
 1865 
 1866 -- unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)
 1867 -- That is, if the two types are equal, it's not unsafe!
 1868 
 1869 unsafeEqualityProofRule :: RuleM CoreExpr
 1870 unsafeEqualityProofRule
 1871   = do { [Type rep, Type t1, Type t2] <- getArgs
 1872        ; guard (t1 `eqType` t2)
 1873        ; fn <- getFunction
 1874        ; let (_, ue) = splitForAllTyCoVars (idType fn)
 1875              tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality
 1876              (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl
 1877              -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).
 1878              --               UnsafeEquality r a a
 1879        ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }
 1880 
 1881 
 1882 {- *********************************************************************
 1883 *                                                                      *
 1884              Rules for seq# and spark#
 1885 *                                                                      *
 1886 ********************************************************************* -}
 1887 
 1888 {- Note [seq# magic]
 1889 ~~~~~~~~~~~~~~~~~~~~
 1890 The primop
 1891    seq# :: forall a s . a -> State# s -> (# State# s, a #)
 1892 
 1893 is /not/ the same as the Prelude function seq :: a -> b -> b
 1894 as you can see from its type.  In fact, seq# is the implementation
 1895 mechanism for 'evaluate'
 1896 
 1897    evaluate :: a -> IO a
 1898    evaluate a = IO $ \s -> seq# a s
 1899 
 1900 The semantics of seq# is
 1901   * evaluate its first argument
 1902   * and return it
 1903 
 1904 Things to note
 1905 
 1906 * Why do we need a primop at all?  That is, instead of
 1907       case seq# x s of (# x, s #) -> blah
 1908   why not instead say this?
 1909       case x of { DEFAULT -> blah)
 1910 
 1911   Reason (see #5129): if we saw
 1912     catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
 1913 
 1914   then we'd drop the 'case x' because the body of the case is bottom
 1915   anyway. But we don't want to do that; the whole /point/ of
 1916   seq#/evaluate is to evaluate 'x' first in the IO monad.
 1917 
 1918   In short, we /always/ evaluate the first argument and never
 1919   just discard it.
 1920 
 1921 * Why return the value?  So that we can control sharing of seq'd
 1922   values: in
 1923      let x = e in x `seq` ... x ...
 1924   We don't want to inline x, so better to represent it as
 1925        let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
 1926   also it matches the type of rseq in the Eval monad.
 1927 
 1928 Implementing seq#.  The compiler has magic for SeqOp in
 1929 
 1930 - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
 1931 
 1932 - GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#
 1933 
 1934 - GHC.Core.Utils.exprOkForSpeculation;
 1935   see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils
 1936 
 1937 - Simplify.addEvals records evaluated-ness for the result; see
 1938   Note [Adding evaluatedness info to pattern-bound variables]
 1939   in GHC.Core.Opt.Simplify
 1940 -}
 1941 
 1942 seqRule :: RuleM CoreExpr
 1943 seqRule = do
 1944   [Type ty_a, Type _ty_s, a, s] <- getArgs
 1945   guard $ exprIsHNF a
 1946   return $ mkCoreUbxTup [exprType s, ty_a] [s, a]
 1947 
 1948 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
 1949 sparkRule :: RuleM CoreExpr
 1950 sparkRule = seqRule -- reduce on HNF, just the same
 1951   -- XXX perhaps we shouldn't do this, because a spark eliminated by
 1952   -- this rule won't be counted as a dud at runtime?
 1953 
 1954 {-
 1955 ************************************************************************
 1956 *                                                                      *
 1957 \subsection{Built in rules}
 1958 *                                                                      *
 1959 ************************************************************************
 1960 
 1961 Note [Scoping for Builtin rules]
 1962 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1963 When compiling a (base-package) module that defines one of the
 1964 functions mentioned in the RHS of a built-in rule, there's a danger
 1965 that we'll see
 1966 
 1967         f = ...(eq String x)....
 1968 
 1969         ....and lower down...
 1970 
 1971         eqString = ...
 1972 
 1973 Then a rewrite would give
 1974 
 1975         f = ...(eqString x)...
 1976         ....and lower down...
 1977         eqString = ...
 1978 
 1979 and lo, eqString is not in scope.  This only really matters when we
 1980 get to code generation.  But the occurrence analyser does a GlomBinds
 1981 step when necessary, that does a new SCC analysis on the whole set of
 1982 bindings (see occurAnalysePgm), which sorts out the dependency, so all
 1983 is fine.
 1984 -}
 1985 
 1986 builtinRules :: [CoreRule]
 1987 -- Rules for non-primops that can't be expressed using a RULE pragma
 1988 builtinRules
 1989   = [BuiltinRule { ru_name = fsLit "CStringFoldrLit",
 1990                    ru_fn = unpackCStringFoldrName,
 1991                    ru_nargs = 4, ru_try = match_cstring_foldr_lit_C },
 1992      BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8",
 1993                    ru_fn = unpackCStringFoldrUtf8Name,
 1994                    ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 },
 1995      BuiltinRule { ru_name = fsLit "CStringAppendLit",
 1996                    ru_fn = unpackCStringAppendName,
 1997                    ru_nargs = 2, ru_try = match_cstring_append_lit_C },
 1998      BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8",
 1999                    ru_fn = unpackCStringAppendUtf8Name,
 2000                    ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 },
 2001      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
 2002                    ru_nargs = 2, ru_try = match_eq_string },
 2003      BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName,
 2004                    ru_nargs = 1, ru_try = match_cstring_length },
 2005      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
 2006                    ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
 2007 
 2008      mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,
 2009 
 2010      mkBasicRule divIntName 2 $ msum
 2011         [ nonZeroLit 1 >> binaryLit (intOp2 div)
 2012         , leftZero
 2013         , do
 2014           [arg, Lit (LitNumber LitNumInt d)] <- getArgs
 2015           Just n <- return $ exactLog2 d
 2016           platform <- getPlatform
 2017           return $ Var (mkPrimOpId IntSraOp) `App` arg `App` mkIntVal platform n
 2018         ],
 2019 
 2020      mkBasicRule modIntName 2 $ msum
 2021         [ nonZeroLit 1 >> binaryLit (intOp2 mod)
 2022         , leftZero
 2023         , do
 2024           [arg, Lit (LitNumber LitNumInt d)] <- getArgs
 2025           Just _ <- return $ exactLog2 d
 2026           platform <- getPlatform
 2027           return $ Var (mkPrimOpId IntAndOp)
 2028             `App` arg `App` mkIntVal platform (d - 1)
 2029         ]
 2030      ]
 2031  ++ builtinBignumRules
 2032 {-# NOINLINE builtinRules #-}
 2033 -- there is no benefit to inlining these yet, despite this, GHC produces
 2034 -- unfoldings for this regardless since the floated list entries look small.
 2035 
 2036 builtinBignumRules :: [CoreRule]
 2037 builtinBignumRules =
 2038   [ -- conversions
 2039     lit_to_integer "Word# -> Integer"   integerFromWordName
 2040   , lit_to_integer "Int64# -> Integer"  integerFromInt64Name
 2041   , lit_to_integer "Word64# -> Integer" integerFromWord64Name
 2042   , lit_to_integer "Natural -> Integer" integerFromNaturalName
 2043 
 2044   , integer_to_lit "Integer -> Word# (wrap)"   integerToWordName   mkWordLitWrap
 2045   , integer_to_lit "Integer -> Int# (wrap)"    integerToIntName    mkIntLitWrap
 2046   , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger)
 2047   , integer_to_lit "Integer -> Int64# (wrap)"  integerToInt64Name  (\_ -> mkInt64LitInt64 . fromInteger)
 2048   , integer_to_lit "Integer -> Float#"         integerToFloatName  (\_ -> mkFloatLitFloat . fromInteger)
 2049   , integer_to_lit "Integer -> Double#"        integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger)
 2050 
 2051   , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True
 2052   , integer_to_natural "Integer -> Natural (wrap)"  integerToNaturalName      False False
 2053   , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False
 2054 
 2055   , natural_to_word "Natural -> Word# (wrap)"  naturalToWordName
 2056 
 2057     -- comparisons (return an unlifted Int#)
 2058   , bignum_bin_pred "bigNatEq#"  bignatEqName (==)
 2059 
 2060     -- comparisons (return an Ordering)
 2061   , bignum_compare "bignatCompare"      bignatCompareName
 2062   , bignum_compare "bignatCompareWord#" bignatCompareWordName
 2063 
 2064     -- binary operations
 2065   , integer_binop "integerAdd" integerAddName (+)
 2066   , integer_binop "integerSub" integerSubName (-)
 2067   , integer_binop "integerMul" integerMulName (*)
 2068   , integer_binop "integerGcd" integerGcdName gcd
 2069   , integer_binop "integerLcm" integerLcmName lcm
 2070   , integer_binop "integerAnd" integerAndName (.&.)
 2071   , integer_binop "integerOr"  integerOrName  (.|.)
 2072   , integer_binop "integerXor" integerXorName xor
 2073 
 2074   , natural_binop "naturalAdd" naturalAddName (+)
 2075   , natural_binop "naturalMul" naturalMulName (*)
 2076   , natural_binop "naturalGcd" naturalGcdName gcd
 2077   , natural_binop "naturalLcm" naturalLcmName lcm
 2078   , natural_binop "naturalAnd" naturalAndName (.&.)
 2079   , natural_binop "naturalOr"  naturalOrName  (.|.)
 2080   , natural_binop "naturalXor" naturalXorName xor
 2081 
 2082     -- Natural subtraction: it's a binop but it can fail because of underflow so
 2083     -- we have several primitives to handle here.
 2084   , natural_sub "naturalSubUnsafe" naturalSubUnsafeName
 2085   , natural_sub "naturalSubThrow"  naturalSubThrowName
 2086   , mkRule "naturalSub" naturalSubName 2 $ do
 2087         [a0,a1] <- getArgs
 2088         x <- isNaturalLiteral a0
 2089         y <- isNaturalLiteral a1
 2090         -- return an unboxed sum: (# (# #) | Natural #)
 2091         let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v
 2092         platform <- getPlatform
 2093         if x < y
 2094             then ret 1 $ Var voidPrimId
 2095             else ret 2 $ mkNaturalExpr platform (x - y)
 2096 
 2097     -- unary operations
 2098   , bignum_unop "integerNegate"     integerNegateName     mkIntegerExpr negate
 2099   , bignum_unop "integerAbs"        integerAbsName        mkIntegerExpr abs
 2100   , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement
 2101 
 2102   , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap
 2103   , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap
 2104 
 2105     -- Bits.bit
 2106   , bignum_bit "integerBit" integerBitName mkIntegerExpr
 2107   , bignum_bit "naturalBit" naturalBitName mkNaturalExpr
 2108 
 2109     -- Bits.testBit
 2110   , bignum_testbit "integerTestBit" integerTestBitName
 2111   , bignum_testbit "naturalTestBit" naturalTestBitName
 2112 
 2113     -- Bits.shift
 2114   , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr
 2115   , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr
 2116   , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr
 2117   , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr
 2118 
 2119     -- division
 2120   , divop_one  "integerQuot"    integerQuotName    quot    mkIntegerExpr
 2121   , divop_one  "integerRem"     integerRemName     rem     mkIntegerExpr
 2122   , divop_one  "integerDiv"     integerDivName     div     mkIntegerExpr
 2123   , divop_one  "integerMod"     integerModName     mod     mkIntegerExpr
 2124   , divop_both "integerDivMod"  integerDivModName  divMod  mkIntegerExpr integerTy
 2125   , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy
 2126 
 2127   , divop_one  "naturalQuot"    naturalQuotName    quot    mkNaturalExpr
 2128   , divop_one  "naturalRem"     naturalRemName     rem     mkNaturalExpr
 2129   , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr naturalTy
 2130 
 2131     -- conversions from Rational for Float/Double literals
 2132   , rational_to "rationalToFloat"  rationalToFloatName  mkFloatExpr
 2133   , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr
 2134 
 2135     -- conversions from Integer for Float/Double literals
 2136   , integer_encode_float "integerEncodeFloat"  integerEncodeFloatName  mkFloatLitFloat
 2137   , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble
 2138   ]
 2139   where
 2140     mkRule str name nargs f = BuiltinRule
 2141       { ru_name = fsLit str
 2142       , ru_fn = name
 2143       , ru_nargs = nargs
 2144       , ru_try = runRuleM $ do
 2145           env <- getRuleOpts
 2146           guard (roBignumRules env)
 2147           f
 2148       }
 2149 
 2150     integer_to_lit str name convert = mkRule str name 1 $ do
 2151       [a0] <- getArgs
 2152       platform <- getPlatform
 2153       -- we only match on Big Integer literals. Small literals
 2154       -- are matched by the "Int# -> Integer -> *" rules
 2155       x <- isBigIntegerLiteral a0
 2156       pure (convert platform x)
 2157 
 2158     natural_to_word str name = mkRule str name 1 $ do
 2159       [a0] <- getArgs
 2160       n <- isNaturalLiteral a0
 2161       platform <- getPlatform
 2162       pure (Lit (mkLitWordWrap platform n))
 2163 
 2164     integer_to_natural str name thrw clamp = mkRule str name 1 $ do
 2165       [a0] <- getArgs
 2166       x <- isIntegerLiteral a0
 2167       platform <- getPlatform
 2168       if | x >= 0    -> pure $ mkNaturalExpr platform x
 2169          | thrw      -> mzero
 2170          | clamp     -> pure $ mkNaturalExpr platform 0       -- clamp to 0
 2171          | otherwise -> pure $ mkNaturalExpr platform (abs x) -- negate/wrap
 2172 
 2173     lit_to_integer str name = mkRule str name 1 $ do
 2174       [a0] <- getArgs
 2175       platform <- getPlatform
 2176       i <- isBignumLiteral a0
 2177       -- convert any numeric literal into an Integer literal
 2178       pure (mkIntegerExpr platform i)
 2179 
 2180     integer_binop str name op = mkRule str name 2 $ do
 2181       [a0,a1] <- getArgs
 2182       x <- isIntegerLiteral a0
 2183       y <- isIntegerLiteral a1
 2184       platform <- getPlatform
 2185       pure (mkIntegerExpr platform (x `op` y))
 2186 
 2187     natural_binop str name op = mkRule str name 2 $ do
 2188       [a0,a1] <- getArgs
 2189       x <- isNaturalLiteral a0
 2190       y <- isNaturalLiteral a1
 2191       platform <- getPlatform
 2192       pure (mkNaturalExpr platform (x `op` y))
 2193 
 2194     natural_sub str name = mkRule str name 2 $ do
 2195       [a0,a1] <- getArgs
 2196       x <- isNaturalLiteral a0
 2197       y <- isNaturalLiteral a1
 2198       guard (x >= y)
 2199       platform <- getPlatform
 2200       pure (mkNaturalExpr platform (x - y))
 2201 
 2202     bignum_bin_pred str name op = mkRule str name 2 $ do
 2203       platform <- getPlatform
 2204       [a0,a1] <- getArgs
 2205       x <- isBignumLiteral a0
 2206       y <- isBignumLiteral a1
 2207       pure $ if x `op` y
 2208               then trueValInt platform
 2209               else falseValInt platform
 2210 
 2211     bignum_compare str name = mkRule str name 2 $ do
 2212       [a0,a1] <- getArgs
 2213       x <- isBignumLiteral a0
 2214       y <- isBignumLiteral a1
 2215       pure $ case x `compare` y of
 2216               LT -> ltVal
 2217               EQ -> eqVal
 2218               GT -> gtVal
 2219 
 2220     bignum_unop str name mk_lit op = mkRule str name 1 $ do
 2221       [a0] <- getArgs
 2222       x <- isBignumLiteral a0
 2223       platform <- getPlatform
 2224       pure $ mk_lit platform (op x)
 2225 
 2226     bignum_popcount str name mk_lit = mkRule str name 1 $ do
 2227       platform <- getPlatform
 2228       -- We use a host Int to compute the popCount. If we compile on a 32-bit
 2229       -- host for a 64-bit target, the result may be different than if computed
 2230       -- by the target. So we disable this rule if sizes don't match.
 2231       guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word))
 2232       [a0] <- getArgs
 2233       x <- isBignumLiteral a0
 2234       pure $ Lit (mk_lit platform (fromIntegral (popCount x)))
 2235 
 2236     bignum_bit str name mk_lit = mkRule str name 1 $ do
 2237       [a0] <- getArgs
 2238       platform <- getPlatform
 2239       n <- isNumberLiteral a0
 2240       -- Make sure n is positive and small enough to yield a decently
 2241       -- small number. Attempting to construct the Integer for
 2242       --    (integerBit 9223372036854775807#)
 2243       -- would be a bad idea (#14959)
 2244       guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform))
 2245       -- it's safe to convert a target Int value into a host Int value
 2246       -- to perform the "bit" operation because n is very small (<= 64).
 2247       pure $ mk_lit platform (bit (fromIntegral n))
 2248 
 2249     bignum_testbit str name = mkRule str name 2 $ do
 2250       [a0,a1] <- getArgs
 2251       platform <- getPlatform
 2252       x <- isBignumLiteral a0
 2253       n <- isNumberLiteral a1
 2254       -- ensure that we can store 'n' in a host Int
 2255       guard (n >= 0 && n <= fromIntegral (maxBound :: Int))
 2256       pure $ if testBit x (fromIntegral n)
 2257               then trueValInt platform
 2258               else falseValInt platform
 2259 
 2260     bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do
 2261       [a0,a1] <- getArgs
 2262       x <- isBignumLiteral a0
 2263       n <- isNumberLiteral a1
 2264       -- See Note [Guarding against silly shifts]
 2265       -- Restrict constant-folding of shifts on Integers, somewhat arbitrary.
 2266       -- We can get huge shifts in inaccessible code (#15673)
 2267       guard (n <= 4)
 2268       platform <- getPlatform
 2269       pure $ mk_lit platform (x `shift_op` fromIntegral n)
 2270 
 2271     divop_one str name divop mk_lit = mkRule str name 2 $ do
 2272       [a0,a1] <- getArgs
 2273       n <- isBignumLiteral a0
 2274       d <- isBignumLiteral a1
 2275       guard (d /= 0)
 2276       platform <- getPlatform
 2277       pure $ mk_lit platform (n `divop` d)
 2278 
 2279     divop_both str name divop mk_lit ty = mkRule str name 2 $ do
 2280       [a0,a1] <- getArgs
 2281       n <- isBignumLiteral a0
 2282       d <- isBignumLiteral a1
 2283       guard (d /= 0)
 2284       let (r,s) = n `divop` d
 2285       platform <- getPlatform
 2286       pure $ mkCoreUbxTup [ty,ty] [mk_lit platform r, mk_lit platform s]
 2287 
 2288     integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule
 2289     integer_encode_float str name mk_lit = mkRule str name 2 $ do
 2290       [a0,a1] <- getArgs
 2291       x <- isIntegerLiteral a0
 2292       y <- isNumberLiteral a1
 2293       -- check that y (a target Int) is in the host Int range
 2294       guard (y <= fromIntegral (maxBound :: Int))
 2295       pure (mk_lit $ encodeFloat x (fromInteger y))
 2296 
 2297     rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule
 2298     rational_to str name mk_lit = mkRule str name 2 $ do
 2299       -- This turns `rationalToFloat n d` where `n` and `d` are literals into
 2300       -- a literal Float (and similarly for Double).
 2301       [a0,a1] <- getArgs
 2302       n <- isIntegerLiteral a0
 2303       d <- isIntegerLiteral a1
 2304       -- it's important to not match d == 0, because that may represent a
 2305       -- literal "0/0" or similar, and we can't produce a literal value for
 2306       -- NaN or +-Inf
 2307       guard (d /= 0)
 2308       pure $ mk_lit (fromRational (n % d))
 2309 
 2310 
 2311 ---------------------------------------------------
 2312 -- The rules are:
 2313 --      unpackAppendCString*# "foo"# (unpackCString*# "baz"#)
 2314 --      =  unpackCString*# "foobaz"#
 2315 --
 2316 --      unpackAppendCString*# "foo"# (unpackAppendCString*# "baz"# e)
 2317 --      =  unpackAppendCString*# "foobaz"# e
 2318 --
 2319 
 2320 -- CString version
 2321 match_cstring_append_lit_C :: RuleFun
 2322 match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey
 2323 
 2324 -- CStringUTF8 version
 2325 match_cstring_append_lit_utf8 :: RuleFun
 2326 match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey
 2327 
 2328 {-# INLINE match_cstring_append_lit #-}
 2329 match_cstring_append_lit :: Unique -> Unique -> RuleFun
 2330 match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2]
 2331   | Just (LitString s1) <- exprIsLiteral_maybe env lit1
 2332   , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2
 2333   , unpk `hasKey` unpack_key
 2334   , Just (LitString s2) <- exprIsLiteral_maybe env lit2
 2335   = Just $ mkTicks strTicks
 2336          $ Var unpk `App` Lit (LitString (s1 `BS.append` s2))
 2337 
 2338   | Just (LitString s1) <- exprIsLiteral_maybe env lit1
 2339   , (strTicks, Var appnd `App` lit2 `App` e) <- stripStrTopTicks env e2
 2340   , appnd `hasKey` append_key
 2341   , Just (LitString s2) <- exprIsLiteral_maybe env lit2
 2342   = Just $ mkTicks strTicks
 2343          $ Var appnd `App` Lit (LitString (s1 `BS.append` s2)) `App` e
 2344 
 2345 match_cstring_append_lit _ _ _ _ _ _ = Nothing
 2346 
 2347 ---------------------------------------------------
 2348 -- The rule is this:
 2349 --      unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n)
 2350 --      =  unpackFoldrCString*# "foobaz"# c n
 2351 --
 2352 -- See also Note [String literals in GHC] in CString.hs
 2353 
 2354 -- CString version
 2355 match_cstring_foldr_lit_C :: RuleFun
 2356 match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey
 2357 
 2358 -- CStringUTF8 version
 2359 match_cstring_foldr_lit_utf8 :: RuleFun
 2360 match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey
 2361 
 2362 {-# INLINE match_cstring_foldr_lit #-}
 2363 match_cstring_foldr_lit :: Unique -> RuleFun
 2364 match_cstring_foldr_lit foldVariant _ env _
 2365         [ Type ty1
 2366         , lit1
 2367         , c1
 2368         , e2
 2369         ]
 2370   | (strTicks, Var unpk `App` Type ty2
 2371                         `App` lit2
 2372                         `App` c2
 2373                         `App` n) <- stripStrTopTicks env e2
 2374   , unpk `hasKey` foldVariant
 2375   , Just (LitString s1) <- exprIsLiteral_maybe env lit1
 2376   , Just (LitString s2) <- exprIsLiteral_maybe env lit2
 2377   , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2))
 2378     in eqExpr freeVars c1 c2
 2379   , (c1Ticks, c1') <- stripStrTopTicks env c1
 2380   , c2Ticks <- stripStrTopTicksT c2
 2381   = assert (ty1 `eqType` ty2) $
 2382     Just $ mkTicks strTicks
 2383          $ Var unpk `App` Type ty1
 2384                     `App` Lit (LitString (s1 `BS.append` s2))
 2385                     `App` mkTicks (c1Ticks ++ c2Ticks) c1'
 2386                     `App` n
 2387 
 2388 match_cstring_foldr_lit _ _ _ _ _ = Nothing
 2389 
 2390 
 2391 -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the
 2392 -- argument, lest this may fail to fire when building with -g3. See #16740.
 2393 --
 2394 -- Also, look into variable's unfolding just in case the expression we look for
 2395 -- is in a top-level thunk.
 2396 stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
 2397 stripStrTopTicks (_,id_unf) e = case e of
 2398   Var v
 2399     | Just rhs <- expandUnfolding_maybe (id_unf v)
 2400     -> stripTicksTop tickishFloatable rhs
 2401   _ -> stripTicksTop tickishFloatable e
 2402 
 2403 stripStrTopTicksT :: CoreExpr -> [CoreTickish]
 2404 stripStrTopTicksT e = stripTicksTopT tickishFloatable e
 2405 
 2406 ---------------------------------------------------
 2407 -- The rule is this:
 2408 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
 2409 -- Also  matches unpackCStringUtf8#
 2410 
 2411 match_eq_string :: RuleFun
 2412 match_eq_string _ env _ [e1, e2]
 2413   | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1
 2414   , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2
 2415   , unpk_key1 <- getUnique unpk1
 2416   , unpk_key2 <- getUnique unpk2
 2417   , unpk_key1 == unpk_key2
 2418   -- For now we insist the literals have to agree in their encoding
 2419   -- to keep the rule simple. But we could check if the decoded strings
 2420   -- compare equal in here as well.
 2421   , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey]
 2422   , Just (LitString s1) <- exprIsLiteral_maybe env lit1
 2423   , Just (LitString s2) <- exprIsLiteral_maybe env lit2
 2424   = Just $ mkTicks (ticks1 ++ ticks2)
 2425          $ (if s1 == s2 then trueValBool else falseValBool)
 2426 
 2427 match_eq_string _ _ _ _ = Nothing
 2428 
 2429 -----------------------------------------------------------------------
 2430 -- Illustration of this rule:
 2431 --
 2432 -- cstringLength# "foobar"# --> 6
 2433 -- cstringLength# "fizz\NULzz"# --> 4
 2434 --
 2435 -- Nota bene: Addr# literals are suffixed by a NUL byte when they are
 2436 -- compiled to read-only data sections. That's why cstringLength# is
 2437 -- well defined on Addr# literals that do not explicitly have an embedded
 2438 -- NUL byte.
 2439 --
 2440 -- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly
 2441 -- helpful when using OverloadedStrings to create a ByteString since the
 2442 -- function computing the length of such ByteStrings can often be constant
 2443 -- folded.
 2444 match_cstring_length :: RuleFun
 2445 match_cstring_length rule_env env _ [lit1]
 2446   | Just (LitString str) <- exprIsLiteral_maybe env lit1
 2447     -- If elemIndex returns Just, it has the index of the first embedded NUL
 2448     -- in the string. If no NUL bytes are present (the common case) then use
 2449     -- full length of the byte string.
 2450   = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str)
 2451      in Just (Lit (mkLitInt (roPlatform rule_env) (fromIntegral len)))
 2452 match_cstring_length _ _ _ _ = Nothing
 2453 
 2454 ---------------------------------------------------
 2455 {- Note [inlineId magic]
 2456 ~~~~~~~~~~~~~~~~~~~~~~~~
 2457 The call 'inline f' arranges that 'f' is inlined, regardless of
 2458 its size. More precisely, the call 'inline f' rewrites to the
 2459 right-hand side of 'f's definition. This allows the programmer to
 2460 control inlining from a particular call site rather than the
 2461 definition site of the function.
 2462 
 2463 The moving parts are simple:
 2464 
 2465 * A very simple definition in the library base:GHC.Magic
 2466      {-# NOINLINE[0] inline #-}
 2467      inline :: a -> a
 2468      inline x = x
 2469   So in phase 0, 'inline' will be inlined, so its use imposes
 2470   no overhead.
 2471 
 2472 * A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes
 2473   (inline f) inline, implemented by match_inline.
 2474   The rule for the 'inline' function is this:
 2475      inline f_ty (f a b c) = <f's unfolding> a b c
 2476   (if f has an unfolding, EVEN if it's a loop breaker)
 2477 
 2478   It's important to allow the argument to 'inline' to have args itself
 2479   (a) because its more forgiving to allow the programmer to write
 2480       either  inline f a b c
 2481       or      inline (f a b c)
 2482   (b) because a polymorphic f wll get a type argument that the
 2483       programmer can't avoid, so the call may look like
 2484         inline (map @Int @Bool) g xs
 2485 
 2486   Also, don't forget about 'inline's type argument!
 2487 -}
 2488 
 2489 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 2490 match_inline (Type _ : e : _)
 2491   | (Var f, args1) <- collectArgs e,
 2492     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
 2493              -- Ignore the IdUnfoldingFun here!
 2494   = Just (mkApps unf args1)
 2495 
 2496 match_inline _ = Nothing
 2497 
 2498 --------------------------------------------------------
 2499 -- Note [Constant folding through nested expressions]
 2500 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 2501 --
 2502 -- We use rewrites rules to perform constant folding. It means that we don't
 2503 -- have a global view of the expression we are trying to optimise. As a
 2504 -- consequence we only perform local (small-step) transformations that either:
 2505 --    1) reduce the number of operations
 2506 --    2) rearrange the expression to increase the odds that other rules will
 2507 --    match
 2508 --
 2509 -- We don't try to handle more complex expression optimisation cases that would
 2510 -- require a global view. For example, rewriting expressions to increase
 2511 -- sharing (e.g., Horner's method); optimisations that require local
 2512 -- transformations increasing the number of operations; rearrangements to
 2513 -- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).
 2514 --
 2515 -- We already have rules to perform constant folding on expressions with the
 2516 -- following shape (where a and/or b are literals):
 2517 --
 2518 --          D)    op
 2519 --                /\
 2520 --               /  \
 2521 --              /    \
 2522 --             a      b
 2523 --
 2524 -- To support nested expressions, we match three other shapes of expression
 2525 -- trees:
 2526 --
 2527 -- A)   op1          B)       op1       C)       op1
 2528 --      /\                    /\                 /\
 2529 --     /  \                  /  \               /  \
 2530 --    /    \                /    \             /    \
 2531 --   a     op2            op2     c          op2    op3
 2532 --          /\            /\                 /\      /\
 2533 --         /  \          /  \               /  \    /  \
 2534 --        b    c        a    b             a    b  c    d
 2535 --
 2536 --
 2537 -- R1) +/- simplification:
 2538 --    ops = + or -, two literals (not siblings)
 2539 --
 2540 --    Examples:
 2541 --       A: 5 + (10-x)  ==> 15-x
 2542 --       B: (10+x) + 5  ==> 15+x
 2543 --       C: (5+a)-(5-b) ==> 0+(a+b)
 2544 --
 2545 -- R2) *, `and`, `or`  simplification
 2546 --    ops = *, `and`, `or` two literals (not siblings)
 2547 --
 2548 --    Examples:
 2549 --       A: 5 * (10*x)  ==> 50*x
 2550 --       B: (10*x) * 5  ==> 50*x
 2551 --       C: (5*a)*(5*b) ==> 25*(a*b)
 2552 --
 2553 -- R3) * distribution over +/-
 2554 --    op1 = *, op2 = + or -, two literals (not siblings)
 2555 --
 2556 --    This transformation doesn't reduce the number of operations but switches
 2557 --    the outer and the inner operations so that the outer is (+) or (-) instead
 2558 --    of (*). It increases the odds that other rules will match after this one.
 2559 --
 2560 --    Examples:
 2561 --       A: 5 * (10-x)  ==> 50 - (5*x)
 2562 --       B: (10+x) * 5  ==> 50 + (5*x)
 2563 --       C: Not supported as it would increase the number of operations:
 2564 --          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b
 2565 --
 2566 -- R4) Simple factorization
 2567 --
 2568 --    op1 = + or -, op2/op3 = *,
 2569 --    one literal for each innermost * operation (except in the D case),
 2570 --    the two other terms are equals
 2571 --
 2572 --    Examples:
 2573 --       A: x - (10*x)  ==> (-9)*x
 2574 --       B: (10*x) + x  ==> 11*x
 2575 --       C: (5*x)-(x*3) ==> 2*x
 2576 --       D: x+x         ==> 2*x
 2577 --
 2578 -- R5) +/- propagation
 2579 --
 2580 --    ops = + or -, one literal
 2581 --
 2582 --    This transformation doesn't reduce the number of operations but propagates
 2583 --    the constant to the outer level. It increases the odds that other rules
 2584 --    will match after this one.
 2585 --
 2586 --    Examples:
 2587 --       A: x - (10-y)  ==> (x+y) - 10
 2588 --       B: (10+x) - y  ==> 10 + (x-y)
 2589 --       C: N/A (caught by the A and B cases)
 2590 --
 2591 --------------------------------------------------------
 2592 
 2593 -- Rules to perform constant folding into nested expressions
 2594 --
 2595 --See Note [Constant folding through nested expressions]
 2596 
 2597 addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
 2598 addFoldingRules op num_ops = do
 2599    massert (op == numAdd num_ops)
 2600    env <- getRuleOpts
 2601    guard (roNumConstantFolding env)
 2602    [arg1,arg2] <- getArgs
 2603    platform <- getPlatform
 2604    liftMaybe
 2605       -- commutativity for + is handled here
 2606       (addFoldingRules' platform arg1 arg2 num_ops
 2607        <|> addFoldingRules' platform arg2 arg1 num_ops)
 2608 
 2609 subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
 2610 subFoldingRules op num_ops = do
 2611    massert (op == numSub num_ops)
 2612    env <- getRuleOpts
 2613    guard (roNumConstantFolding env)
 2614    [arg1,arg2] <- getArgs
 2615    platform <- getPlatform
 2616    liftMaybe (subFoldingRules' platform arg1 arg2 num_ops)
 2617 
 2618 mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
 2619 mulFoldingRules op num_ops = do
 2620    massert (op == numMul num_ops)
 2621    env <- getRuleOpts
 2622    guard (roNumConstantFolding env)
 2623    [arg1,arg2] <- getArgs
 2624    platform <- getPlatform
 2625    liftMaybe
 2626       -- commutativity for * is handled here
 2627       (mulFoldingRules' platform arg1 arg2 num_ops
 2628        <|> mulFoldingRules' platform arg2 arg1 num_ops)
 2629 
 2630 andFoldingRules :: NumOps -> RuleM CoreExpr
 2631 andFoldingRules num_ops = do
 2632    env <- getRuleOpts
 2633    guard (roNumConstantFolding env)
 2634    [arg1,arg2] <- getArgs
 2635    platform <- getPlatform
 2636    liftMaybe
 2637       -- commutativity for `and` is handled here
 2638       (andFoldingRules' platform arg1 arg2 num_ops
 2639        <|> andFoldingRules' platform arg2 arg1 num_ops)
 2640 
 2641 orFoldingRules :: NumOps -> RuleM CoreExpr
 2642 orFoldingRules num_ops = do
 2643    env <- getRuleOpts
 2644    guard (roNumConstantFolding env)
 2645    [arg1,arg2] <- getArgs
 2646    platform <- getPlatform
 2647    liftMaybe
 2648       -- commutativity for `or` is handled here
 2649       (orFoldingRules' platform arg1 arg2 num_ops
 2650        <|> orFoldingRules' platform arg2 arg1 num_ops)
 2651 
 2652 addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
 2653 addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
 2654 
 2655       -- x + (-y) ==> x-y
 2656       (x, is_neg num_ops -> Just y)
 2657          -> Just (x `sub` y)
 2658 
 2659       -- R1) +/- simplification
 2660 
 2661       -- l1 + (l2 + x) ==> (l1+l2) + x
 2662       (L l1, is_lit_add num_ops -> Just (l2,x))
 2663          -> Just (mkL (l1+l2) `add` x)
 2664 
 2665       -- l1 + (l2 - x) ==> (l1+l2) - x
 2666       (L l1, is_sub num_ops -> Just (L l2,x))
 2667          -> Just (mkL (l1+l2) `sub` x)
 2668 
 2669       -- l1 + (x - l2) ==> (l1-l2) + x
 2670       (L l1, is_sub num_ops -> Just (x,L l2))
 2671          -> Just (mkL (l1-l2) `add` x)
 2672 
 2673       -- (l1 + x) + (l2 + y) ==> (l1+l2) + (x+y)
 2674       (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))
 2675          -> Just (mkL (l1+l2) `add` (x `add` y))
 2676 
 2677       -- (l1 + x) + (l2 - y) ==> (l1+l2) + (x-y)
 2678       (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))
 2679          -> Just (mkL (l1+l2) `add` (x `sub` y))
 2680 
 2681       -- (l1 + x) + (y - l2) ==> (l1-l2) + (x+y)
 2682       (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))
 2683          -> Just (mkL (l1-l2) `add` (x `add` y))
 2684 
 2685       -- (l1 - x) + (l2 - y) ==> (l1+l2) - (x+y)
 2686       (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))
 2687          -> Just (mkL (l1+l2) `sub` (x `add` y))
 2688 
 2689       -- (l1 - x) + (y - l2) ==> (l1-l2) + (y-x)
 2690       (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))
 2691          -> Just (mkL (l1-l2) `add` (y `sub` x))
 2692 
 2693       -- (x - l1) + (y - l2) ==> (0-l1-l2) + (x+y)
 2694       (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))
 2695          -> Just (mkL (0-l1-l2) `add` (x `add` y))
 2696 
 2697       -- R4) Simple factorization
 2698 
 2699       -- x + x ==> 2 * x
 2700       _ | Just l1 <- is_expr_mul num_ops arg1 arg2
 2701         -> Just (mkL (l1+1) `mul` arg1)
 2702 
 2703       -- (l1 * x) + x ==> (l1+1) * x
 2704       _ | Just l1 <- is_expr_mul num_ops arg2 arg1
 2705         -> Just (mkL (l1+1) `mul` arg2)
 2706 
 2707       -- (l1 * x) + (l2 * x) ==> (l1+l2) * x
 2708       (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)
 2709          -> Just (mkL (l1+l2) `mul` x)
 2710 
 2711       -- R5) +/- propagation: these transformations push literals outwards
 2712       -- with the hope that other rules can then be applied.
 2713 
 2714       -- In the following rules, x can't be a literal otherwise another
 2715       -- rule would have combined it with the other literal in arg2. So we
 2716       -- don't have to check this to avoid loops here.
 2717 
 2718       -- x + (l1 + y) ==> l1 + (x + y)
 2719       (_, is_lit_add num_ops -> Just (l1,y))
 2720          -> Just (mkL l1 `add` (arg1 `add` y))
 2721 
 2722       -- x + (l1 - y) ==> l1 + (x - y)
 2723       (_, is_sub num_ops -> Just (L l1,y))
 2724          -> Just (mkL l1 `add` (arg1 `sub` y))
 2725 
 2726       -- x + (y - l1) ==> (x + y) - l1
 2727       (_, is_sub num_ops -> Just (y,L l1))
 2728          -> Just ((arg1 `add` y) `sub` mkL l1)
 2729 
 2730       _ -> Nothing
 2731 
 2732    where
 2733       mkL = Lit . mkNumLiteral platform num_ops
 2734       add x y = BinOpApp x (numAdd num_ops) y
 2735       sub x y = BinOpApp x (numSub num_ops) y
 2736       mul x y = BinOpApp x (numMul num_ops) y
 2737 
 2738 subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
 2739 subFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of
 2740       -- x - (-y) ==> x+y
 2741       (x, is_neg num_ops -> Just y)
 2742          -> Just (x `add` y)
 2743 
 2744       -- R1) +/- simplification
 2745 
 2746       -- l1 - (l2 + x) ==> (l1-l2) - x
 2747       (L l1, is_lit_add num_ops -> Just (l2,x))
 2748          -> Just (mkL (l1-l2) `sub` x)
 2749 
 2750       -- l1 - (l2 - x) ==> (l1-l2) + x
 2751       (L l1, is_sub num_ops -> Just (L l2,x))
 2752          -> Just (mkL (l1-l2) `add` x)
 2753 
 2754       -- l1 - (x - l2) ==> (l1+l2) - x
 2755       (L l1, is_sub num_ops -> Just (x, L l2))
 2756          -> Just (mkL (l1+l2) `sub` x)
 2757 
 2758       -- (l1 + x) - l2 ==> (l1-l2) + x
 2759       (is_lit_add num_ops -> Just (l1,x), L l2)
 2760          -> Just (mkL (l1-l2) `add` x)
 2761 
 2762       -- (l1 - x) - l2 ==> (l1-l2) - x
 2763       (is_sub num_ops -> Just (L l1,x), L l2)
 2764          -> Just (mkL (l1-l2) `sub` x)
 2765 
 2766       -- (x - l1) - l2 ==> x - (l1+l2)
 2767       (is_sub num_ops -> Just (x,L l1), L l2)
 2768          -> Just (x `sub` mkL (l1+l2))
 2769 
 2770 
 2771       -- (l1 + x) - (l2 + y) ==> (l1-l2) + (x-y)
 2772       (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))
 2773          -> Just (mkL (l1-l2) `add` (x `sub` y))
 2774 
 2775       -- (l1 + x) - (l2 - y) ==> (l1-l2) + (x+y)
 2776       (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))
 2777          -> Just (mkL (l1-l2) `add` (x `add` y))
 2778 
 2779       -- (l1 + x) - (y - l2) ==> (l1+l2) + (x-y)
 2780       (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))
 2781          -> Just (mkL (l1+l2) `add` (x `sub` y))
 2782 
 2783       -- (l1 - x) - (l2 + y) ==> (l1-l2) - (x+y)
 2784       (is_sub num_ops -> Just (L l1,x), is_lit_add num_ops -> Just (l2,y))
 2785          -> Just (mkL (l1-l2) `sub` (x `add` y))
 2786 
 2787       -- (x - l1) - (l2 + y) ==> (0-l1-l2) + (x-y)
 2788       (is_sub num_ops -> Just (x,L l1), is_lit_add num_ops -> Just (l2,y))
 2789          -> Just (mkL (0-l1-l2) `add` (x `sub` y))
 2790 
 2791       -- (l1 - x) - (l2 - y) ==> (l1-l2) + (y-x)
 2792       (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))
 2793          -> Just (mkL (l1-l2) `add` (y `sub` x))
 2794 
 2795       -- (l1 - x) - (y - l2) ==> (l1+l2) - (x+y)
 2796       (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))
 2797          -> Just (mkL (l1+l2) `sub` (x `add` y))
 2798 
 2799       -- (x - l1) - (l2 - y) ==> (0-l1-l2) + (x+y)
 2800       (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (L l2,y))
 2801          -> Just (mkL (0-l1-l2) `add` (x `add` y))
 2802 
 2803       -- (x - l1) - (y - l2) ==> (l2-l1) + (x-y)
 2804       (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))
 2805          -> Just (mkL (l2-l1) `add` (x `sub` y))
 2806 
 2807        -- R4) Simple factorization
 2808 
 2809       -- x - (l1 * x) ==> (1-l1) * x
 2810       _ | Just l1 <- is_expr_mul num_ops arg1 arg2
 2811         -> Just (mkL (1-l1) `mul` arg1)
 2812 
 2813       -- (l1 * x) - x ==> (l1-1) * x
 2814       _ | Just l1 <- is_expr_mul num_ops arg2 arg1
 2815         -> Just (mkL (l1-1) `mul` arg2)
 2816 
 2817       -- (l1 * x) - (l2 * x) ==> (l1-l2) * x
 2818       (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)
 2819          -> Just (mkL (l1-l2) `mul` x)
 2820 
 2821       -- R5) +/- propagation: these transformations push literals outwards
 2822       -- with the hope that other rules can then be applied.
 2823 
 2824       -- In the following rules, x can't be a literal otherwise another
 2825       -- rule would have combined it with the other literal in arg2. So we
 2826       -- don't have to check this to avoid loops here.
 2827 
 2828       -- x - (l1 + y) ==> (x - y) - l1
 2829       (_, is_lit_add num_ops -> Just (l1,y))
 2830          -> Just ((arg1 `sub` y) `sub` mkL l1)
 2831 
 2832       -- (l1 + x) - y ==> l1 + (x - y)
 2833       (is_lit_add num_ops -> Just (l1,x), _)
 2834          -> Just (mkL l1 `add` (x `sub` arg2))
 2835 
 2836       -- x - (l1 - y) ==> (x + y) - l1
 2837       (_, is_sub num_ops -> Just (L l1,y))
 2838          -> Just ((arg1 `add` y) `sub` mkL l1)
 2839 
 2840       -- x - (y - l1) ==> l1 + (x - y)
 2841       (_, is_sub num_ops -> Just (y,L l1))
 2842          -> Just (mkL l1 `add` (arg1 `sub` y))
 2843 
 2844       -- (l1 - x) - y ==> l1 - (x + y)
 2845       (is_sub num_ops -> Just (L l1,x), _)
 2846          -> Just (mkL l1 `sub` (x `add` arg2))
 2847 
 2848       -- (x - l1) - y ==> (x - y) - l1
 2849       (is_sub num_ops -> Just (x,L l1), _)
 2850          -> Just ((x `sub` arg2) `sub` mkL l1)
 2851 
 2852       _ -> Nothing
 2853    where
 2854       mkL = Lit . mkNumLiteral platform num_ops
 2855       add x y = BinOpApp x (numAdd num_ops) y
 2856       sub x y = BinOpApp x (numSub num_ops) y
 2857       mul x y = BinOpApp x (numMul num_ops) y
 2858 
 2859 mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
 2860 mulFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of
 2861    -- (-x) * (-y) ==> x*y
 2862    (is_neg num_ops -> Just x, is_neg num_ops -> Just y)
 2863       -> Just (x `mul` y)
 2864 
 2865    -- l1 * (-x) ==> (-l1) * x
 2866    (L l1, is_neg num_ops -> Just x)
 2867       -> Just (mkL (-l1) `mul` x)
 2868 
 2869    -- l1 * (l2 * x) ==> (l1*l2) * x
 2870    (L l1, is_lit_mul num_ops -> Just (l2,x))
 2871       -> Just (mkL (l1*l2) `mul` x)
 2872 
 2873    -- l1 * (l2 + x) ==> (l1*l2) + (l1 * x)
 2874    (L l1, is_lit_add num_ops -> Just (l2,x))
 2875       -> Just (mkL (l1*l2) `add` (arg1 `mul` x))
 2876 
 2877    -- l1 * (l2 - x) ==> (l1*l2) - (l1 * x)
 2878    (L l1, is_sub num_ops -> Just (L l2,x))
 2879       -> Just (mkL (l1*l2) `sub` (arg1 `mul` x))
 2880 
 2881    -- l1 * (x - l2) ==> (l1 * x) - (l1*l2)
 2882    (L l1, is_sub num_ops -> Just (x, L l2))
 2883       -> Just ((arg1 `mul` x) `sub` mkL (l1*l2))
 2884 
 2885    -- (l1 * x) * (l2 * y) ==> (l1*l2) * (x * y)
 2886    (is_lit_mul num_ops -> Just (l1,x), is_lit_mul num_ops -> Just (l2,y))
 2887       -> Just (mkL (l1*l2) `mul` (x `mul` y))
 2888 
 2889    _ -> Nothing
 2890    where
 2891       mkL = Lit . mkNumLiteral platform num_ops
 2892       add x y = BinOpApp x (numAdd num_ops) y
 2893       sub x y = BinOpApp x (numSub num_ops) y
 2894       mul x y = BinOpApp x (numMul num_ops) y
 2895 
 2896 andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
 2897 andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
 2898     -- R2) * `or` `and` simplications
 2899     -- l1 and (l2 and x) ==> (l1 and l2) and x
 2900     (L l1, is_lit_and num_ops -> Just (l2, x))
 2901        -> Just (mkL (l1 .&. l2) `and` x)
 2902 
 2903     -- l1 and (l2 or x) ==> (l1 and l2) or (l1 and x)
 2904     -- does not decrease operations
 2905 
 2906     -- (l1 and x) and (l2 and y) ==> (l1 and l2) and (x and y)
 2907     (is_lit_and num_ops -> Just (l1, x), is_lit_and num_ops -> Just (l2, y))
 2908        -> Just (mkL (l1 .&. l2) `and` (x `and` y))
 2909 
 2910     -- (l1 and x) and (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)
 2911     -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
 2912     -- increase operation numbers
 2913 
 2914     _ -> Nothing
 2915     where
 2916       mkL = Lit . mkNumLiteral platform num_ops
 2917       and x y = BinOpApp x (fromJust (numAnd num_ops)) y
 2918 
 2919 orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
 2920 orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
 2921     -- R2) *  `or` `and` simplications
 2922     -- l1 or (l2 or x) ==> (l1 or l2) or x
 2923     (L l1, is_lit_or num_ops -> Just (l2, x))
 2924        -> Just (mkL (l1 .|. l2) `or` x)
 2925 
 2926     -- l1 or (l2 and x) ==> (l1 or l2) and (l1 and x)
 2927     -- does not decrease operations
 2928 
 2929     -- (l1 or x) or (l2 or y) ==> (l1 or l2) or (x or y)
 2930     (is_lit_or num_ops -> Just (l1, x), is_lit_or num_ops -> Just (l2, y))
 2931        -> Just (mkL (l1 .|. l2) `or` (x `or` y))
 2932 
 2933     -- (l1 and x) or (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)
 2934     -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
 2935     -- increase operation numbers
 2936 
 2937     _ -> Nothing
 2938     where
 2939       mkL = Lit . mkNumLiteral platform num_ops
 2940       or x y = BinOpApp x (fromJust (numOr num_ops)) y
 2941 
 2942 is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)
 2943 is_binop op e = case e of
 2944  BinOpApp x op' y | op == op' -> Just (x,y)
 2945  _                            -> Nothing
 2946 
 2947 is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr)
 2948 is_op op e = case e of
 2949  App (OpVal op') x | op == op' -> Just x
 2950  _                             -> Nothing
 2951 
 2952 is_add, is_sub, is_mul, is_and, is_or :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)
 2953 is_add num_ops e = is_binop (numAdd num_ops) e
 2954 is_sub num_ops e = is_binop (numSub num_ops) e
 2955 is_mul num_ops e = is_binop (numMul num_ops) e
 2956 is_and num_ops e = numAnd num_ops >>= \op -> is_binop op e
 2957 is_or  num_ops e = numOr  num_ops >>= \op -> is_binop op e
 2958 
 2959 is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr)
 2960 is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e
 2961 
 2962 -- match operation with a literal (handles commutativity)
 2963 is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)
 2964 is_lit_add num_ops e = is_lit' is_add num_ops e
 2965 is_lit_mul num_ops e = is_lit' is_mul num_ops e
 2966 is_lit_and num_ops e = is_lit' is_and num_ops e
 2967 is_lit_or  num_ops e = is_lit' is_or  num_ops e
 2968 
 2969 is_lit' :: (NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)) -> NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)
 2970 is_lit' f num_ops e = case f num_ops e of
 2971   Just (L l, x  ) -> Just (l,x)
 2972   Just (x  , L l) -> Just (l,x)
 2973   _               -> Nothing
 2974 
 2975 -- match given "x": return 1
 2976 -- match "lit * x": return lit value (handles commutativity)
 2977 is_expr_mul :: NumOps -> Expr CoreBndr -> Expr CoreBndr -> Maybe Integer
 2978 is_expr_mul num_ops x e = if
 2979    | x `cheapEqExpr` e
 2980    -> Just 1
 2981    | Just (k,x') <- is_lit_mul num_ops e
 2982    , x `cheapEqExpr` x'
 2983    -> return k
 2984    | otherwise
 2985    -> Nothing
 2986 
 2987 
 2988 -- | Match the application of a binary primop
 2989 pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
 2990 pattern BinOpApp x op y = OpVal op `App` x `App` y
 2991 
 2992 -- | Match a primop
 2993 pattern OpVal:: PrimOp  -> Arg CoreBndr
 2994 pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where
 2995    OpVal op = Var (mkPrimOpId op)
 2996 
 2997 -- | Match a literal
 2998 pattern L :: Integer -> Arg CoreBndr
 2999 pattern L i <- Lit (LitNumber _ i)
 3000 
 3001 -- | Explicit "type-class"-like dictionary for numeric primops
 3002 data NumOps = NumOps
 3003    { numAdd     :: !PrimOp         -- ^ Add two numbers
 3004    , numSub     :: !PrimOp         -- ^ Sub two numbers
 3005    , numMul     :: !PrimOp         -- ^ Multiply two numbers
 3006    , numAnd     :: !(Maybe PrimOp) -- ^ And two numbers
 3007    , numOr      :: !(Maybe PrimOp) -- ^ Or two numbers
 3008    , numNeg     :: !(Maybe PrimOp) -- ^ Negate a number
 3009    , numLitType :: !LitNumType     -- ^ Literal type
 3010    }
 3011 
 3012 -- | Create a numeric literal
 3013 mkNumLiteral :: Platform -> NumOps -> Integer -> Literal
 3014 mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i
 3015 
 3016 int8Ops :: NumOps
 3017 int8Ops = NumOps
 3018    { numAdd     = Int8AddOp
 3019    , numSub     = Int8SubOp
 3020    , numMul     = Int8MulOp
 3021    , numLitType = LitNumInt8
 3022    , numAnd     = Nothing
 3023    , numOr      = Nothing
 3024    , numNeg     = Just Int8NegOp
 3025    }
 3026 
 3027 word8Ops :: NumOps
 3028 word8Ops = NumOps
 3029    { numAdd     = Word8AddOp
 3030    , numSub     = Word8SubOp
 3031    , numMul     = Word8MulOp
 3032    , numAnd     = Just Word8AndOp
 3033    , numOr      = Just Word8OrOp
 3034    , numNeg     = Nothing
 3035    , numLitType = LitNumWord8
 3036    }
 3037 
 3038 int16Ops :: NumOps
 3039 int16Ops = NumOps
 3040    { numAdd     = Int16AddOp
 3041    , numSub     = Int16SubOp
 3042    , numMul     = Int16MulOp
 3043    , numLitType = LitNumInt16
 3044    , numAnd     = Nothing
 3045    , numOr      = Nothing
 3046    , numNeg     = Just Int16NegOp
 3047    }
 3048 
 3049 word16Ops :: NumOps
 3050 word16Ops = NumOps
 3051    { numAdd     = Word16AddOp
 3052    , numSub     = Word16SubOp
 3053    , numMul     = Word16MulOp
 3054    , numAnd     = Just Word16AndOp
 3055    , numOr      = Just Word16OrOp
 3056    , numNeg     = Nothing
 3057    , numLitType = LitNumWord16
 3058    }
 3059 
 3060 int32Ops :: NumOps
 3061 int32Ops = NumOps
 3062    { numAdd     = Int32AddOp
 3063    , numSub     = Int32SubOp
 3064    , numMul     = Int32MulOp
 3065    , numLitType = LitNumInt32
 3066    , numAnd     = Nothing
 3067    , numOr      = Nothing
 3068    , numNeg     = Just Int32NegOp
 3069    }
 3070 
 3071 word32Ops :: NumOps
 3072 word32Ops = NumOps
 3073    { numAdd     = Word32AddOp
 3074    , numSub     = Word32SubOp
 3075    , numMul     = Word32MulOp
 3076    , numAnd     = Just Word32AndOp
 3077    , numOr      = Just Word32OrOp
 3078    , numNeg     = Nothing
 3079    , numLitType = LitNumWord32
 3080    }
 3081 
 3082 int64Ops :: NumOps
 3083 int64Ops = NumOps
 3084    { numAdd     = Int64AddOp
 3085    , numSub     = Int64SubOp
 3086    , numMul     = Int64MulOp
 3087    , numLitType = LitNumInt64
 3088    , numAnd     = Nothing
 3089    , numOr      = Nothing
 3090    , numNeg     = Just Int64NegOp
 3091    }
 3092 
 3093 word64Ops :: NumOps
 3094 word64Ops = NumOps
 3095    { numAdd     = Word64AddOp
 3096    , numSub     = Word64SubOp
 3097    , numMul     = Word64MulOp
 3098    , numAnd     = Just Word64AndOp
 3099    , numOr      = Just Word64OrOp
 3100    , numNeg     = Nothing
 3101    , numLitType = LitNumWord64
 3102    }
 3103 
 3104 intOps :: NumOps
 3105 intOps = NumOps
 3106    { numAdd     = IntAddOp
 3107    , numSub     = IntSubOp
 3108    , numMul     = IntMulOp
 3109    , numAnd     = Just IntAndOp
 3110    , numOr      = Just IntOrOp
 3111    , numNeg     = Just IntNegOp
 3112    , numLitType = LitNumInt
 3113    }
 3114 
 3115 wordOps :: NumOps
 3116 wordOps = NumOps
 3117    { numAdd     = WordAddOp
 3118    , numSub     = WordSubOp
 3119    , numMul     = WordMulOp
 3120    , numAnd     = Just WordAndOp
 3121    , numOr      = Just WordOrOp
 3122    , numNeg     = Nothing
 3123    , numLitType = LitNumWord
 3124    }
 3125 
 3126 --------------------------------------------------------
 3127 -- Constant folding through case-expressions
 3128 --
 3129 -- cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils
 3130 --------------------------------------------------------
 3131 
 3132 -- | Match the scrutinee of a case and potentially return a new scrutinee and a
 3133 -- function to apply to each literal alternative.
 3134 caseRules :: Platform
 3135           -> CoreExpr                       -- Scrutinee
 3136           -> Maybe ( CoreExpr               -- New scrutinee
 3137                    , AltCon -> Maybe AltCon -- How to fix up the alt pattern
 3138                                             --   Nothing <=> Unreachable
 3139                                             -- See Note [Unreachable caseRules alternatives]
 3140                    , Id -> CoreExpr)        -- How to reconstruct the original scrutinee
 3141                                             -- from the new case-binder
 3142 -- e.g  case e of b {
 3143 --         ...;
 3144 --         con bs -> rhs;
 3145 --         ... }
 3146 --  ==>
 3147 --      case e' of b' {
 3148 --         ...;
 3149 --         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
 3150 --         ... }
 3151 
 3152 caseRules platform (App (App (Var f) v) (Lit l))   -- v `op` x#
 3153   | Just op <- isPrimOpId_maybe f
 3154   , LitNumber _ x <- l
 3155   , Just adjust_lit <- adjustDyadicRight op x
 3156   = Just (v, tx_lit_con platform adjust_lit
 3157            , \v -> (App (App (Var f) (Var v)) (Lit l)))
 3158 
 3159 caseRules platform (App (App (Var f) (Lit l)) v)   -- x# `op` v
 3160   | Just op <- isPrimOpId_maybe f
 3161   , LitNumber _ x <- l
 3162   , Just adjust_lit <- adjustDyadicLeft x op
 3163   = Just (v, tx_lit_con platform adjust_lit
 3164            , \v -> (App (App (Var f) (Lit l)) (Var v)))
 3165 
 3166 
 3167 caseRules platform (App (Var f) v              )   -- op v
 3168   | Just op <- isPrimOpId_maybe f
 3169   , Just adjust_lit <- adjustUnary op
 3170   = Just (v, tx_lit_con platform adjust_lit
 3171            , \v -> App (Var f) (Var v))
 3172 
 3173 -- See Note [caseRules for tagToEnum]
 3174 caseRules platform (App (App (Var f) type_arg) v)
 3175   | Just TagToEnumOp <- isPrimOpId_maybe f
 3176   = Just (v, tx_con_tte platform
 3177            , \v -> (App (App (Var f) type_arg) (Var v)))
 3178 
 3179 -- See Note [caseRules for dataToTag]
 3180 caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x
 3181   | Just DataToTagOp <- isPrimOpId_maybe f
 3182   , Just (tc, _) <- tcSplitTyConApp_maybe ty
 3183   , isAlgTyCon tc
 3184   = Just (v, tx_con_dtt ty
 3185            , \v -> App (App (Var f) (Type ty)) (Var v))
 3186 
 3187 caseRules _ _ = Nothing
 3188 
 3189 
 3190 tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon
 3191 tx_lit_con _        _      DEFAULT    = Just DEFAULT
 3192 tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)
 3193 tx_lit_con _        _      alt        = pprPanic "caseRules" (ppr alt)
 3194    -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the
 3195    -- literal alternatives remain in Word/Int target ranges
 3196    -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172).
 3197 
 3198 adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
 3199 -- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x
 3200 adjustDyadicRight op lit
 3201   = case op of
 3202          WordAddOp -> Just (\y -> y-lit      )
 3203          IntAddOp  -> Just (\y -> y-lit      )
 3204          WordSubOp -> Just (\y -> y+lit      )
 3205          IntSubOp  -> Just (\y -> y+lit      )
 3206          WordXorOp -> Just (\y -> y `xor` lit)
 3207          IntXorOp  -> Just (\y -> y `xor` lit)
 3208          _         -> Nothing
 3209 
 3210 adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
 3211 -- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x
 3212 adjustDyadicLeft lit op
 3213   = case op of
 3214          WordAddOp -> Just (\y -> y-lit      )
 3215          IntAddOp  -> Just (\y -> y-lit      )
 3216          WordSubOp -> Just (\y -> lit-y      )
 3217          IntSubOp  -> Just (\y -> lit-y      )
 3218          WordXorOp -> Just (\y -> y `xor` lit)
 3219          IntXorOp  -> Just (\y -> y `xor` lit)
 3220          _         -> Nothing
 3221 
 3222 
 3223 adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
 3224 -- Given (op x) return a function 'f' s.t.  f (op x) = x
 3225 adjustUnary op
 3226   = case op of
 3227          WordNotOp -> Just (\y -> complement y)
 3228          IntNotOp  -> Just (\y -> complement y)
 3229          IntNegOp  -> Just (\y -> negate y    )
 3230          _         -> Nothing
 3231 
 3232 tx_con_tte :: Platform -> AltCon -> Maybe AltCon
 3233 tx_con_tte _        DEFAULT         = Just DEFAULT
 3234 tx_con_tte _        alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
 3235 tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]
 3236   = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc
 3237 
 3238 tx_con_dtt :: Type -> AltCon -> Maybe AltCon
 3239 tx_con_dtt _  DEFAULT = Just DEFAULT
 3240 tx_con_dtt ty (LitAlt (LitNumber LitNumInt i))
 3241    | tag >= 0
 3242    , tag < n_data_cons
 3243    = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)
 3244    | otherwise
 3245    = Nothing
 3246    where
 3247      tag         = fromInteger i :: ConTagZ
 3248      tc          = tyConAppTyCon ty
 3249      n_data_cons = tyConFamilySize tc
 3250      data_cons   = tyConDataCons tc
 3251 
 3252 tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
 3253 
 3254 
 3255 {- Note [caseRules for tagToEnum]
 3256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 3257 We want to transform
 3258    case tagToEnum x of
 3259      False -> e1
 3260      True  -> e2
 3261 into
 3262    case x of
 3263      0# -> e1
 3264      1# -> e2
 3265 
 3266 This rule eliminates a lot of boilerplate. For
 3267   if (x>y) then e2 else e1
 3268 we generate
 3269   case tagToEnum (x ># y) of
 3270     False -> e1
 3271     True  -> e2
 3272 and it is nice to then get rid of the tagToEnum.
 3273 
 3274 Beware (#14768): avoid the temptation to map constructor 0 to
 3275 DEFAULT, in the hope of getting this
 3276   case (x ># y) of
 3277     DEFAULT -> e1
 3278     1#      -> e2
 3279 That fails utterly in the case of
 3280    data Colour = Red | Green | Blue
 3281    case tagToEnum x of
 3282       DEFAULT -> e1
 3283       Red     -> e2
 3284 
 3285 We don't want to get this!
 3286    case x of
 3287       DEFAULT -> e1
 3288       DEFAULT -> e2
 3289 
 3290 Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils
 3291 (add_default in mkCase3).
 3292 
 3293 Note [caseRules for dataToTag]
 3294 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 3295 See also Note [dataToTag#] in primpops.txt.pp
 3296 
 3297 We want to transform
 3298   case dataToTag x of
 3299     DEFAULT -> e1
 3300     1# -> e2
 3301 into
 3302   case x of
 3303     DEFAULT -> e1
 3304     (:) _ _ -> e2
 3305 
 3306 Note the need for some wildcard binders in
 3307 the 'cons' case.
 3308 
 3309 For the time, we only apply this transformation when the type of `x` is a type
 3310 headed by a normal tycon. In particular, we do not apply this in the case of a
 3311 data family tycon, since that would require carefully applying coercion(s)
 3312 between the data family and the data family instance's representation type,
 3313 which caseRules isn't currently engineered to handle (#14680).
 3314 
 3315 Note [Unreachable caseRules alternatives]
 3316 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 3317 Take care if we see something like
 3318   case dataToTag x of
 3319     DEFAULT -> e1
 3320     -1# -> e2
 3321     100 -> e3
 3322 because there isn't a data constructor with tag -1 or 100. In this case the
 3323 out-of-range alternative is dead code -- we know the range of tags for x.
 3324 
 3325 Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating
 3326 an alternative that is unreachable.
 3327 
 3328 You may wonder how this can happen: check out #15436.
 3329 -}