{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[ConFold]{Constant Folder}

Conceptually, constant folding should be parameterized with the kind
of target machine to get identical behaviour during compilation time
and runtime. We cheat a little bit here...

ToDo:
   check boundaries before folding, e.g. we can fold the Float addition
   (i1 + i2) only if it results in a valid Float.
-}

{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,
    DeriveFunctor #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}

module PrelRules
   ( primOpRules
   , builtinRules
   , caseRules
   )
where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )

import CoreSyn
import MkCore
import Id
import Literal
import CoreOpt     ( exprIsLiteral_maybe )
import PrimOp      ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
import TyCon       ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
                   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons
                   , tyConFamilySize )
import DataCon     ( dataConTagZ, dataConTyCon, dataConWorkId )
import CoreUtils   ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType, stripTicksTop, stripTicksTopT, mkTicks )
import CoreUnfold  ( exprIsConApp_maybe )
import Type
import OccName     ( occNameFS )
import PrelNames
import Maybes      ( orElse )
import Name        ( Name, nameOccName )
import Outputable
import FastString
import BasicTypes
import DynFlags
import GHC.Platform
import Util
import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))

import Control.Applicative ( Alternative(..) )

import Control.Monad
import qualified Control.Monad.Fail as MonadFail
import Data.Bits as Bits
import qualified Data.ByteString as BS
import Data.Int
import Data.Ratio
import Data.Word

{-
Note [Constant folding]
~~~~~~~~~~~~~~~~~~~~~~~
primOpRules generates a rewrite rule for each primop
These rules do what is often called "constant folding"
E.g. the rules for +# might say
        4 +# 5 = 9
Well, of course you'd need a lot of rules if you did it
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values.  So the rule is really
more like
        (Lit x) +# (Lit y) = Lit (x+#y)
where the (+#) on the rhs is done at compile time

That is why these rules are built in here.
-}

primOpRules :: Name -> PrimOp -> Maybe CoreRule
    -- ToDo: something for integer-shift ops?
    --       NotOp
primOpRules :: Name -> PrimOp -> Maybe CoreRule
primOpRules Name
nm PrimOp
TagToEnumOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ RuleM CoreExpr
tagToEnumRule ]
primOpRules Name
nm PrimOp
DataToTagOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ RuleM CoreExpr
dataToTagRule ]

-- Int operations
primOpRules Name
nm PrimOp
IntAddOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
zeroi
                                               , PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
IntAddOp DynFlags -> PrimOps
intPrimOps
                                               ]
primOpRules Name
nm PrimOp
IntSubOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 (-))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zeroi
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zeroi
                                               , PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
IntSubOp DynFlags -> PrimOps
intPrimOps
                                               ]
primOpRules Name
nm PrimOp
IntAddCOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOpC2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityCDynFlags DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
IntSubCOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOpC2 (-))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityCDynFlags DynFlags -> Literal
zeroi
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLitNoC DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
IntMulOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
zeroElem DynFlags -> Literal
zeroi
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
onei
                                               , PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
IntMulOp DynFlags -> PrimOps
intPrimOps
                                               ]
primOpRules Name
nm PrimOp
IntQuotOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ Int -> RuleM ()
nonZeroLit Int
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
leftZero DynFlags -> Literal
zeroi
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
onei
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
onei ]
primOpRules Name
nm PrimOp
IntRemOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ Int -> RuleM ()
nonZeroLit Int
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
leftZero DynFlags -> Literal
zeroi
                                               , do Literal
l <- Int -> RuleM Literal
getLiteral Int
1
                                                    DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                                                    Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
onei DynFlags
dflags)
                                                    (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zeroi
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zeroi
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
AndIOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.))
                                               , RuleM CoreExpr
idempotent
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
zeroElem DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
OrIOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.))
                                               , RuleM CoreExpr
idempotent
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
XorIOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
zeroi
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
NotIOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
complementOp
                                               , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
NotIOp ]
primOpRules Name
nm PrimOp
IntNegOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
negOp
                                               , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
IntNegOp ]
primOpRules Name
nm PrimOp
ISllOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule ((Integer -> Int -> Integer)
-> DynFlags -> Integer -> Int -> Integer
forall a b. a -> b -> a
const Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
Bits.shiftL)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
ISraOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule ((Integer -> Int -> Integer)
-> DynFlags -> Integer -> Int -> Integer
forall a b. a -> b -> a
const Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
Bits.shiftR)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zeroi ]
primOpRules Name
nm PrimOp
ISrlOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule DynFlags -> Integer -> Int -> Integer
shiftRightLogical
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zeroi ]

-- Word operations
primOpRules Name
nm PrimOp
WordAddOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
zerow
                                               , PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
WordAddOp DynFlags -> PrimOps
wordPrimOps
                                               ]
primOpRules Name
nm PrimOp
WordSubOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 (-))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zerow
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zerow
                                               , PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
WordSubOp DynFlags -> PrimOps
wordPrimOps
                                               ]
primOpRules Name
nm PrimOp
WordAddCOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityCDynFlags DynFlags -> Literal
zerow ]
primOpRules Name
nm PrimOp
WordSubCOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 (-))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityCDynFlags DynFlags -> Literal
zerow
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLitNoC DynFlags -> Literal
zerow ]
primOpRules Name
nm PrimOp
WordMulOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
onew
                                               , PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
WordMulOp DynFlags -> PrimOps
wordPrimOps
                                               ]
primOpRules Name
nm PrimOp
WordQuotOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ Int -> RuleM ()
nonZeroLit Int
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
onew ]
primOpRules Name
nm PrimOp
WordRemOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ Int -> RuleM ()
nonZeroLit Int
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
leftZero DynFlags -> Literal
zerow
                                               , do Literal
l <- Int -> RuleM Literal
getLiteral Int
1
                                                    DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                                                    Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
onew DynFlags
dflags)
                                                    (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zerow
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zerow ]
primOpRules Name
nm PrimOp
AndOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.))
                                               , RuleM CoreExpr
idempotent
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
zeroElem DynFlags -> Literal
zerow ]
primOpRules Name
nm PrimOp
OrOp        = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.))
                                               , RuleM CoreExpr
idempotent
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
zerow ]
primOpRules Name
nm PrimOp
XorOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor)
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
zerow
                                               , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
zerow ]
primOpRules Name
nm PrimOp
NotOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
complementOp
                                               , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
NotOp ]
primOpRules Name
nm PrimOp
SllOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule ((Integer -> Int -> Integer)
-> DynFlags -> Integer -> Int -> Integer
forall a b. a -> b -> a
const Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
Bits.shiftL) ]
primOpRules Name
nm PrimOp
SrlOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule DynFlags -> Integer -> Int -> Integer
shiftRightLogical ]

-- coercions
primOpRules Name
nm PrimOp
Word2IntOp     = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags DynFlags -> Literal -> Literal
word2IntLit
                                                  , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
Int2WordOp ]
primOpRules Name
nm PrimOp
Int2WordOp     = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags DynFlags -> Literal -> Literal
int2WordLit
                                                  , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
Word2IntOp ]
primOpRules Name
nm PrimOp
Narrow8IntOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrow8IntLit
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow8IntOp
                                                  , PrimOp
Narrow8IntOp PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
Narrow16IntOp
                                                  , PrimOp
Narrow8IntOp PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
Narrow32IntOp ]
primOpRules Name
nm PrimOp
Narrow16IntOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrow16IntLit
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow8IntOp
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow16IntOp
                                                  , PrimOp
Narrow16IntOp PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
Narrow32IntOp ]
primOpRules Name
nm PrimOp
Narrow32IntOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrow32IntLit
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow8IntOp
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow16IntOp
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow32IntOp
                                                  , RuleM CoreExpr
removeOp32 ]
primOpRules Name
nm PrimOp
Narrow8WordOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrow8WordLit
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow8WordOp
                                                  , PrimOp
Narrow8WordOp PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
Narrow16WordOp
                                                  , PrimOp
Narrow8WordOp PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
Narrow32WordOp ]
primOpRules Name
nm PrimOp
Narrow16WordOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrow16WordLit
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow8WordOp
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow16WordOp
                                                  , PrimOp
Narrow16WordOp PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
Narrow32WordOp ]
primOpRules Name
nm PrimOp
Narrow32WordOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrow32WordLit
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow8WordOp
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow16WordOp
                                                  , PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
Narrow32WordOp
                                                  , RuleM CoreExpr
removeOp32 ]
primOpRules Name
nm PrimOp
OrdOp          = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
char2IntLit
                                                  , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
ChrOp ]
primOpRules Name
nm PrimOp
ChrOp          = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ do [Lit Literal
lit] <- RuleM [CoreExpr]
getArgs
                                                       Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal -> Bool
litFitsInChar Literal
lit)
                                                       (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2CharLit
                                                  , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
OrdOp ]
primOpRules Name
nm PrimOp
Float2IntOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
float2IntLit ]
primOpRules Name
nm PrimOp
Int2FloatOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2FloatLit ]
primOpRules Name
nm PrimOp
Double2IntOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
double2IntLit ]
primOpRules Name
nm PrimOp
Int2DoubleOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2DoubleLit ]
-- SUP: Not sure what the standard says about precision in the following 2 cases
primOpRules Name
nm PrimOp
Float2DoubleOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
float2DoubleLit ]
primOpRules Name
nm PrimOp
Double2FloatOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
double2FloatLit ]

-- Float
primOpRules Name
nm PrimOp
FloatAddOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
floatOp2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(+))
                                                , Literal -> RuleM CoreExpr
identity Literal
zerof ]
primOpRules Name
nm PrimOp
FloatSubOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
floatOp2 (-))
                                                , Literal -> RuleM CoreExpr
rightIdentity Literal
zerof ]
primOpRules Name
nm PrimOp
FloatMulOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
floatOp2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(*))
                                                , Literal -> RuleM CoreExpr
identity Literal
onef
                                                , Literal -> PrimOp -> RuleM CoreExpr
strengthReduction Literal
twof PrimOp
FloatAddOp  ]
                         -- zeroElem zerof doesn't hold because of NaN
primOpRules Name
nm PrimOp
FloatDivOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ RuleM ()
guardFloatDiv RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
floatOp2 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
(/))
                                                , Literal -> RuleM CoreExpr
rightIdentity Literal
onef ]
primOpRules Name
nm PrimOp
FloatNegOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
negOp
                                                , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
FloatNegOp ]

-- Double
primOpRules Name
nm PrimOp
DoubleAddOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(+))
                                                 , Literal -> RuleM CoreExpr
identity Literal
zerod ]
primOpRules Name
nm PrimOp
DoubleSubOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 (-))
                                                 , Literal -> RuleM CoreExpr
rightIdentity Literal
zerod ]
primOpRules Name
nm PrimOp
DoubleMulOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(*))
                                                 , Literal -> RuleM CoreExpr
identity Literal
oned
                                                 , Literal -> PrimOp -> RuleM CoreExpr
strengthReduction Literal
twod PrimOp
DoubleAddOp  ]
                          -- zeroElem zerod doesn't hold because of NaN
primOpRules Name
nm PrimOp
DoubleDivOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ RuleM ()
guardDoubleDiv RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
(/))
                                                 , Literal -> RuleM CoreExpr
rightIdentity Literal
oned ]
primOpRules Name
nm PrimOp
DoubleNegOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
negOp
                                                 , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
DoubleNegOp ]

-- Relational operators

primOpRules Name
nm PrimOp
IntEqOp    = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(==) [ Bool -> RuleM CoreExpr
litEq Bool
True ]
primOpRules Name
nm PrimOp
IntNeOp    = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=) [ Bool -> RuleM CoreExpr
litEq Bool
False ]
primOpRules Name
nm PrimOp
CharEqOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(==) [ Bool -> RuleM CoreExpr
litEq Bool
True ]
primOpRules Name
nm PrimOp
CharNeOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=) [ Bool -> RuleM CoreExpr
litEq Bool
False ]

primOpRules Name
nm PrimOp
IntGtOp    = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
primOpRules Name
nm PrimOp
IntGeOp    = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
primOpRules Name
nm PrimOp
IntLeOp    = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
primOpRules Name
nm PrimOp
IntLtOp    = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

primOpRules Name
nm PrimOp
CharGtOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
primOpRules Name
nm PrimOp
CharGeOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
primOpRules Name
nm PrimOp
CharLeOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
primOpRules Name
nm PrimOp
CharLtOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

primOpRules Name
nm PrimOp
FloatGtOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>)
primOpRules Name
nm PrimOp
FloatGeOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>=)
primOpRules Name
nm PrimOp
FloatLeOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<=)
primOpRules Name
nm PrimOp
FloatLtOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<)
primOpRules Name
nm PrimOp
FloatEqOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(==)
primOpRules Name
nm PrimOp
FloatNeOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=)

primOpRules Name
nm PrimOp
DoubleGtOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>)
primOpRules Name
nm PrimOp
DoubleGeOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>=)
primOpRules Name
nm PrimOp
DoubleLeOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<=)
primOpRules Name
nm PrimOp
DoubleLtOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<)
primOpRules Name
nm PrimOp
DoubleEqOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(==)
primOpRules Name
nm PrimOp
DoubleNeOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=)

primOpRules Name
nm PrimOp
WordGtOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
primOpRules Name
nm PrimOp
WordGeOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
primOpRules Name
nm PrimOp
WordLeOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
primOpRules Name
nm PrimOp
WordLtOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]
primOpRules Name
nm PrimOp
WordEqOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(==) [ Bool -> RuleM CoreExpr
litEq Bool
True ]
primOpRules Name
nm PrimOp
WordNeOp   = Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=) [ Bool -> RuleM CoreExpr
litEq Bool
False ]

primOpRules Name
nm PrimOp
AddrAddOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [ (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zeroi ]

primOpRules Name
nm PrimOp
SeqOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
4 [ RuleM CoreExpr
seqRule ]
primOpRules Name
nm PrimOp
SparkOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
4 [ RuleM CoreExpr
sparkRule ]

primOpRules Name
_  PrimOp
_          = Maybe CoreRule
forall a. Maybe a
Nothing

{-
************************************************************************
*                                                                      *
\subsection{Doing the business}
*                                                                      *
************************************************************************
-}

-- useful shorthands
mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
arity [RuleM CoreExpr]
rules = CoreRule -> Maybe CoreRule
forall a. a -> Maybe a
Just (CoreRule -> Maybe CoreRule) -> CoreRule -> Maybe CoreRule
forall a b. (a -> b) -> a -> b
$ Name -> Int -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
nm Int
arity ([RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [RuleM CoreExpr]
rules)

mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
            -> [RuleM CoreExpr] -> Maybe CoreRule
mkRelOpRule :: Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
cmp [RuleM CoreExpr]
extra
  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 ([RuleM CoreExpr] -> Maybe CoreRule)
-> [RuleM CoreExpr] -> Maybe CoreRule
forall a b. (a -> b) -> a -> b
$
    (forall a. Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit forall a. Ord a => a -> a -> Bool
cmp RuleM CoreExpr -> [RuleM CoreExpr] -> [RuleM CoreExpr]
forall a. a -> [a] -> [a]
: RuleM CoreExpr
equal_rule RuleM CoreExpr -> [RuleM CoreExpr] -> [RuleM CoreExpr]
forall a. a -> [a] -> [a]
: [RuleM CoreExpr]
extra
  where
        -- x `cmp` x does not depend on x, so
        -- compute it for the arbitrary value 'True'
        -- and use that result
    equal_rule :: RuleM CoreExpr
equal_rule = do { RuleM ()
equalArgs
                    ; DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                    ; CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
cmp Bool
True Bool
True
                              then DynFlags -> CoreExpr
trueValInt  DynFlags
dflags
                              else DynFlags -> CoreExpr
falseValInt DynFlags
dflags) }

{- Note [Rules for floating-point comparisons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need different rules for floating-point values because for floats
it is not true that x = x (for NaNs); so we do not want the equal_rule
rule that mkRelOpRule uses.

Note also that, in the case of equality/inequality, we do /not/
want to switch to a case-expression.  For example, we do not want
to convert
   case (eqFloat# x 3.8#) of
     True -> this
     False -> that
to
  case x of
    3.8#::Float# -> this
    _            -> that
See #9238.  Reason: comparing floating-point values for equality
delicate, and we don't want to implement that delicacy in the code for
case expressions.  So we make it an invariant of Core that a case
expression never scrutinises a Float# or Double#.

This transformation is what the litEq rule does;
see Note [The litEq rule: converting equality to case].
So we /refrain/ from using litEq for mkFloatingRelOpRule.
-}

mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
                    -> Maybe CoreRule
-- See Note [Rules for floating-point comparisons]
mkFloatingRelOpRule :: Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
cmp
  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm Int
2 [(forall a. Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit forall a. Ord a => a -> a -> Bool
cmp]

-- common constants
zeroi, onei, zerow, onew :: DynFlags -> Literal
zeroi :: DynFlags -> Literal
zeroi DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitInt  DynFlags
dflags Integer
0
onei :: DynFlags -> Literal
onei  DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitInt  DynFlags
dflags Integer
1
zerow :: DynFlags -> Literal
zerow DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitWord DynFlags
dflags Integer
0
onew :: DynFlags -> Literal
onew  DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitWord DynFlags
dflags Integer
1

zerof, onef, twof, zerod, oned, twod :: Literal
zerof :: Literal
zerof = Rational -> Literal
mkLitFloat Rational
0.0
onef :: Literal
onef  = Rational -> Literal
mkLitFloat Rational
1.0
twof :: Literal
twof  = Rational -> Literal
mkLitFloat Rational
2.0
zerod :: Literal
zerod = Rational -> Literal
mkLitDouble Rational
0.0
oned :: Literal
oned  = Rational -> Literal
mkLitDouble Rational
1.0
twod :: Literal
twod  = Rational -> Literal
mkLitDouble Rational
2.0

cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
      -> Literal -> Literal -> Maybe CoreExpr
cmpOp :: DynFlags
-> (forall a. Ord a => a -> a -> Bool)
-> Literal
-> Literal
-> Maybe CoreExpr
cmpOp DynFlags
dflags forall a. Ord a => a -> a -> Bool
cmp = Literal -> Literal -> Maybe CoreExpr
go
  where
    done :: Bool -> Maybe CoreExpr
done Bool
True  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
trueValInt  DynFlags
dflags
    done Bool
False = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
falseValInt DynFlags
dflags

    -- These compares are at different types
    go :: Literal -> Literal -> Maybe CoreExpr
go (LitChar Char
i1)   (LitChar Char
i2)   = Bool -> Maybe CoreExpr
done (Char
i1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
`cmp` Char
i2)
    go (LitFloat Rational
i1)  (LitFloat Rational
i2)  = Bool -> Maybe CoreExpr
done (Rational
i1 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
`cmp` Rational
i2)
    go (LitDouble Rational
i1) (LitDouble Rational
i2) = Bool -> Maybe CoreExpr
done (Rational
i1 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
`cmp` Rational
i2)
    go (LitNumber LitNumType
nt1 Integer
i1 Type
_) (LitNumber LitNumType
nt2 Integer
i2 Type
_)
      | LitNumType
nt1 LitNumType -> LitNumType -> Bool
forall a. Eq a => a -> a -> Bool
/= LitNumType
nt2 = Maybe CoreExpr
forall a. Maybe a
Nothing
      | Bool
otherwise  = Bool -> Maybe CoreExpr
done (Integer
i1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
`cmp` Integer
i2)
    go Literal
_               Literal
_               = Maybe CoreExpr
forall a. Maybe a
Nothing

--------------------------

negOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Negate
negOp :: DynFlags -> Literal -> Maybe CoreExpr
negOp DynFlags
_      (LitFloat Rational
0.0)  = Maybe CoreExpr
forall a. Maybe a
Nothing  -- can't represent -0.0 as a Rational
negOp DynFlags
dflags (LitFloat Rational
f)    = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Rational -> CoreExpr
mkFloatVal DynFlags
dflags (-Rational
f))
negOp DynFlags
_      (LitDouble Rational
0.0) = Maybe CoreExpr
forall a. Maybe a
Nothing
negOp DynFlags
dflags (LitDouble Rational
d)   = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Rational -> CoreExpr
mkDoubleVal DynFlags
dflags (-Rational
d))
negOp DynFlags
dflags (LitNumber LitNumType
nt Integer
i Type
t)
   | LitNumType -> Bool
litNumIsSigned LitNumType
nt = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumberWrap DynFlags
dflags LitNumType
nt (-Integer
i) Type
t))
negOp DynFlags
_      Literal
_                = Maybe CoreExpr
forall a. Maybe a
Nothing

complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement
complementOp :: DynFlags -> Literal -> Maybe CoreExpr
complementOp DynFlags
dflags (LitNumber LitNumType
nt Integer
i Type
t) =
   CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumberWrap DynFlags
dflags LitNumType
nt (Integer -> Integer
forall a. Bits a => a -> a
complement Integer
i) Type
t))
complementOp DynFlags
_      Literal
_            = Maybe CoreExpr
forall a. Maybe a
Nothing

--------------------------
intOp2 :: (Integral a, Integral b)
       => (a -> b -> Integer)
       -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 :: (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 = (DynFlags -> a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(DynFlags -> a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2' ((DynFlags -> a -> b -> Integer)
 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> ((a -> b -> Integer) -> DynFlags -> a -> b -> Integer)
-> (a -> b -> Integer)
-> DynFlags
-> Literal
-> Literal
-> Maybe CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> Integer) -> DynFlags -> a -> b -> Integer
forall a b. a -> b -> a
const

intOp2' :: (Integral a, Integral b)
        => (DynFlags -> a -> b -> Integer)
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2' :: (DynFlags -> a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2' DynFlags -> a -> b -> Integer
op DynFlags
dflags (LitNumber LitNumType
LitNumInt Integer
i1 Type
_) (LitNumber LitNumType
LitNumInt Integer
i2 Type
_) =
  let o :: a -> b -> Integer
o = DynFlags -> a -> b -> Integer
op DynFlags
dflags
  in  DynFlags -> Integer -> Maybe CoreExpr
intResult DynFlags
dflags (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i1 a -> b -> Integer
`o` Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
i2)
intOp2' DynFlags -> a -> b -> Integer
_  DynFlags
_      Literal
_            Literal
_            = Maybe CoreExpr
forall a. Maybe a
Nothing  -- Could find LitLit

intOpC2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOpC2 :: (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOpC2 a -> b -> Integer
op DynFlags
dflags (LitNumber LitNumType
LitNumInt Integer
i1 Type
_) (LitNumber LitNumType
LitNumInt Integer
i2 Type
_) = do
  DynFlags -> Integer -> Maybe CoreExpr
intCResult DynFlags
dflags (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i1 a -> b -> Integer
`op` Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
i2)
intOpC2 a -> b -> Integer
_  DynFlags
_      Literal
_            Literal
_            = Maybe CoreExpr
forall a. Maybe a
Nothing  -- Could find LitLit

shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
-- Do this by converting to Word and back.  Obviously this won't work for big
-- values, but its ok as we use it here
shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
shiftRightLogical DynFlags
dflags Integer
x Int
n =
    case Platform -> PlatformWordSize
platformWordSize (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
      PlatformWordSize
PW4 -> Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
x Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
n :: Word32)
      PlatformWordSize
PW8 -> Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
x Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
n :: Word64)

--------------------------
retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit DynFlags -> Literal
l = do DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
              CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Literal
l DynFlags
dflags

retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr
retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr
retLitNoC DynFlags -> Literal
l = do DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                 let lit :: Literal
lit = DynFlags -> Literal
l DynFlags
dflags
                 let ty :: Type
ty = Literal -> Type
literalType Literal
lit
                 CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type
ty, Type
ty] [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Literal
zeroi DynFlags
dflags)]

wordOp2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 :: (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 a -> b -> Integer
op DynFlags
dflags (LitNumber LitNumType
LitNumWord Integer
w1 Type
_) (LitNumber LitNumType
LitNumWord Integer
w2 Type
_)
    = DynFlags -> Integer -> Maybe CoreExpr
wordResult DynFlags
dflags (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
w1 a -> b -> Integer
`op` Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
w2)
wordOp2 a -> b -> Integer
_ DynFlags
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing  -- Could find LitLit

wordOpC2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 :: (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 a -> b -> Integer
op DynFlags
dflags (LitNumber LitNumType
LitNumWord Integer
w1 Type
_) (LitNumber LitNumType
LitNumWord Integer
w2 Type
_) =
  DynFlags -> Integer -> Maybe CoreExpr
wordCResult DynFlags
dflags (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
w1 a -> b -> Integer
`op` Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
w2)
wordOpC2 a -> b -> Integer
_ DynFlags
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing  -- Could find LitLit

shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
-- Shifts take an Int; hence third arg of op is Int
-- Used for shift primops
--    ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word#
--    SllOp, SrlOp           :: Word# -> Int# -> Word#
shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule DynFlags -> Integer -> Int -> Integer
shift_op
  = do { DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; [CoreExpr
e1, Lit (LitNumber LitNumType
LitNumInt Integer
shift_len Type
_)] <- RuleM [CoreExpr]
getArgs
       ; case CoreExpr
e1 of
           CoreExpr
_ | Integer
shift_len Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e1
             -- See Note [Guarding against silly shifts]
             | Integer
shift_len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
shift_len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> DynFlags -> Integer
wordSizeInBits DynFlags
dflags
             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumberWrap DynFlags
dflags LitNumType
LitNumInt Integer
0 (CoreExpr -> Type
exprType CoreExpr
e1)

           -- Do the shift at type Integer, but shift length is Int
           Lit (LitNumber LitNumType
nt Integer
x Type
t)
             | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
shift_len
             , Integer
shift_len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Integer
wordSizeInBits DynFlags
dflags
             -> let op :: Integer -> Int -> Integer
op = DynFlags -> Integer -> Int -> Integer
shift_op DynFlags
dflags
                    y :: Integer
y  = Integer
x Integer -> Int -> Integer
`op` Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
shift_len
                in  Maybe CoreExpr -> RuleM CoreExpr
forall a. Maybe a -> RuleM a
liftMaybe (Maybe CoreExpr -> RuleM CoreExpr)
-> Maybe CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumberWrap DynFlags
dflags LitNumType
nt Integer
y Type
t))

           CoreExpr
_ -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero }

wordSizeInBits :: DynFlags -> Integer
wordSizeInBits :: DynFlags -> Integer
wordSizeInBits DynFlags
dflags = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Platform -> Int
platformWordSizeInBits (DynFlags -> Platform
targetPlatform DynFlags
dflags))

--------------------------
floatOp2 :: (Rational -> Rational -> Rational)
         -> DynFlags -> Literal -> Literal
         -> Maybe (Expr CoreBndr)
floatOp2 :: (Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
floatOp2 Rational -> Rational -> Rational
op DynFlags
dflags (LitFloat Rational
f1) (LitFloat Rational
f2)
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Rational -> CoreExpr
mkFloatVal DynFlags
dflags (Rational
f1 Rational -> Rational -> Rational
`op` Rational
f2))
floatOp2 Rational -> Rational -> Rational
_ DynFlags
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

--------------------------
doubleOp2 :: (Rational -> Rational -> Rational)
          -> DynFlags -> Literal -> Literal
          -> Maybe (Expr CoreBndr)
doubleOp2 :: (Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 Rational -> Rational -> Rational
op DynFlags
dflags (LitDouble Rational
f1) (LitDouble Rational
f2)
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Rational -> CoreExpr
mkDoubleVal DynFlags
dflags (Rational
f1 Rational -> Rational -> Rational
`op` Rational
f2))
doubleOp2 Rational -> Rational -> Rational
_ DynFlags
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

--------------------------
{- Note [The litEq rule: converting equality to case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This stuff turns
     n ==# 3#
into
     case n of
       3# -> True
       m  -> False

This is a Good Thing, because it allows case-of case things
to happen, and case-default absorption to happen.  For
example:

     if (n ==# 3#) || (n ==# 4#) then e1 else e2
will transform to
     case n of
       3# -> e1
       4# -> e1
       m  -> e2
(modulo the usual precautions to avoid duplicating e1)
-}

litEq :: Bool  -- True <=> equality, False <=> inequality
      -> RuleM CoreExpr
litEq :: Bool -> RuleM CoreExpr
litEq Bool
is_eq = [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
  [ do [Lit Literal
lit, CoreExpr
expr] <- RuleM [CoreExpr]
getArgs
       DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       DynFlags -> Literal -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *).
(Monad m, Alternative m) =>
DynFlags -> Literal -> CoreExpr -> m CoreExpr
do_lit_eq DynFlags
dflags Literal
lit CoreExpr
expr
  , do [CoreExpr
expr, Lit Literal
lit] <- RuleM [CoreExpr]
getArgs
       DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       DynFlags -> Literal -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *).
(Monad m, Alternative m) =>
DynFlags -> Literal -> CoreExpr -> m CoreExpr
do_lit_eq DynFlags
dflags Literal
lit CoreExpr
expr ]
  where
    do_lit_eq :: DynFlags -> Literal -> CoreExpr -> m CoreExpr
do_lit_eq DynFlags
dflags Literal
lit CoreExpr
expr = do
      Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Literal -> Bool
litIsLifted Literal
lit))
      CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
expr (Literal -> Type
literalType Literal
lit) Type
intPrimTy
                    [(AltCon
DEFAULT,    [], CoreExpr
val_if_neq),
                     (Literal -> AltCon
LitAlt Literal
lit, [], CoreExpr
val_if_eq)])
      where
        val_if_eq :: CoreExpr
val_if_eq  | Bool
is_eq     = DynFlags -> CoreExpr
trueValInt  DynFlags
dflags
                   | Bool
otherwise = DynFlags -> CoreExpr
falseValInt DynFlags
dflags
        val_if_neq :: CoreExpr
val_if_neq | Bool
is_eq     = DynFlags -> CoreExpr
falseValInt DynFlags
dflags
                   | Bool
otherwise = DynFlags -> CoreExpr
trueValInt  DynFlags
dflags


-- | Check if there is comparison with minBound or maxBound, that is
-- always true or false. For instance, an Int cannot be smaller than its
-- minBound, so we can replace such comparison with False.
boundsCmp :: Comparison -> RuleM CoreExpr
boundsCmp :: Comparison -> RuleM CoreExpr
boundsCmp Comparison
op = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [CoreExpr
a, CoreExpr
b] <- RuleM [CoreExpr]
getArgs
  Maybe CoreExpr -> RuleM CoreExpr
forall a. Maybe a -> RuleM a
liftMaybe (Maybe CoreExpr -> RuleM CoreExpr)
-> Maybe CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
mkRuleFn DynFlags
dflags Comparison
op CoreExpr
a CoreExpr
b

data Comparison = Gt | Ge | Lt | Le

mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
mkRuleFn DynFlags
dflags Comparison
Gt (Lit Literal
lit) CoreExpr
_ | DynFlags -> Literal -> Bool
isMinBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
falseValInt DynFlags
dflags
mkRuleFn DynFlags
dflags Comparison
Le (Lit Literal
lit) CoreExpr
_ | DynFlags -> Literal -> Bool
isMinBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
trueValInt  DynFlags
dflags
mkRuleFn DynFlags
dflags Comparison
Ge CoreExpr
_ (Lit Literal
lit) | DynFlags -> Literal -> Bool
isMinBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
trueValInt  DynFlags
dflags
mkRuleFn DynFlags
dflags Comparison
Lt CoreExpr
_ (Lit Literal
lit) | DynFlags -> Literal -> Bool
isMinBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
falseValInt DynFlags
dflags
mkRuleFn DynFlags
dflags Comparison
Ge (Lit Literal
lit) CoreExpr
_ | DynFlags -> Literal -> Bool
isMaxBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
trueValInt  DynFlags
dflags
mkRuleFn DynFlags
dflags Comparison
Lt (Lit Literal
lit) CoreExpr
_ | DynFlags -> Literal -> Bool
isMaxBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
falseValInt DynFlags
dflags
mkRuleFn DynFlags
dflags Comparison
Gt CoreExpr
_ (Lit Literal
lit) | DynFlags -> Literal -> Bool
isMaxBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
falseValInt DynFlags
dflags
mkRuleFn DynFlags
dflags Comparison
Le CoreExpr
_ (Lit Literal
lit) | DynFlags -> Literal -> Bool
isMaxBound DynFlags
dflags Literal
lit = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> CoreExpr
trueValInt  DynFlags
dflags
mkRuleFn DynFlags
_ Comparison
_ CoreExpr
_ CoreExpr
_                                       = Maybe CoreExpr
forall a. Maybe a
Nothing

isMinBound :: DynFlags -> Literal -> Bool
isMinBound :: DynFlags -> Literal -> Bool
isMinBound DynFlags
_      (LitChar Char
c)        = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
minBound
isMinBound DynFlags
dflags (LitNumber LitNumType
nt Integer
i Type
_) = case LitNumType
nt of
   LitNumType
LitNumInt     -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Integer
tARGET_MIN_INT DynFlags
dflags
   LitNumType
LitNumInt64   -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
minBound :: Int64)
   LitNumType
LitNumWord    -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
   LitNumType
LitNumWord64  -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
   LitNumType
LitNumNatural -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
   LitNumType
LitNumInteger -> Bool
False
isMinBound DynFlags
_      Literal
_                  = Bool
False

isMaxBound :: DynFlags -> Literal -> Bool
isMaxBound :: DynFlags -> Literal -> Bool
isMaxBound DynFlags
_      (LitChar Char
c)       = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
maxBound
isMaxBound DynFlags
dflags (LitNumber LitNumType
nt Integer
i Type
_) = case LitNumType
nt of
   LitNumType
LitNumInt     -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Integer
tARGET_MAX_INT DynFlags
dflags
   LitNumType
LitNumInt64   -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64)
   LitNumType
LitNumWord    -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Integer
tARGET_MAX_WORD DynFlags
dflags
   LitNumType
LitNumWord64  -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64
forall a. Bounded a => a
maxBound :: Word64)
   LitNumType
LitNumNatural -> Bool
False
   LitNumType
LitNumInteger -> Bool
False
isMaxBound DynFlags
_      Literal
_                  = Bool
False

-- | Create an Int literal expression while ensuring the given Integer is in the
-- target Int range
intResult :: DynFlags -> Integer -> Maybe CoreExpr
intResult :: DynFlags -> Integer -> Maybe CoreExpr
intResult DynFlags
dflags Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Integer -> CoreExpr
intResult' DynFlags
dflags Integer
result)

intResult' :: DynFlags -> Integer -> CoreExpr
intResult' :: DynFlags -> Integer -> CoreExpr
intResult' DynFlags
dflags Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitIntWrap DynFlags
dflags Integer
result)

-- | Create an unboxed pair of an Int literal expression, ensuring the given
-- Integer is in the target Int range and the corresponding overflow flag
-- (@0#@/@1#@) if it wasn't.
intCResult :: DynFlags -> Integer -> Maybe CoreExpr
intCResult :: DynFlags -> Integer -> Maybe CoreExpr
intCResult DynFlags
dflags Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([CoreExpr] -> CoreExpr
mkPair [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
c])
  where
    mkPair :: [CoreExpr] -> CoreExpr
mkPair = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type
intPrimTy, Type
intPrimTy]
    (Literal
lit, Bool
b) = DynFlags -> Integer -> (Literal, Bool)
mkLitIntWrapC DynFlags
dflags Integer
result
    c :: Literal
c = if Bool
b then DynFlags -> Literal
onei DynFlags
dflags else DynFlags -> Literal
zeroi DynFlags
dflags

-- | Create a Word literal expression while ensuring the given Integer is in the
-- target Word range
wordResult :: DynFlags -> Integer -> Maybe CoreExpr
wordResult :: DynFlags -> Integer -> Maybe CoreExpr
wordResult DynFlags
dflags Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Integer -> CoreExpr
wordResult' DynFlags
dflags Integer
result)

wordResult' :: DynFlags -> Integer -> CoreExpr
wordResult' :: DynFlags -> Integer -> CoreExpr
wordResult' DynFlags
dflags Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitWordWrap DynFlags
dflags Integer
result)

-- | Create an unboxed pair of a Word literal expression, ensuring the given
-- Integer is in the target Word range and the corresponding carry flag
-- (@0#@/@1#@) if it wasn't.
wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
wordCResult DynFlags
dflags Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([CoreExpr] -> CoreExpr
mkPair [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
c])
  where
    mkPair :: [CoreExpr] -> CoreExpr
mkPair = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type
wordPrimTy, Type
intPrimTy]
    (Literal
lit, Bool
b) = DynFlags -> Integer -> (Literal, Bool)
mkLitWordWrapC DynFlags
dflags Integer
result
    c :: Literal
c = if Bool
b then DynFlags -> Literal
onei DynFlags
dflags else DynFlags -> Literal
zeroi DynFlags
dflags

inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
primop = do
  [Var CoreBndr
primop_id `App` CoreExpr
e] <- RuleM [CoreExpr]
getArgs
  PrimOp -> CoreBndr -> RuleM ()
matchPrimOpId PrimOp
primop CoreBndr
primop_id
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e

subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
PrimOp
this subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
that = do
  [Var CoreBndr
primop_id `App` CoreExpr
e] <- RuleM [CoreExpr]
getArgs
  PrimOp -> CoreBndr -> RuleM ()
matchPrimOpId PrimOp
that CoreBndr
primop_id
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (PrimOp -> CoreBndr
mkPrimOpId PrimOp
this) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e)

subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
primop = do
  [e :: CoreExpr
e@(Var CoreBndr
primop_id `App` CoreExpr
_)] <- RuleM [CoreExpr]
getArgs
  PrimOp -> CoreBndr -> RuleM ()
matchPrimOpId PrimOp
primop CoreBndr
primop_id
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e

idempotent :: RuleM CoreExpr
idempotent :: RuleM CoreExpr
idempotent = do [CoreExpr
e1, CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
                Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
cheapEqExpr CoreExpr
e1 CoreExpr
e2
                CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e1

{-
Note [Guarding against silly shifts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this code:

  import Data.Bits( (.|.), shiftL )
  chunkToBitmap :: [Bool] -> Word32
  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]

This optimises to:
Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
    case w1_sCT of _ {
      [] -> 0##;
      : x_aAW xs_aAX ->
        case x_aAW of _ {
          GHC.Types.False ->
            case w_sCS of wild2_Xh {
              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
              9223372036854775807 -> 0## };
          GHC.Types.True ->
            case GHC.Prim.>=# w_sCS 64 of _ {
              GHC.Types.False ->
                case w_sCS of wild3_Xh {
                  __DEFAULT ->
                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
                      GHC.Prim.or# (GHC.Prim.narrow32Word#
                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
                                   ww_sCW
                     };
                  9223372036854775807 ->
                    GHC.Prim.narrow32Word#
!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
                };
              GHC.Types.True ->
                case w_sCS of wild3_Xh {
                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
                  9223372036854775807 -> 0##
                } } } }

Note the massive shift on line "!!!!".  It can't happen, because we've checked
that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!
Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
can't constant fold it, but if it gets to the assember we get
     Error: operand type mismatch for `shl'

So the best thing to do is to rewrite the shift with a call to error,
when the second arg is large. However, in general we cannot do this; consider
this case

    let x = I# (uncheckedIShiftL# n 80)
    in ...

Here x contains an invalid shift and consequently we would like to rewrite it
as follows:

    let x = I# (error "invalid shift)
    in ...

This was originally done in the fix to #16449 but this breaks the let/app
invariant (see Note [CoreSyn let/app invariant] in CoreSyn) as noted in #16742.
For the reasons discussed in Note [Checking versus non-checking primops] (in
the PrimOp module) there is no safe way rewrite the argument of I# such that
it bottoms.

Consequently we instead take advantage of the fact that large shifts are
undefined behavior (see associated documentation in primops.txt.pp) and
transform the invalid shift into an "obviously incorrect" value.

There are two cases:

- Shifting fixed-width things: the primops ISll, Sll, etc
  These are handled by shiftRule.

  We are happy to shift by any amount up to wordSize but no more.

- Shifting Integers: the function shiftLInteger, shiftRInteger
  from the 'integer' library.   These are handled by rule_shift_op,
  and match_Integer_shift_op.

  Here we could in principle shift by any amount, but we arbitary
  limit the shift to 4 bits; in particualr we do not want shift by a
  huge amount, which can happen in code like that above.

The two cases are more different in their code paths that is comfortable,
but that is only a historical accident.


************************************************************************
*                                                                      *
\subsection{Vaguely generic functions}
*                                                                      *
************************************************************************
-}

mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
-- Gives the Rule the same name as the primop itself
mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
op_name Int
n_args RuleM CoreExpr
rm
  = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = OccName -> RuleName
occNameFS (Name -> OccName
nameOccName Name
op_name),
                  ru_fn :: Name
ru_fn = Name
op_name,
                  ru_nargs :: Int
ru_nargs = Int
n_args,
                  ru_try :: RuleFun
ru_try = \ DynFlags
dflags InScopeEnv
in_scope CoreBndr
_ -> RuleM CoreExpr
-> DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe CoreExpr
forall r.
RuleM r -> DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r
runRuleM RuleM CoreExpr
rm DynFlags
dflags InScopeEnv
in_scope }

newtype RuleM r = RuleM
  { RuleM r -> DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r
runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
  deriving (a -> RuleM b -> RuleM a
(a -> b) -> RuleM a -> RuleM b
(forall a b. (a -> b) -> RuleM a -> RuleM b)
-> (forall a b. a -> RuleM b -> RuleM a) -> Functor RuleM
forall a b. a -> RuleM b -> RuleM a
forall a b. (a -> b) -> RuleM a -> RuleM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RuleM b -> RuleM a
$c<$ :: forall a b. a -> RuleM b -> RuleM a
fmap :: (a -> b) -> RuleM a -> RuleM b
$cfmap :: forall a b. (a -> b) -> RuleM a -> RuleM b
Functor)

instance Applicative RuleM where
    pure :: a -> RuleM a
pure a
x = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a)
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a
forall a b. (a -> b) -> a -> b
$ \DynFlags
_ InScopeEnv
_ [CoreExpr]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    <*> :: RuleM (a -> b) -> RuleM a -> RuleM b
(<*>) = RuleM (a -> b) -> RuleM a -> RuleM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad RuleM where
  RuleM DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f >>= :: RuleM a -> (a -> RuleM b) -> RuleM b
>>= a -> RuleM b
g = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe b) -> RuleM b
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe b) -> RuleM b)
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe b) -> RuleM b
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags InScopeEnv
iu [CoreExpr]
e -> case DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f DynFlags
dflags InScopeEnv
iu [CoreExpr]
e of
    Maybe a
Nothing -> Maybe b
forall a. Maybe a
Nothing
    Just a
r -> RuleM b -> DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe b
forall r.
RuleM r -> DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r
runRuleM (a -> RuleM b
g a
r) DynFlags
dflags InScopeEnv
iu [CoreExpr]
e
#if !MIN_VERSION_base(4,13,0)
  fail = MonadFail.fail
#endif

instance MonadFail.MonadFail RuleM where
    fail :: String -> RuleM a
fail String
_ = RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance Alternative RuleM where
  empty :: RuleM a
empty = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a)
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a
forall a b. (a -> b) -> a -> b
$ \DynFlags
_ InScopeEnv
_ [CoreExpr]
_ -> Maybe a
forall a. Maybe a
Nothing
  RuleM DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f1 <|> :: RuleM a -> RuleM a -> RuleM a
<|> RuleM DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f2 = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a)
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a) -> RuleM a
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags InScopeEnv
iu [CoreExpr]
args ->
    DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f1 DynFlags
dflags InScopeEnv
iu [CoreExpr]
args Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f2 DynFlags
dflags InScopeEnv
iu [CoreExpr]
args

instance MonadPlus RuleM

instance HasDynFlags RuleM where
    getDynFlags :: RuleM DynFlags
getDynFlags = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe DynFlags)
-> RuleM DynFlags
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe DynFlags)
 -> RuleM DynFlags)
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe DynFlags)
-> RuleM DynFlags
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags InScopeEnv
_ [CoreExpr]
_ -> DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just DynFlags
dflags

liftMaybe :: Maybe a -> RuleM a
liftMaybe :: Maybe a -> RuleM a
liftMaybe Maybe a
Nothing = RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
liftMaybe (Just a
x) = a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

liftLit :: (Literal -> Literal) -> RuleM CoreExpr
liftLit :: (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
f = (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags ((Literal -> Literal) -> DynFlags -> Literal -> Literal
forall a b. a -> b -> a
const Literal -> Literal
f)

liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags DynFlags -> Literal -> Literal
f = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit Literal
lit] <- RuleM [CoreExpr]
getArgs
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Literal -> Literal
f DynFlags
dflags Literal
lit)

removeOp32 :: RuleM CoreExpr
removeOp32 :: RuleM CoreExpr
removeOp32 = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  case Platform -> PlatformWordSize
platformWordSize (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
    PlatformWordSize
PW4 -> do
      [CoreExpr
e] <- RuleM [CoreExpr]
getArgs
      CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
    PlatformWordSize
PW8 ->
      RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero

getArgs :: RuleM [CoreExpr]
getArgs :: RuleM [CoreExpr]
getArgs = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe [CoreExpr])
-> RuleM [CoreExpr]
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe [CoreExpr])
 -> RuleM [CoreExpr])
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe [CoreExpr])
-> RuleM [CoreExpr]
forall a b. (a -> b) -> a -> b
$ \DynFlags
_ InScopeEnv
_ [CoreExpr]
args -> [CoreExpr] -> Maybe [CoreExpr]
forall a. a -> Maybe a
Just [CoreExpr]
args

getInScopeEnv :: RuleM InScopeEnv
getInScopeEnv :: RuleM InScopeEnv
getInScopeEnv = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe InScopeEnv)
-> RuleM InScopeEnv
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe InScopeEnv)
 -> RuleM InScopeEnv)
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe InScopeEnv)
-> RuleM InScopeEnv
forall a b. (a -> b) -> a -> b
$ \DynFlags
_ InScopeEnv
iu [CoreExpr]
_ -> InScopeEnv -> Maybe InScopeEnv
forall a. a -> Maybe a
Just InScopeEnv
iu

-- return the n-th argument of this rule, if it is a literal
-- argument indices start from 0
getLiteral :: Int -> RuleM Literal
getLiteral :: Int -> RuleM Literal
getLiteral Int
n = (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe Literal)
-> RuleM Literal
forall r.
(DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe Literal)
 -> RuleM Literal)
-> (DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe Literal)
-> RuleM Literal
forall a b. (a -> b) -> a -> b
$ \DynFlags
_ InScopeEnv
_ [CoreExpr]
exprs -> case Int -> [CoreExpr] -> [CoreExpr]
forall a. Int -> [a] -> [a]
drop Int
n [CoreExpr]
exprs of
  (Lit Literal
l:[CoreExpr]
_) -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
  [CoreExpr]
_ -> Maybe Literal
forall a. Maybe a
Nothing

unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
op = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit Literal
l] <- RuleM [CoreExpr]
getArgs
  Maybe CoreExpr -> RuleM CoreExpr
forall a. Maybe a -> RuleM a
liftMaybe (Maybe CoreExpr -> RuleM CoreExpr)
-> Maybe CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Literal -> Maybe CoreExpr
op DynFlags
dflags (DynFlags -> Literal -> Literal
convFloating DynFlags
dflags Literal
l)

binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit DynFlags -> Literal -> Literal -> Maybe CoreExpr
op = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit Literal
l1, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Maybe CoreExpr -> RuleM CoreExpr
forall a. Maybe a -> RuleM a
liftMaybe (Maybe CoreExpr -> RuleM CoreExpr)
-> Maybe CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Literal -> Literal -> Maybe CoreExpr
op DynFlags
dflags (DynFlags -> Literal -> Literal
convFloating DynFlags
dflags Literal
l1) (DynFlags -> Literal -> Literal
convFloating DynFlags
dflags Literal
l2)

binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit :: (forall a. Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit forall a. Ord a => a -> a -> Bool
op = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit (\DynFlags
_ -> DynFlags
-> (forall a. Ord a => a -> a -> Bool)
-> Literal
-> Literal
-> Maybe CoreExpr
cmpOp DynFlags
dflags forall a. Ord a => a -> a -> Bool
op)

leftIdentity :: Literal -> RuleM CoreExpr
leftIdentity :: Literal -> RuleM CoreExpr
leftIdentity Literal
id_lit = (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityDynFlags (Literal -> DynFlags -> Literal
forall a b. a -> b -> a
const Literal
id_lit)

rightIdentity :: Literal -> RuleM CoreExpr
rightIdentity :: Literal -> RuleM CoreExpr
rightIdentity Literal
id_lit = (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags (Literal -> DynFlags -> Literal
forall a b. a -> b -> a
const Literal
id_lit)

identity :: Literal -> RuleM CoreExpr
identity :: Literal -> RuleM CoreExpr
identity Literal
lit = Literal -> RuleM CoreExpr
leftIdentity Literal
lit RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Literal -> RuleM CoreExpr
rightIdentity Literal
lit

leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityDynFlags DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit Literal
l1, CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
id_lit DynFlags
dflags
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e2

-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
-- addition to the result, we have to indicate that no carry/overflow occured.
leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityCDynFlags DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit Literal
l1, CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
id_lit DynFlags
dflags
  let no_c :: Expr b
no_c = Literal -> Expr b
forall b. Literal -> Expr b
Lit (DynFlags -> Literal
zeroi DynFlags
dflags)
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [CoreExpr -> Type
exprType CoreExpr
e2, Type
intPrimTy] [CoreExpr
e2, CoreExpr
forall b. Expr b
no_c])

rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [CoreExpr
e1, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l2 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
id_lit DynFlags
dflags
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e1

-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
-- addition to the result, we have to indicate that no carry/overflow occured.
rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityCDynFlags DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [CoreExpr
e1, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l2 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
id_lit DynFlags
dflags
  let no_c :: Expr b
no_c = Literal -> Expr b
forall b. Literal -> Expr b
Lit (DynFlags -> Literal
zeroi DynFlags
dflags)
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [CoreExpr -> Type
exprType CoreExpr
e1, Type
intPrimTy] [CoreExpr
e1, CoreExpr
forall b. Expr b
no_c])

identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags DynFlags -> Literal
lit =
  (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityDynFlags DynFlags -> Literal
lit RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
lit

-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
-- to the result, we have to indicate that no carry/overflow occured.
identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityCDynFlags DynFlags -> Literal
lit =
  (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityCDynFlags DynFlags -> Literal
lit RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityCDynFlags DynFlags -> Literal
lit

leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
leftZero DynFlags -> Literal
zero = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit Literal
l1, CoreExpr
_] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
zero DynFlags
dflags
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
l1

rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
rightZero DynFlags -> Literal
zero = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [CoreExpr
_, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l2 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Literal
zero DynFlags
dflags
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
l2

zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
zeroElem DynFlags -> Literal
lit = (DynFlags -> Literal) -> RuleM CoreExpr
leftZero DynFlags -> Literal
lit RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (DynFlags -> Literal) -> RuleM CoreExpr
rightZero DynFlags -> Literal
lit

equalArgs :: RuleM ()
equalArgs :: RuleM ()
equalArgs = do
  [CoreExpr
e1, CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ CoreExpr
e1 CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
e2

nonZeroLit :: Int -> RuleM ()
nonZeroLit :: Int -> RuleM ()
nonZeroLit Int
n = Int -> RuleM Literal
getLiteral Int
n RuleM Literal -> (Literal -> RuleM ()) -> RuleM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> (Literal -> Bool) -> Literal -> RuleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Literal -> Bool) -> Literal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Bool
isZeroLit

-- When excess precision is not requested, cut down the precision of the
-- Rational value to that of Float/Double. We confuse host architecture
-- and target architecture here, but it's convenient (and wrong :-).
convFloating :: DynFlags -> Literal -> Literal
convFloating :: DynFlags -> Literal -> Literal
convFloating DynFlags
dflags (LitFloat  Rational
f) | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExcessPrecision DynFlags
dflags) =
   Rational -> Literal
LitFloat  (Float -> Rational
forall a. Real a => a -> Rational
toRational (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
f :: Float ))
convFloating DynFlags
dflags (LitDouble Rational
d) | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExcessPrecision DynFlags
dflags) =
   Rational -> Literal
LitDouble (Double -> Rational
forall a. Real a => a -> Rational
toRational (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
d :: Double))
convFloating DynFlags
_ Literal
l = Literal
l

guardFloatDiv :: RuleM ()
guardFloatDiv :: RuleM ()
guardFloatDiv = do
  [Lit (LitFloat Rational
f1), Lit (LitFloat Rational
f2)] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ (Rational
f1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/=Rational
0 Bool -> Bool -> Bool
|| Rational
f2 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0) -- see Note [negative zero]
       Bool -> Bool -> Bool
&& Rational
f2 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0            -- avoid NaN and Infinity/-Infinity

guardDoubleDiv :: RuleM ()
guardDoubleDiv :: RuleM ()
guardDoubleDiv = do
  [Lit (LitDouble Rational
d1), Lit (LitDouble Rational
d2)] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ (Rational
d1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/=Rational
0 Bool -> Bool -> Bool
|| Rational
d2 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0) -- see Note [negative zero]
       Bool -> Bool -> Bool
&& Rational
d2 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0            -- avoid NaN and Infinity/-Infinity
-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
-- zero, but we might want to preserve the negative zero here which
-- is representable in Float/Double but not in (normalised)
-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?

strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
strengthReduction Literal
two_lit PrimOp
add_op = do -- Note [Strength reduction]
  CoreExpr
arg <- [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ do [CoreExpr
arg, Lit Literal
mult_lit] <- RuleM [CoreExpr]
getArgs
                   Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal
mult_lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
two_lit)
                   CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
arg
              , do [Lit Literal
mult_lit, CoreExpr
arg] <- RuleM [CoreExpr]
getArgs
                   Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal
mult_lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
two_lit)
                   CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
arg ]
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (PrimOp -> CoreBndr
mkPrimOpId PrimOp
add_op) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
arg CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
arg

-- Note [Strength reduction]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- This rule turns floating point multiplications of the form 2.0 * x and
-- x * 2.0 into x + x addition, because addition costs less than multiplication.
-- See #7116

-- Note [What's true and false]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- trueValInt and falseValInt represent true and false values returned by
-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
-- True is represented as an unboxed 1# literal, while false is represented
-- as 0# literal.
-- We still need Bool data constructors (True and False) to use in a rule
-- for constant folding of equal Strings

trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
trueValInt :: DynFlags -> CoreExpr
trueValInt  DynFlags
dflags = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Literal
onei  DynFlags
dflags -- see Note [What's true and false]
falseValInt :: DynFlags -> CoreExpr
falseValInt DynFlags
dflags = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> Literal
zeroi DynFlags
dflags

trueValBool, falseValBool :: Expr CoreBndr
trueValBool :: CoreExpr
trueValBool   = CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
trueDataConId -- see Note [What's true and false]
falseValBool :: CoreExpr
falseValBool  = CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
falseDataConId

ltVal, eqVal, gtVal :: Expr CoreBndr
ltVal :: CoreExpr
ltVal = CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
ordLTDataConId
eqVal :: CoreExpr
eqVal = CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
ordEQDataConId
gtVal :: CoreExpr
gtVal = CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
ordGTDataConId

mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
mkIntVal :: DynFlags -> Integer -> CoreExpr
mkIntVal DynFlags
dflags Integer
i = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitInt DynFlags
dflags Integer
i)
mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
mkFloatVal :: DynFlags -> Rational -> CoreExpr
mkFloatVal DynFlags
dflags Rational
f = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Literal -> Literal
convFloating DynFlags
dflags (Rational -> Literal
LitFloat  Rational
f))
mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
mkDoubleVal :: DynFlags -> Rational -> CoreExpr
mkDoubleVal DynFlags
dflags Rational
d = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Literal -> Literal
convFloating DynFlags
dflags (Rational -> Literal
LitDouble Rational
d))

matchPrimOpId :: PrimOp -> Id -> RuleM ()
matchPrimOpId :: PrimOp -> CoreBndr -> RuleM ()
matchPrimOpId PrimOp
op CoreBndr
id = do
  PrimOp
op' <- Maybe PrimOp -> RuleM PrimOp
forall a. Maybe a -> RuleM a
liftMaybe (Maybe PrimOp -> RuleM PrimOp) -> Maybe PrimOp -> RuleM PrimOp
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
id
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== PrimOp
op'

{-
************************************************************************
*                                                                      *
\subsection{Special rules for seq, tagToEnum, dataToTag}
*                                                                      *
************************************************************************

Note [tagToEnum#]
~~~~~~~~~~~~~~~~~
Nasty check to ensure that tagToEnum# is applied to a type that is an
enumeration TyCon.  Unification may refine the type later, but this
check won't see that, alas.  It's crude but it works.

Here's are two cases that should fail
        f :: forall a. a
        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable

        g :: Int
        g = tagToEnum# 0        -- Int is not an enumeration

We used to make this check in the type inference engine, but it's quite
ugly to do so, because the delayed constraint solving means that we don't
really know what's going on until the end. It's very much a corner case
because we don't expect the user to call tagToEnum# at all; we merely
generate calls in derived instances of Enum.  So we compromise: a
rewrite rule rewrites a bad instance of tagToEnum# to an error call,
and emits a warning.
-}

tagToEnumRule :: RuleM CoreExpr
-- If     data T a = A | B | C
-- then   tag2Enum# (T ty) 2# -->  B ty
tagToEnumRule :: RuleM CoreExpr
tagToEnumRule = do
  [Type Type
ty, Lit (LitNumber LitNumType
LitNumInt Integer
i Type
_)] <- RuleM [CoreExpr]
getArgs
  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
    Just (TyCon
tycon, [Type]
tc_args) | TyCon -> Bool
isEnumerationTyCon TyCon
tycon -> do
      let tag :: Int
tag = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i
          correct_tag :: DataCon -> Bool
correct_tag DataCon
dc = (DataCon -> Int
dataConTagZ DataCon
dc) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tag
      (DataCon
dc:[DataCon]
rest) <- [DataCon] -> RuleM [DataCon]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> RuleM [DataCon]) -> [DataCon] -> RuleM [DataCon]
forall a b. (a -> b) -> a -> b
$ (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filter DataCon -> Bool
correct_tag (TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tycon Maybe [DataCon] -> [DataCon] -> [DataCon]
forall a. Maybe a -> a -> a
`orElse` [])
      ASSERT(null rest) return ()
      CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (DataCon -> CoreBndr
dataConWorkId DataCon
dc)) [Type]
tc_args

    -- See Note [tagToEnum#]
    Maybe (TyCon, [Type])
_ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
         CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Type -> String -> CoreExpr
mkRuntimeErrorApp CoreBndr
rUNTIME_ERROR_ID Type
ty String
"tagToEnum# on non-enumeration type"

------------------------------
dataToTagRule :: RuleM CoreExpr
-- See Note [dataToTag#] in primops.txt.pp
dataToTagRule :: RuleM CoreExpr
dataToTagRule = RuleM CoreExpr
a RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` RuleM CoreExpr
b
  where
    -- dataToTag (tagToEnum x)   ==>   x
    a :: RuleM CoreExpr
a = do
      [Type Type
ty1, Var CoreBndr
tag_to_enum `App` Type Type
ty2 `App` CoreExpr
tag] <- RuleM [CoreExpr]
getArgs
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ CoreBndr
tag_to_enum CoreBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2
      CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
tag

    -- dataToTag (K e1 e2)  ==>   tag-of K
    -- This also works (via exprIsConApp_maybe) for
    --   dataToTag x
    -- where x's unfolding is a constructor application
    b :: RuleM CoreExpr
b = do
      DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      [CoreExpr
_, CoreExpr
val_arg] <- RuleM [CoreExpr]
getArgs
      InScopeEnv
in_scope <- RuleM InScopeEnv
getInScopeEnv
      (InScopeSet
_,[FloatBind]
floats, DataCon
dc,[Type]
_,[CoreExpr]
_) <- Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-> RuleM (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a. Maybe a -> RuleM a
liftMaybe (Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
 -> RuleM (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-> RuleM (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$ InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe InScopeEnv
in_scope CoreExpr
val_arg
      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
      CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats (DynFlags -> Integer -> CoreExpr
mkIntVal DynFlags
dflags (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (DataCon -> Int
dataConTagZ DataCon
dc)))

{- Note [dataToTag# magic]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The primop dataToTag# is unusual because it evaluates its argument.
Only `SeqOp` shares that property.  (Other primops do not do anything
as fancy as argument evaluation.)  The special handling for dataToTag#
is:

* CoreUtils.exprOkForSpeculation has a special case for DataToTagOp,
  (actually in app_ok).  Most primops with lifted arguments do not
  evaluate those arguments, but DataToTagOp and SeqOp are two
  exceptions.  We say that they are /never/ ok-for-speculation,
  regardless of the evaluated-ness of their argument.
  See CoreUtils Note [exprOkForSpeculation and SeqOp/DataToTagOp]

* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,
  that evaluates its argument and then extracts the tag from
  the returned value.

* An application like (dataToTag# (Just x)) is optimised by
  dataToTagRule in PrelRules.

* A case expression like
     case (dataToTag# e) of <alts>
  gets transformed t
     case e of <transformed alts>
  by PrelRules.caseRules; see Note [caseRules for dataToTag]

See #15696 for a long saga.


************************************************************************
*                                                                      *
\subsection{Rules for seq# and spark#}
*                                                                      *
************************************************************************
-}

{- Note [seq# magic]
~~~~~~~~~~~~~~~~~~~~
The primop
   seq# :: forall a s . a -> State# s -> (# State# s, a #)

is /not/ the same as the Prelude function seq :: a -> b -> b
as you can see from its type.  In fact, seq# is the implementation
mechanism for 'evaluate'

   evaluate :: a -> IO a
   evaluate a = IO $ \s -> seq# a s

The semantics of seq# is
  * evaluate its first argument
  * and return it

Things to note

* Why do we need a primop at all?  That is, instead of
      case seq# x s of (# x, s #) -> blah
  why not instead say this?
      case x of { DEFAULT -> blah)

  Reason (see #5129): if we saw
    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler

  then we'd drop the 'case x' because the body of the case is bottom
  anyway. But we don't want to do that; the whole /point/ of
  seq#/evaluate is to evaluate 'x' first in the IO monad.

  In short, we /always/ evaluate the first argument and never
  just discard it.

* Why return the value?  So that we can control sharing of seq'd
  values: in
     let x = e in x `seq` ... x ...
  We don't want to inline x, so better to represent it as
       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
  also it matches the type of rseq in the Eval monad.

Implementing seq#.  The compiler has magic for SeqOp in

- PrelRules.seqRule: eliminate (seq# <whnf> s)

- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#

- CoreUtils.exprOkForSpeculation;
  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in CoreUtils

- Simplify.addEvals records evaluated-ness for the result; see
  Note [Adding evaluatedness info to pattern-bound variables]
  in Simplify
-}

seqRule :: RuleM CoreExpr
seqRule :: RuleM CoreExpr
seqRule = do
  [Type Type
ty_a, Type Type
_ty_s, CoreExpr
a, CoreExpr
s] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Bool
exprIsHNF CoreExpr
a
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [CoreExpr -> Type
exprType CoreExpr
s, Type
ty_a] [CoreExpr
s, CoreExpr
a]

-- spark# :: forall a s . a -> State# s -> (# State# s, a #)
sparkRule :: RuleM CoreExpr
sparkRule :: RuleM CoreExpr
sparkRule = RuleM CoreExpr
seqRule -- reduce on HNF, just the same
  -- XXX perhaps we shouldn't do this, because a spark eliminated by
  -- this rule won't be counted as a dud at runtime?

{-
************************************************************************
*                                                                      *
\subsection{Built in rules}
*                                                                      *
************************************************************************

Note [Scoping for Builtin rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When compiling a (base-package) module that defines one of the
functions mentioned in the RHS of a built-in rule, there's a danger
that we'll see

        f = ...(eq String x)....

        ....and lower down...

        eqString = ...

Then a rewrite would give

        f = ...(eqString x)...
        ....and lower down...
        eqString = ...

and lo, eqString is not in scope.  This only really matters when we get to code
generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole
set of bindings, which sorts out the dependency.  Without -O we don't do any rule
rewriting so again we are fine.

(This whole thing doesn't show up for non-built-in rules because their dependencies
are explicit.)
-}

builtinRules :: [CoreRule]
-- Rules for non-primops that can't be expressed using a RULE pragma
builtinRules :: [CoreRule]
builtinRules
  = [BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"AppendLitString",
                   ru_fn :: Name
ru_fn = Name
unpackCStringFoldrName,
                   ru_nargs :: Int
ru_nargs = Int
4, ru_try :: RuleFun
ru_try = RuleFun
match_append_lit },
     BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"EqString", ru_fn :: Name
ru_fn = Name
eqStringName,
                   ru_nargs :: Int
ru_nargs = Int
2, ru_try :: RuleFun
ru_try = RuleFun
match_eq_string },
     BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"Inline", ru_fn :: Name
ru_fn = Name
inlineIdName,
                   ru_nargs :: Int
ru_nargs = Int
2, ru_try :: RuleFun
ru_try = \DynFlags
_ InScopeEnv
_ CoreBndr
_ -> [CoreExpr] -> Maybe CoreExpr
match_inline },
     BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"MagicDict", ru_fn :: Name
ru_fn = CoreBndr -> Name
idName CoreBndr
magicDictId,
                   ru_nargs :: Int
ru_nargs = Int
4, ru_try :: RuleFun
ru_try = \DynFlags
_ InScopeEnv
_ CoreBndr
_ -> [CoreExpr] -> Maybe CoreExpr
match_magicDict },
     Name -> Int -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
divIntName Int
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        [ Int -> RuleM ()
nonZeroLit Int
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div)
        , (DynFlags -> Literal) -> RuleM CoreExpr
leftZero DynFlags -> Literal
zeroi
        , do
          [CoreExpr
arg, Lit (LitNumber LitNumType
LitNumInt Integer
d Type
_)] <- RuleM [CoreExpr]
getArgs
          Just Integer
n <- Maybe Integer -> RuleM (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> RuleM (Maybe Integer))
-> Maybe Integer -> RuleM (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
exactLog2 Integer
d
          DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
          CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (PrimOp -> CoreBndr
mkPrimOpId PrimOp
ISraOp) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
arg CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` DynFlags -> Integer -> CoreExpr
mkIntVal DynFlags
dflags Integer
n
        ],
     Name -> Int -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
modIntName Int
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        [ Int -> RuleM ()
nonZeroLit Int
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DynFlags -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod)
        , (DynFlags -> Literal) -> RuleM CoreExpr
leftZero DynFlags -> Literal
zeroi
        , do
          [CoreExpr
arg, Lit (LitNumber LitNumType
LitNumInt Integer
d Type
_)] <- RuleM [CoreExpr]
getArgs
          Just Integer
_ <- Maybe Integer -> RuleM (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> RuleM (Maybe Integer))
-> Maybe Integer -> RuleM (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
exactLog2 Integer
d
          DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
          CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (PrimOp -> CoreBndr
mkPrimOpId PrimOp
AndIOp)
            CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
arg CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` DynFlags -> Integer -> CoreExpr
mkIntVal DynFlags
dflags (Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
        ]
     ]
 [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
builtinIntegerRules
 [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
builtinNaturalRules
{-# NOINLINE builtinRules #-}
-- there is no benefit to inlining these yet, despite this, GHC produces
-- unfoldings for this regardless since the floated list entries look small.

builtinIntegerRules :: [CoreRule]
builtinIntegerRules :: [CoreRule]
builtinIntegerRules =
 [String -> Name -> CoreRule
rule_IntToInteger   String
"smallInteger"        Name
smallIntegerName,
  String -> Name -> CoreRule
rule_WordToInteger  String
"wordToInteger"       Name
wordToIntegerName,
  String -> Name -> CoreRule
rule_Int64ToInteger  String
"int64ToInteger"     Name
int64ToIntegerName,
  String -> Name -> CoreRule
rule_Word64ToInteger String
"word64ToInteger"    Name
word64ToIntegerName,
  String -> Name -> (DynFlags -> Word -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        String
"integerToWord"       Name
integerToWordName       DynFlags -> Word -> CoreExpr
forall b. DynFlags -> Word -> Expr b
mkWordLitWord,
  String -> Name -> (DynFlags -> Int -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        String
"integerToInt"        Name
integerToIntName        DynFlags -> Int -> CoreExpr
forall b. DynFlags -> Int -> Expr b
mkIntLitInt,
  String -> Name -> (DynFlags -> Word64 -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        String
"integerToWord64"     Name
integerToWord64Name     (\DynFlags
_ -> Word64 -> CoreExpr
forall b. Word64 -> Expr b
mkWord64LitWord64),
  String -> Name -> (DynFlags -> Int64 -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        String
"integerToInt64"      Name
integerToInt64Name      (\DynFlags
_ -> Int64 -> CoreExpr
forall b. Int64 -> Expr b
mkInt64LitInt64),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"plusInteger"         Name
plusIntegerName         Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"minusInteger"        Name
minusIntegerName        (-),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"timesInteger"        Name
timesIntegerName        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*),
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           String
"negateInteger"       Name
negateIntegerName       Integer -> Integer
forall a. Num a => a -> a
negate,
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     String
"eqInteger#"          Name
eqIntegerPrimName       Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     String
"neqInteger#"         Name
neqIntegerPrimName      Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(/=),
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           String
"absInteger"          Name
absIntegerName          Integer -> Integer
forall a. Num a => a -> a
abs,
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           String
"signumInteger"       Name
signumIntegerName       Integer -> Integer
forall a. Num a => a -> a
signum,
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     String
"leInteger#"          Name
leIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     String
"gtInteger#"          Name
gtIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     String
"ltInteger#"          Name
ltIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     String
"geInteger#"          Name
geIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=),
  String -> Name -> (Integer -> Integer -> Ordering) -> CoreRule
rule_binop_Ordering String
"compareInteger"      Name
compareIntegerName      Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare,
  String -> Name -> (Float -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rule_encodeFloat    String
"encodeFloatInteger"  Name
encodeFloatIntegerName  Float -> CoreExpr
forall b. Float -> Expr b
mkFloatLitFloat,
  String -> Name -> (DynFlags -> Float -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        String
"floatFromInteger"    Name
floatFromIntegerName    (\DynFlags
_ -> Float -> CoreExpr
forall b. Float -> Expr b
mkFloatLitFloat),
  String -> Name -> (Double -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rule_encodeFloat    String
"encodeDoubleInteger" Name
encodeDoubleIntegerName Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble,
  String -> Name -> CoreRule
rule_decodeDouble   String
"decodeDoubleInteger" Name
decodeDoubleIntegerName,
  String -> Name -> (DynFlags -> Double -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        String
"doubleFromInteger"   Name
doubleFromIntegerName   (\DynFlags
_ -> Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble),
  String -> Name -> (Float -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rule_rationalTo     String
"rationalToFloat"     Name
rationalToFloatName     Float -> CoreExpr
mkFloatExpr,
  String -> Name -> (Double -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rule_rationalTo     String
"rationalToDouble"    Name
rationalToDoubleName    Double -> CoreExpr
mkDoubleExpr,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"gcdInteger"          Name
gcdIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"lcmInteger"          Name
lcmIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
lcm,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"andInteger"          Name
andIntegerName          Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"orInteger"           Name
orIntegerName           Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          String
"xorInteger"          Name
xorIntegerName          Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor,
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           String
"complementInteger"   Name
complementIntegerName   Integer -> Integer
forall a. Bits a => a -> a
complement,
  String -> Name -> (Integer -> Int -> Integer) -> CoreRule
rule_shift_op       String
"shiftLInteger"       Name
shiftLIntegerName       Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL,
  String -> Name -> (Integer -> Int -> Integer) -> CoreRule
rule_shift_op       String
"shiftRInteger"       Name
shiftRIntegerName       Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftR,
  String -> Name -> CoreRule
rule_bitInteger     String
"bitInteger"          Name
bitIntegerName,
  -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      String
"quotInteger"         Name
quotIntegerName         Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      String
"remInteger"          Name
remIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      String
"divInteger"          Name
divIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      String
"modInteger"          Name
modIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod,
  String
-> Name -> (Integer -> Integer -> (Integer, Integer)) -> CoreRule
rule_divop_both     String
"divModInteger"       Name
divModIntegerName       Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
divMod,
  String
-> Name -> (Integer -> Integer -> (Integer, Integer)) -> CoreRule
rule_divop_both     String
"quotRemInteger"      Name
quotRemIntegerName      Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
quotRem,
  -- These rules below don't actually have to be built in, but if we
  -- put them in the Haskell source then we'd have to duplicate them
  -- between all Integer implementations
  String -> Name -> Name -> CoreRule
rule_XToIntegerToX String
"smallIntegerToInt"       Name
integerToIntName    Name
smallIntegerName,
  String -> Name -> Name -> CoreRule
rule_XToIntegerToX String
"wordToIntegerToWord"     Name
integerToWordName   Name
wordToIntegerName,
  String -> Name -> Name -> CoreRule
rule_XToIntegerToX String
"int64ToIntegerToInt64"   Name
integerToInt64Name  Name
int64ToIntegerName,
  String -> Name -> Name -> CoreRule
rule_XToIntegerToX String
"word64ToIntegerToWord64" Name
integerToWord64Name Name
word64ToIntegerName,
  String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo String
"smallIntegerToWord"   Name
integerToWordName     PrimOp
Int2WordOp,
  String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo String
"smallIntegerToFloat"  Name
floatFromIntegerName  PrimOp
Int2FloatOp,
  String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo String
"smallIntegerToDouble" Name
doubleFromIntegerName PrimOp
Int2DoubleOp
  ]
    where rule_convert :: String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert String
str Name
name DynFlags -> a -> CoreExpr
convert
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = (DynFlags -> a -> CoreExpr) -> RuleFun
forall a. Num a => (DynFlags -> a -> CoreExpr) -> RuleFun
match_Integer_convert DynFlags -> a -> CoreExpr
convert }
          rule_IntToInteger :: String -> Name -> CoreRule
rule_IntToInteger String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_IntToInteger }
          rule_WordToInteger :: String -> Name -> CoreRule
rule_WordToInteger String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_WordToInteger }
          rule_Int64ToInteger :: String -> Name -> CoreRule
rule_Int64ToInteger String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_Int64ToInteger }
          rule_Word64ToInteger :: String -> Name -> CoreRule
rule_Word64ToInteger String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_Word64ToInteger }
          rule_unop :: String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop String
str Name
name Integer -> Integer
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer) -> RuleFun
match_Integer_unop Integer -> Integer
op }
          rule_bitInteger :: String -> Name -> CoreRule
rule_bitInteger String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_bitInteger }
          rule_binop :: String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop String
str Name
name Integer -> Integer -> Integer
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop Integer -> Integer -> Integer
op }
          rule_divop_both :: String
-> Name -> (Integer -> Integer -> (Integer, Integer)) -> CoreRule
rule_divop_both String
str Name
name Integer -> Integer -> (Integer, Integer)
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer -> (Integer, Integer)) -> RuleFun
match_Integer_divop_both Integer -> Integer -> (Integer, Integer)
op }
          rule_divop_one :: String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one String
str Name
name Integer -> Integer -> Integer
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer -> Integer) -> RuleFun
match_Integer_divop_one Integer -> Integer -> Integer
op }
          rule_shift_op :: String -> Name -> (Integer -> Int -> Integer) -> CoreRule
rule_shift_op String
str Name
name Integer -> Int -> Integer
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Int -> Integer) -> RuleFun
match_Integer_shift_op Integer -> Int -> Integer
op }
          rule_binop_Prim :: String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim String
str Name
name Integer -> Integer -> Bool
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Prim Integer -> Integer -> Bool
op }
          rule_binop_Ordering :: String -> Name -> (Integer -> Integer -> Ordering) -> CoreRule
rule_binop_Ordering String
str Name
name Integer -> Integer -> Ordering
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer -> Ordering) -> RuleFun
match_Integer_binop_Ordering Integer -> Integer -> Ordering
op }
          rule_encodeFloat :: String -> Name -> (a -> CoreExpr) -> CoreRule
rule_encodeFloat String
str Name
name a -> CoreExpr
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (a -> CoreExpr) -> RuleFun
forall a. RealFloat a => (a -> CoreExpr) -> RuleFun
match_Integer_Int_encodeFloat a -> CoreExpr
op }
          rule_decodeDouble :: String -> Name -> CoreRule
rule_decodeDouble String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_decodeDouble }
          rule_XToIntegerToX :: String -> Name -> Name -> CoreRule
rule_XToIntegerToX String
str Name
name Name
toIntegerName
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = Name -> RuleFun
match_XToIntegerToX Name
toIntegerName }
          rule_smallIntegerTo :: String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo String
str Name
name PrimOp
primOp
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = PrimOp -> RuleFun
match_smallIntegerTo PrimOp
primOp }
          rule_rationalTo :: String -> Name -> (a -> CoreExpr) -> CoreRule
rule_rationalTo String
str Name
name a -> CoreExpr
mkLit
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (a -> CoreExpr) -> RuleFun
forall a. RealFloat a => (a -> CoreExpr) -> RuleFun
match_rationalTo a -> CoreExpr
mkLit }

builtinNaturalRules :: [CoreRule]
builtinNaturalRules :: [CoreRule]
builtinNaturalRules =
 [String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop              String
"plusNatural"        Name
plusNaturalName         Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)
 ,String -> Name -> (Integer -> Integer -> Maybe Integer) -> CoreRule
rule_partial_binop      String
"minusNatural"       Name
minusNaturalName        (\Integer
a Integer
b -> if Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
b then Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
b) else Maybe Integer
forall a. Maybe a
Nothing)
 ,String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop              String
"timesNatural"       Name
timesNaturalName        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*)
 ,String -> Name -> CoreRule
rule_NaturalFromInteger String
"naturalFromInteger" Name
naturalFromIntegerName
 ,String -> Name -> CoreRule
rule_NaturalToInteger   String
"naturalToInteger"   Name
naturalToIntegerName
 ,String -> Name -> CoreRule
rule_WordToNatural      String
"wordToNatural"      Name
wordToNaturalName
 ]
    where rule_binop :: String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop String
str Name
name Integer -> Integer -> Integer
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer -> Integer) -> RuleFun
match_Natural_binop Integer -> Integer -> Integer
op }
          rule_partial_binop :: String -> Name -> (Integer -> Integer -> Maybe Integer) -> CoreRule
rule_partial_binop String
str Name
name Integer -> Integer -> Maybe Integer
op
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
2,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer -> Maybe Integer) -> RuleFun
match_Natural_partial_binop Integer -> Integer -> Maybe Integer
op }
          rule_NaturalToInteger :: String -> Name -> CoreRule
rule_NaturalToInteger String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_NaturalToInteger }
          rule_NaturalFromInteger :: String -> Name -> CoreRule
rule_NaturalFromInteger String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_NaturalFromInteger }
          rule_WordToNatural :: String -> Name -> CoreRule
rule_WordToNatural String
str Name
name
           = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str, ru_fn :: Name
ru_fn = Name
name, ru_nargs :: Int
ru_nargs = Int
1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_WordToNatural }

---------------------------------------------------
-- The rule is this:
--      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
--      =  unpackFoldrCString# "foobaz" c n

match_append_lit :: RuleFun
match_append_lit :: RuleFun
match_append_lit DynFlags
_ InScopeEnv
id_unf CoreBndr
_
        [ Type Type
ty1
        , CoreExpr
lit1
        , CoreExpr
c1
        , CoreExpr
e2
        ]
  -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the
  -- `lit` and `c` arguments, lest this may fail to fire when building with
  -- -g3. See #16740.
  | ([Tickish CoreBndr]
strTicks, Var CoreBndr
unpk `App` Type Type
ty2
                        `App` CoreExpr
lit2
                        `App` CoreExpr
c2
                        `App` CoreExpr
n) <- (Tickish CoreBndr -> Bool)
-> CoreExpr -> ([Tickish CoreBndr], CoreExpr)
forall b.
(Tickish CoreBndr -> Bool)
-> Expr b -> ([Tickish CoreBndr], Expr b)
stripTicksTop Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
e2
  , CoreBndr
unpk CoreBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringFoldrIdKey
  , (Tickish CoreBndr -> Bool) -> CoreExpr -> CoreExpr -> Bool
forall b. (Tickish CoreBndr -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
c1 CoreExpr
c2
  , ([Tickish CoreBndr]
c1Ticks, CoreExpr
c1') <- (Tickish CoreBndr -> Bool)
-> CoreExpr -> ([Tickish CoreBndr], CoreExpr)
forall b.
(Tickish CoreBndr -> Bool)
-> Expr b -> ([Tickish CoreBndr], Expr b)
stripTicksTop Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
c1
  , [Tickish CoreBndr]
c2Ticks <- (Tickish CoreBndr -> Bool) -> CoreExpr -> [Tickish CoreBndr]
forall b.
(Tickish CoreBndr -> Bool) -> Expr b -> [Tickish CoreBndr]
stripTicksTopT Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
c2
  , Just (LitString ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit1
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit2
  = ASSERT( ty1 `eqType` ty2 )
    CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Tickish CoreBndr] -> CoreExpr -> CoreExpr
mkTicks [Tickish CoreBndr]
strTicks
         (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
unpk CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty1
                    CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (ByteString
s1 ByteString -> ByteString -> ByteString
`BS.append` ByteString
s2))
                    CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` [Tickish CoreBndr] -> CoreExpr -> CoreExpr
mkTicks ([Tickish CoreBndr]
c1Ticks [Tickish CoreBndr] -> [Tickish CoreBndr] -> [Tickish CoreBndr]
forall a. [a] -> [a] -> [a]
++ [Tickish CoreBndr]
c2Ticks) CoreExpr
c1'
                    CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
n

match_append_lit DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

---------------------------------------------------
-- The rule is this:
--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2

match_eq_string :: RuleFun
match_eq_string :: RuleFun
match_eq_string DynFlags
_ InScopeEnv
id_unf CoreBndr
_
        [Var CoreBndr
unpk1 `App` CoreExpr
lit1, Var CoreBndr
unpk2 `App` CoreExpr
lit2]
  | CoreBndr
unpk1 CoreBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey
  , CoreBndr
unpk2 CoreBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey
  , Just (LitString ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit1
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit2
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (if ByteString
s1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
s2 then CoreExpr
trueValBool else CoreExpr
falseValBool)

match_eq_string DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing


---------------------------------------------------
-- The rule is this:
--      inline f_ty (f a b c) = <f's unfolding> a b c
-- (if f has an unfolding, EVEN if it's a loop breaker)
--
-- It's important to allow the argument to 'inline' to have args itself
-- (a) because its more forgiving to allow the programmer to write
--       inline f a b c
--   or  inline (f a b c)
-- (b) because a polymorphic f wll get a type argument that the
--     programmer can't avoid
--
-- Also, don't forget about 'inline's type argument!
match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_inline :: [CoreExpr] -> Maybe CoreExpr
match_inline (Type Type
_ : CoreExpr
e : [CoreExpr]
_)
  | (Var CoreBndr
f, [CoreExpr]
args1) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e,
    Just CoreExpr
unf <- Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreBndr -> Unfolding
realIdUnfolding CoreBndr
f)
             -- Ignore the IdUnfoldingFun here!
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
unf [CoreExpr]
args1)

match_inline [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing


-- See Note [magicDictId magic] in `basicTypes/MkId.hs`
-- for a description of what is going on here.
match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_magicDict :: [CoreExpr] -> Maybe CoreExpr
match_magicDict [Type Type
_, Var CoreBndr
wrap `App` Type Type
a `App` Type Type
_ `App` CoreExpr
f, CoreExpr
x, CoreExpr
y ]
  | Just (Type
fieldTy, Type
_)   <- Type -> Maybe (Type, Type)
splitFunTy_maybe (Type -> Maybe (Type, Type)) -> Type -> Maybe (Type, Type)
forall a b. (a -> b) -> a -> b
$ Type -> Type
dropForAlls (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Type
idType CoreBndr
wrap
  , Just (Type
dictTy, Type
_)    <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
fieldTy
  , Just TyCon
dictTc         <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
dictTy
  , Just ([CoreBndr]
_,Type
_,CoAxiom Unbranched
co)       <- TyCon -> Maybe ([CoreBndr], Type, CoAxiom Unbranched)
unwrapNewTyCon_maybe TyCon
dictTc
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just
  (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
x (Coercion -> Coercion
mkSymCo (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational CoAxiom Unbranched
co [Type
a] []))
      CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
y

match_magicDict [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

-------------------------------------------------
-- Integer rules
--   smallInteger  (79::Int#)  = 79::Integer
--   wordToInteger (79::Word#) = 79::Integer
-- Similarly Int64, Word64

match_IntToInteger :: RuleFun
match_IntToInteger :: RuleFun
match_IntToInteger = (Integer -> Integer) -> RuleFun
match_IntToInteger_unop Integer -> Integer
forall a. a -> a
id

match_WordToInteger :: RuleFun
match_WordToInteger :: RuleFun
match_WordToInteger DynFlags
_ InScopeEnv
id_unf CoreBndr
id [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumWord Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
id) of
    Just (Type
_, Type
integerTy) ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger Integer
x Type
integerTy))
    Maybe (Type, Type)
_ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_WordToInteger: Id has the wrong type"
match_WordToInteger DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Int64ToInteger :: RuleFun
match_Int64ToInteger :: RuleFun
match_Int64ToInteger DynFlags
_ InScopeEnv
id_unf CoreBndr
id [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumInt64 Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
id) of
    Just (Type
_, Type
integerTy) ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger Integer
x Type
integerTy))
    Maybe (Type, Type)
_ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_Int64ToInteger: Id has the wrong type"
match_Int64ToInteger DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Word64ToInteger :: RuleFun
match_Word64ToInteger :: RuleFun
match_Word64ToInteger DynFlags
_ InScopeEnv
id_unf CoreBndr
id [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumWord64 Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
id) of
    Just (Type
_, Type
integerTy) ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger Integer
x Type
integerTy))
    Maybe (Type, Type)
_ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_Word64ToInteger: Id has the wrong type"
match_Word64ToInteger DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_NaturalToInteger :: RuleFun
match_NaturalToInteger :: RuleFun
match_NaturalToInteger DynFlags
_ InScopeEnv
id_unf CoreBndr
id [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumNatural Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
id) of
    Just (Type
_, Type
naturalTy) ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (LitNumType -> Integer -> Type -> Literal
LitNumber LitNumType
LitNumInteger Integer
x Type
naturalTy))
    Maybe (Type, Type)
_ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_NaturalToInteger: Id has the wrong type"
match_NaturalToInteger DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_NaturalFromInteger :: RuleFun
match_NaturalFromInteger :: RuleFun
match_NaturalFromInteger DynFlags
_ InScopeEnv
id_unf CoreBndr
id [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
id) of
    Just (Type
_, Type
naturalTy) ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (LitNumType -> Integer -> Type -> Literal
LitNumber LitNumType
LitNumNatural Integer
x Type
naturalTy))
    Maybe (Type, Type)
_ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_NaturalFromInteger: Id has the wrong type"
match_NaturalFromInteger DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_WordToNatural :: RuleFun
match_WordToNatural :: RuleFun
match_WordToNatural DynFlags
_ InScopeEnv
id_unf CoreBndr
id [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumWord Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
id) of
    Just (Type
_, Type
naturalTy) ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (LitNumType -> Integer -> Type -> Literal
LitNumber LitNumType
LitNumNatural Integer
x Type
naturalTy))
    Maybe (Type, Type)
_ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_WordToNatural: Id has the wrong type"
match_WordToNatural DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

-------------------------------------------------
{- Note [Rewriting bitInteger]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For most types the bitInteger operation can be implemented in terms of shifts.
The integer-gmp package, however, can do substantially better than this if
allowed to provide its own implementation. However, in so doing it previously lost
constant-folding (see #8832). The bitInteger rule above provides constant folding
specifically for this function.

There is, however, a bit of trickiness here when it comes to ranges. While the
AST encodes all integers as Integers, `bit` expects the bit
index to be given as an Int. Hence we coerce to an Int in the rule definition.
This will behave a bit funny for constants larger than the word size, but the user
should expect some funniness given that they will have at very least ignored a
warning in this case.
-}

match_bitInteger :: RuleFun
-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer
match_bitInteger :: RuleFun
match_bitInteger DynFlags
dflags InScopeEnv
id_unf CoreBndr
fn [CoreExpr
arg]
  | Just (LitNumber LitNumType
LitNumInt Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
arg
  , Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0
  , Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= (DynFlags -> Integer
wordSizeInBits DynFlags
dflags Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
    -- Make sure x is small enough to yield a decently small iteger
    -- Attempting to construct the Integer for
    --    (bitInteger 9223372036854775807#)
    -- would be a bad idea (#14959)
  , let x_int :: Int
x_int = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x :: Int
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
fn) of
    Just (Type
_, Type
integerTy)
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (LitNumType -> Integer -> Type -> Literal
LitNumber LitNumType
LitNumInteger (Int -> Integer
forall a. Bits a => Int -> a
bit Int
x_int) Type
integerTy))
    Maybe (Type, Type)
_ -> String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_IntToInteger_unop: Id has the wrong type"

match_bitInteger DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing


-------------------------------------------------
match_Integer_convert :: Num a
                      => (DynFlags -> a -> Expr CoreBndr)
                      -> RuleFun
match_Integer_convert :: (DynFlags -> a -> CoreExpr) -> RuleFun
match_Integer_convert DynFlags -> a -> CoreExpr
convert DynFlags
dflags InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> a -> CoreExpr
convert DynFlags
dflags (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
x))
match_Integer_convert DynFlags -> a -> CoreExpr
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Integer_unop :: (Integer -> Integer) -> RuleFun
match_Integer_unop :: (Integer -> Integer) -> RuleFun
match_Integer_unop Integer -> Integer
unop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (LitNumType -> Integer -> Type -> Literal
LitNumber LitNumType
LitNumInteger (Integer -> Integer
unop Integer
x) Type
i))
match_Integer_unop Integer -> Integer
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
match_IntToInteger_unop Integer -> Integer
unop DynFlags
_ InScopeEnv
id_unf CoreBndr
fn [CoreExpr
xl]
  | Just (LitNumber LitNumType
LitNumInt Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
fn) of
    Just (Type
_, Type
integerTy) ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (LitNumType -> Integer -> Type -> Literal
LitNumber LitNumType
LitNumInteger (Integer -> Integer
unop Integer
x) Type
integerTy))
    Maybe (Type, Type)
_ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic String
"match_IntToInteger_unop: Id has the wrong type"
match_IntToInteger_unop Integer -> Integer
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop Integer -> Integer -> Integer
binop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl,CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInteger Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger (Integer
x Integer -> Integer -> Integer
`binop` Integer
y) Type
i))
match_Integer_binop Integer -> Integer -> Integer
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Natural_binop Integer -> Integer -> Integer
binop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl,CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumNatural Integer
x Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumNatural Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitNatural (Integer
x Integer -> Integer -> Integer
`binop` Integer
y) Type
i))
match_Natural_binop Integer -> Integer -> Integer
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
match_Natural_partial_binop Integer -> Integer -> Maybe Integer
binop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl,CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumNatural Integer
x Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumNatural Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Just Integer
z <- Integer
x Integer -> Integer -> Maybe Integer
`binop` Integer
y
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitNatural Integer
z Type
i))
match_Natural_partial_binop Integer -> Integer -> Maybe Integer
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

-- This helper is used for the quotRem and divMod functions
match_Integer_divop_both
   :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
match_Integer_divop_both Integer -> Integer -> (Integer, Integer)
divop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl,CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
t) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInteger Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
  , (Integer
r,Integer
s) <- Integer
x Integer -> Integer -> (Integer, Integer)
`divop` Integer
y
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type
t,Type
t] [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger Integer
r Type
t), Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger Integer
s Type
t)]
match_Integer_divop_both Integer -> Integer -> (Integer, Integer)
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

-- This helper is used for the quot and rem functions
match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_divop_one Integer -> Integer -> Integer
divop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl,CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInteger Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger (Integer
x Integer -> Integer -> Integer
`divop` Integer
y) Type
i))
match_Integer_divop_one Integer -> Integer -> Integer
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun
-- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer
-- See Note [Guarding against silly shifts]
match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun
match_Integer_shift_op Integer -> Int -> Integer
binop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl,CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInt Integer
y Type
_)     <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0
  , Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
4   -- Restrict constant-folding of shifts on Integers, somewhat
             -- arbitrary.  We can get huge shifts in inaccessible code
             -- (#15673)
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger (Integer
x Integer -> Int -> Integer
`binop` Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y) Type
i))
match_Integer_shift_op Integer -> Int -> Integer
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Prim Integer -> Integer -> Bool
binop DynFlags
dflags InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl, CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInteger Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (if Integer
x Integer -> Integer -> Bool
`binop` Integer
y then DynFlags -> CoreExpr
trueValInt DynFlags
dflags else DynFlags -> CoreExpr
falseValInt DynFlags
dflags)
match_Integer_binop_Prim Integer -> Integer -> Bool
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
match_Integer_binop_Ordering Integer -> Integer -> Ordering
binop DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl, CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInteger Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ case Integer
x Integer -> Integer -> Ordering
`binop` Integer
y of
             Ordering
LT -> CoreExpr
ltVal
             Ordering
EQ -> CoreExpr
eqVal
             Ordering
GT -> CoreExpr
gtVal
match_Integer_binop_Ordering Integer -> Integer -> Ordering
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Integer_Int_encodeFloat :: RealFloat a
                              => (a -> Expr CoreBndr)
                              -> RuleFun
match_Integer_Int_encodeFloat :: (a -> CoreExpr) -> RuleFun
match_Integer_Int_encodeFloat a -> CoreExpr
mkLit DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl,CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInt Integer
y Type
_)     <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (a -> CoreExpr
mkLit (a -> CoreExpr) -> a -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
x (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
y))
match_Integer_Int_encodeFloat a -> CoreExpr
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

---------------------------------------------------
-- constant folding for Float/Double
--
-- This turns
--      rationalToFloat n d
-- into a literal Float, and similarly for Doubles.
--
-- it's important to not match d == 0, because that may represent a
-- literal "0/0" or similar, and we can't produce a literal value for
-- NaN or +-Inf
match_rationalTo :: RealFloat a
                 => (a -> Expr CoreBndr)
                 -> RuleFun
match_rationalTo :: (a -> CoreExpr) -> RuleFun
match_rationalTo a -> CoreExpr
mkLit DynFlags
_ InScopeEnv
id_unf CoreBndr
_ [CoreExpr
xl, CoreExpr
yl]
  | Just (LitNumber LitNumType
LitNumInteger Integer
x Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumType
LitNumInteger Integer
y Type
_) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (a -> CoreExpr
mkLit (Rational -> a
forall a. Fractional a => Rational -> a
fromRational (Integer
x Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
y)))
match_rationalTo a -> CoreExpr
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_decodeDouble :: RuleFun
match_decodeDouble :: RuleFun
match_decodeDouble DynFlags
dflags InScopeEnv
id_unf CoreBndr
fn [CoreExpr
xl]
  | Just (LitDouble Rational
x) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (CoreBndr -> Type
idType CoreBndr
fn) of
    Just (Type
_, Type
res)
      | Just [Type
_lev1, Type
_lev2, Type
integerTy, Type
intHashTy] <- Type -> Maybe [Type]
tyConAppArgs_maybe Type
res
      -> case Double -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x :: Double) of
           (Integer
y, Int
z) ->
             CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type
integerTy, Type
intHashTy]
                                 [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger Integer
y Type
integerTy),
                                  Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitInt DynFlags
dflags (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
z))]
    Maybe (Type, Type)
_ ->
        String -> SDoc -> Maybe CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"match_decodeDouble: Id has the wrong type"
          (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Type
idType CoreBndr
fn))
match_decodeDouble DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_XToIntegerToX :: Name -> RuleFun
match_XToIntegerToX :: Name -> RuleFun
match_XToIntegerToX Name
n DynFlags
_ InScopeEnv
_ CoreBndr
_ [App (Var CoreBndr
x) CoreExpr
y]
  | CoreBndr -> Name
idName CoreBndr
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
y
match_XToIntegerToX Name
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_smallIntegerTo :: PrimOp -> RuleFun
match_smallIntegerTo :: PrimOp -> RuleFun
match_smallIntegerTo PrimOp
primOp DynFlags
_ InScopeEnv
_ CoreBndr
_ [App (Var CoreBndr
x) CoreExpr
y]
  | CoreBndr -> Name
idName CoreBndr
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
smallIntegerName
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (PrimOp -> CoreBndr
mkPrimOpId PrimOp
primOp)) CoreExpr
y
match_smallIntegerTo PrimOp
_ DynFlags
_ InScopeEnv
_ CoreBndr
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing



--------------------------------------------------------
-- Note [Constant folding through nested expressions]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We use rewrites rules to perform constant folding. It means that we don't
-- have a global view of the expression we are trying to optimise. As a
-- consequence we only perform local (small-step) transformations that either:
--    1) reduce the number of operations
--    2) rearrange the expression to increase the odds that other rules will
--    match
--
-- We don't try to handle more complex expression optimisation cases that would
-- require a global view. For example, rewriting expressions to increase
-- sharing (e.g., Horner's method); optimisations that require local
-- transformations increasing the number of operations; rearrangements to
-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).
--
-- We already have rules to perform constant folding on expressions with the
-- following shape (where a and/or b are literals):
--
--          D)    op
--                /\
--               /  \
--              /    \
--             a      b
--
-- To support nested expressions, we match three other shapes of expression
-- trees:
--
-- A)   op1          B)       op1       C)       op1
--      /\                    /\                 /\
--     /  \                  /  \               /  \
--    /    \                /    \             /    \
--   a     op2            op2     c          op2    op3
--          /\            /\                 /\      /\
--         /  \          /  \               /  \    /  \
--        b    c        a    b             a    b  c    d
--
--
-- R1) +/- simplification:
--    ops = + or -, two literals (not siblings)
--
--    Examples:
--       A: 5 + (10-x)  ==> 15-x
--       B: (10+x) + 5  ==> 15+x
--       C: (5+a)-(5-b) ==> 0+(a+b)
--
-- R2) * simplification
--    ops = *, two literals (not siblings)
--
--    Examples:
--       A: 5 * (10*x)  ==> 50*x
--       B: (10*x) * 5  ==> 50*x
--       C: (5*a)*(5*b) ==> 25*(a*b)
--
-- R3) * distribution over +/-
--    op1 = *, op2 = + or -, two literals (not siblings)
--
--    This transformation doesn't reduce the number of operations but switches
--    the outer and the inner operations so that the outer is (+) or (-) instead
--    of (*). It increases the odds that other rules will match after this one.
--
--    Examples:
--       A: 5 * (10-x)  ==> 50 - (5*x)
--       B: (10+x) * 5  ==> 50 + (5*x)
--       C: Not supported as it would increase the number of operations:
--          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b
--
-- R4) Simple factorization
--
--    op1 = + or -, op2/op3 = *,
--    one literal for each innermost * operation (except in the D case),
--    the two other terms are equals
--
--    Examples:
--       A: x - (10*x)  ==> (-9)*x
--       B: (10*x) + x  ==> 11*x
--       C: (5*x)-(x*3) ==> 2*x
--       D: x+x         ==> 2*x
--
-- R5) +/- propagation
--
--    ops = + or -, one literal
--
--    This transformation doesn't reduce the number of operations but propagates
--    the constant to the outer level. It increases the odds that other rules
--    will match after this one.
--
--    Examples:
--       A: x - (10-y)  ==> (x+y) - 10
--       B: (10+x) - y  ==> 10 + (x-y)
--       C: N/A (caught by the A and B cases)
--
--------------------------------------------------------

-- | Rules to perform constant folding into nested expressions
--
--See Note [Constant folding through nested expressions]
numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
op DynFlags -> PrimOps
dict = do
  [CoreExpr
e1,CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let PrimOps{Integer -> CoreExpr
CoreExpr -> CoreExpr -> CoreExpr
mkL :: PrimOps -> Integer -> CoreExpr
mul :: PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
sub :: PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
add :: PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
mkL :: Integer -> CoreExpr
mul :: CoreExpr -> CoreExpr -> CoreExpr
sub :: CoreExpr -> CoreExpr -> CoreExpr
add :: CoreExpr -> CoreExpr -> CoreExpr
..} = DynFlags -> PrimOps
dict DynFlags
dflags
  if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NumConstantFolding DynFlags
dflags)
    then RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    else case CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
e1 PrimOp
op CoreExpr
e2 of
     -- R1) +/- simplification
     Integer
x    :++: (Integer
y :++: CoreExpr
v)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v
     Integer
x    :++: (L Integer
y :-: CoreExpr
v)         -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v
     Integer
x    :++: (CoreExpr
v   :-: L Integer
y)       -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v
     L Integer
x  :-:  (Integer
y :++: CoreExpr
v)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v
     L Integer
x  :-:  (L Integer
y :-: CoreExpr
v)         -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v
     L Integer
x  :-:  (CoreExpr
v   :-: L Integer
y)       -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v

     (Integer
y :++: CoreExpr
v)    :-: L Integer
x         -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v
     (L Integer
y :-: CoreExpr
v)   :-: L Integer
x         -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v
     (CoreExpr
v   :-: L Integer
y) :-: L Integer
x         -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x) CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v

     (Integer
x :++: CoreExpr
w)  :+: (Integer
y :++: CoreExpr
v)    -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     (CoreExpr
w :-: L Integer
x) :+: (L Integer
y :-: CoreExpr
v)   -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v)
     (CoreExpr
w :-: L Integer
x) :+: (CoreExpr
v   :-: L Integer
y) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     (L Integer
x :-: CoreExpr
w) :+: (L Integer
y :-: CoreExpr
v)   -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     (L Integer
x :-: CoreExpr
w) :+: (CoreExpr
v   :-: L Integer
y) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
w)
     (CoreExpr
w :-: L Integer
x) :+: (Integer
y :++: CoreExpr
v)    -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     (L Integer
x :-: CoreExpr
w) :+: (Integer
y :++: CoreExpr
v)    -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
w)
     (Integer
y :++: CoreExpr
v)  :+: (CoreExpr
w :-: L Integer
x)   -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     (Integer
y :++: CoreExpr
v)  :+: (L Integer
x :-: CoreExpr
w)   -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
w)

     (CoreExpr
v   :-: L Integer
y) :-: (CoreExpr
w :-: L Integer
x) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
w)
     (CoreExpr
v   :-: L Integer
y) :-: (L Integer
x :-: CoreExpr
w) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
w)
     (L Integer
y :-:   CoreExpr
v) :-: (CoreExpr
w :-: L Integer
x) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
w)
     (L Integer
y :-:   CoreExpr
v) :-: (L Integer
x :-: CoreExpr
w) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v)
     (Integer
x :++: CoreExpr
w)    :-: (Integer
y :++: CoreExpr
v)  -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v)
     (CoreExpr
w :-: L Integer
x)   :-: (Integer
y :++: CoreExpr
v)  -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v)
     (L Integer
x :-: CoreExpr
w)   :-: (Integer
y :++: CoreExpr
v)  -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
w)
     (Integer
y :++: CoreExpr
v)    :-: (CoreExpr
w :-: L Integer
x) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
w)
     (Integer
y :++: CoreExpr
v)    :-: (L Integer
x :-: CoreExpr
w) -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
x)   CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
w)

     -- R2) * simplification
     Integer
x :**: (Integer
y :**: CoreExpr
v)             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (Integer
x :**: CoreExpr
w) :*: (Integer
y :**: CoreExpr
v)     -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v)

     -- R3) * distribution over +/-
     Integer
x :**: (Integer
y :++: CoreExpr
v)             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` (Integer -> CoreExpr
mkL Integer
x CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v)
     Integer
x :**: (L Integer
y :-: CoreExpr
v)            -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` (Integer -> CoreExpr
mkL Integer
x CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v)
     Integer
x :**: (CoreExpr
v   :-: L Integer
y)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> CoreExpr
mkL Integer
x CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
y)

     -- R4) Simple factorization
     CoreExpr
v :+: CoreExpr
w
      | CoreExpr
w CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
v          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL Integer
2       CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     CoreExpr
w :+: (Integer
y :**: CoreExpr
v)
      | CoreExpr
w CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
v          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     CoreExpr
w :-: (Integer
y :**: CoreExpr
v)
      | CoreExpr
w CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
v          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (Integer
y :**: CoreExpr
v) :+: CoreExpr
w
      | CoreExpr
w CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
v          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (Integer
y :**: CoreExpr
v) :-: CoreExpr
w
      | CoreExpr
w CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
v          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (Integer
x :**: CoreExpr
w) :+: (Integer
y :**: CoreExpr
v)
      | CoreExpr
w CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
v          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (Integer
x :**: CoreExpr
w) :-: (Integer
y :**: CoreExpr
v)
      | CoreExpr
w CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
v          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v

     -- R5) +/- propagation
     CoreExpr
w  :+: (Integer
y :++: CoreExpr
v)             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL Integer
y CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     (Integer
y :++: CoreExpr
v) :+: CoreExpr
w              -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL Integer
y       CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     CoreExpr
w  :-: (Integer
y :++: CoreExpr
v)             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
y
     (Integer
y :++: CoreExpr
v) :-: CoreExpr
w              -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL Integer
y       CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
v CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
w)
     CoreExpr
w    :-: (L Integer
y :-: CoreExpr
v)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
y
     (L Integer
y :-: CoreExpr
v) :-: CoreExpr
w             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL Integer
y       CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v)
     CoreExpr
w    :+: (L Integer
y :-: CoreExpr
v)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL Integer
y       CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v)
     CoreExpr
w    :+: (CoreExpr
v :-: L Integer
y)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
y
     (L Integer
y :-: CoreExpr
v) :+: CoreExpr
w             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL Integer
y       CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v)
     (CoreExpr
v :-: L Integer
y) :+: CoreExpr
w             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr
w CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
y

     CoreExpr
_                             -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero



-- | Match the application of a binary primop
pattern BinOpApp  :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
pattern $bBinOpApp :: CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
$mBinOpApp :: forall r.
CoreExpr
-> (CoreExpr -> PrimOp -> CoreExpr -> r) -> (Void# -> r) -> r
BinOpApp  x op y =  OpVal op `App` x `App` y

-- | Match a primop
pattern OpVal   :: PrimOp  -> Arg CoreBndr
pattern $bOpVal :: PrimOp -> CoreExpr
$mOpVal :: forall r. CoreExpr -> (PrimOp -> r) -> (Void# -> r) -> r
OpVal   op     <- Var (isPrimOpId_maybe -> Just op) where
   OpVal PrimOp
op = CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (PrimOp -> CoreBndr
mkPrimOpId PrimOp
op)



-- | Match a literal
pattern L :: Integer -> Arg CoreBndr
pattern $mL :: forall r. CoreExpr -> (Integer -> r) -> (Void# -> r) -> r
L l <- Lit (isLitValue_maybe -> Just l)

-- | Match an addition
pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
pattern x $m:+: :: forall r.
CoreExpr -> (CoreExpr -> CoreExpr -> r) -> (Void# -> r) -> r
:+: y <- BinOpApp x (isAddOp -> True) y

-- | Match an addition with a literal (handle commutativity)
pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr
pattern l $m:++: :: forall r.
CoreExpr -> (Integer -> CoreExpr -> r) -> (Void# -> r) -> r
:++: x <- (isAdd -> Just (l,x))

isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)
isAdd :: CoreExpr -> Maybe (Integer, CoreExpr)
isAdd CoreExpr
e = case CoreExpr
e of
   L Integer
l :+: CoreExpr
x   -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   CoreExpr
x   :+: L Integer
l -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   CoreExpr
_           -> Maybe (Integer, CoreExpr)
forall a. Maybe a
Nothing

-- | Match a multiplication
pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
pattern x $m:*: :: forall r.
CoreExpr -> (CoreExpr -> CoreExpr -> r) -> (Void# -> r) -> r
:*: y <- BinOpApp x (isMulOp -> True) y

-- | Match a multiplication with a literal (handle commutativity)
pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr
pattern l $m:**: :: forall r.
CoreExpr -> (Integer -> CoreExpr -> r) -> (Void# -> r) -> r
:**: x <- (isMul -> Just (l,x))

isMul :: CoreExpr -> Maybe (Integer,CoreExpr)
isMul :: CoreExpr -> Maybe (Integer, CoreExpr)
isMul CoreExpr
e = case CoreExpr
e of
   L Integer
l :*: CoreExpr
x   -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   CoreExpr
x   :*: L Integer
l -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   CoreExpr
_           -> Maybe (Integer, CoreExpr)
forall a. Maybe a
Nothing


-- | Match a subtraction
pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
pattern x $m:-: :: forall r.
CoreExpr -> (CoreExpr -> CoreExpr -> r) -> (Void# -> r) -> r
:-: y <- BinOpApp x (isSubOp -> True) y

isSubOp :: PrimOp -> Bool
isSubOp :: PrimOp -> Bool
isSubOp PrimOp
IntSubOp  = Bool
True
isSubOp PrimOp
WordSubOp = Bool
True
isSubOp PrimOp
_         = Bool
False

isAddOp :: PrimOp -> Bool
isAddOp :: PrimOp -> Bool
isAddOp PrimOp
IntAddOp  = Bool
True
isAddOp PrimOp
WordAddOp = Bool
True
isAddOp PrimOp
_         = Bool
False

isMulOp :: PrimOp -> Bool
isMulOp :: PrimOp -> Bool
isMulOp PrimOp
IntMulOp  = Bool
True
isMulOp PrimOp
WordMulOp = Bool
True
isMulOp PrimOp
_         = Bool
False

-- | Explicit "type-class"-like dictionary for numeric primops
--
-- Depends on DynFlags because creating a literal value depends on DynFlags
data PrimOps = PrimOps
   { PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers
   , PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers
   , PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers
   , PrimOps -> Integer -> CoreExpr
mkL :: Integer -> CoreExpr              -- ^ Create a literal value
   }

intPrimOps :: DynFlags -> PrimOps
intPrimOps :: DynFlags -> PrimOps
intPrimOps DynFlags
dflags = PrimOps :: (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (Integer -> CoreExpr)
-> PrimOps
PrimOps
   { add :: CoreExpr -> CoreExpr -> CoreExpr
add = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntAddOp CoreExpr
y
   , sub :: CoreExpr -> CoreExpr -> CoreExpr
sub = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntSubOp CoreExpr
y
   , mul :: CoreExpr -> CoreExpr -> CoreExpr
mul = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntMulOp CoreExpr
y
   , mkL :: Integer -> CoreExpr
mkL = DynFlags -> Integer -> CoreExpr
intResult' DynFlags
dflags
   }

wordPrimOps :: DynFlags -> PrimOps
wordPrimOps :: DynFlags -> PrimOps
wordPrimOps DynFlags
dflags = PrimOps :: (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (Integer -> CoreExpr)
-> PrimOps
PrimOps
   { add :: CoreExpr -> CoreExpr -> CoreExpr
add = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
WordAddOp CoreExpr
y
   , sub :: CoreExpr -> CoreExpr -> CoreExpr
sub = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
WordSubOp CoreExpr
y
   , mul :: CoreExpr -> CoreExpr -> CoreExpr
mul = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
WordMulOp CoreExpr
y
   , mkL :: Integer -> CoreExpr
mkL = DynFlags -> Integer -> CoreExpr
wordResult' DynFlags
dflags
   }


--------------------------------------------------------
-- Constant folding through case-expressions
--
-- cf Scrutinee Constant Folding in simplCore/SimplUtils
--------------------------------------------------------

-- | Match the scrutinee of a case and potentially return a new scrutinee and a
-- function to apply to each literal alternative.
caseRules :: DynFlags
          -> CoreExpr                       -- Scrutinee
          -> Maybe ( CoreExpr               -- New scrutinee
                   , AltCon -> Maybe AltCon -- How to fix up the alt pattern
                                            --   Nothing <=> Unreachable
                                            -- See Note [Unreachable caseRules alternatives]
                   , Id -> CoreExpr)        -- How to reconstruct the original scrutinee
                                            -- from the new case-binder
-- e.g  case e of b {
--         ...;
--         con bs -> rhs;
--         ... }
--  ==>
--      case e' of b' {
--         ...;
--         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
--         ... }

caseRules :: DynFlags
-> CoreExpr
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
caseRules DynFlags
dflags (App (App (Var CoreBndr
f) CoreExpr
v) (Lit Literal
l))   -- v `op` x#
  | Just PrimOp
op <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
f
  , Just Integer
x  <- Literal -> Maybe Integer
isLitValue_maybe Literal
l
  , Just Integer -> Integer
adjust_lit <- PrimOp -> Integer -> Maybe (Integer -> Integer)
adjustDyadicRight PrimOp
op Integer
x
  = (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con DynFlags
dflags Integer -> Integer
adjust_lit
           , \CoreBndr
v -> (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
f) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
v)) (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
l)))

caseRules DynFlags
dflags (App (App (Var CoreBndr
f) (Lit Literal
l)) CoreExpr
v)   -- x# `op` v
  | Just PrimOp
op <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
f
  , Just Integer
x  <- Literal -> Maybe Integer
isLitValue_maybe Literal
l
  , Just Integer -> Integer
adjust_lit <- Integer -> PrimOp -> Maybe (Integer -> Integer)
adjustDyadicLeft Integer
x PrimOp
op
  = (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con DynFlags
dflags Integer -> Integer
adjust_lit
           , \CoreBndr
v -> (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
f) (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
l)) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
v)))


caseRules DynFlags
dflags (App (Var CoreBndr
f) CoreExpr
v              )   -- op v
  | Just PrimOp
op <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
f
  , Just Integer -> Integer
adjust_lit <- PrimOp -> Maybe (Integer -> Integer)
adjustUnary PrimOp
op
  = (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con DynFlags
dflags Integer -> Integer
adjust_lit
           , \CoreBndr
v -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
f) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
v))

-- See Note [caseRules for tagToEnum]
caseRules DynFlags
dflags (App (App (Var CoreBndr
f) CoreExpr
type_arg) CoreExpr
v)
  | Just PrimOp
TagToEnumOp <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
f
  = (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, DynFlags -> AltCon -> Maybe AltCon
tx_con_tte DynFlags
dflags
           , \CoreBndr
v -> (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
f) CoreExpr
type_arg) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
v)))

-- See Note [caseRules for dataToTag]
caseRules DynFlags
_ (App (App (Var CoreBndr
f) (Type Type
ty)) CoreExpr
v)       -- dataToTag x
  | Just PrimOp
DataToTagOp <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
f
  , Just (TyCon
tc, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
  , TyCon -> Bool
isAlgTyCon TyCon
tc
  = (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, Type -> AltCon -> Maybe AltCon
tx_con_dtt Type
ty
           , \CoreBndr
v -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
f) (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty)) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
v))

caseRules DynFlags
_ CoreExpr
_ = Maybe (CoreExpr, AltCon -> Maybe AltCon, CoreBndr -> CoreExpr)
forall a. Maybe a
Nothing


tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con DynFlags
_      Integer -> Integer
_      AltCon
DEFAULT    = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just AltCon
DEFAULT
tx_lit_con DynFlags
dflags Integer -> Integer
adjust (LitAlt Literal
l) = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just (AltCon -> Maybe AltCon) -> AltCon -> Maybe AltCon
forall a b. (a -> b) -> a -> b
$ Literal -> AltCon
LitAlt (DynFlags -> (Integer -> Integer) -> Literal -> Literal
mapLitValue DynFlags
dflags Integer -> Integer
adjust Literal
l)
tx_lit_con DynFlags
_      Integer -> Integer
_      AltCon
alt        = String -> SDoc -> Maybe AltCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseRules" (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
alt)
   -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the
   -- literal alternatives remain in Word/Int target ranges
   -- (See Note [Word/Int underflow/overflow] in Literal and #13172).

adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
-- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x
adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
adjustDyadicRight PrimOp
op Integer
lit
  = case PrimOp
op of
         PrimOp
WordAddOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         PrimOp
IntAddOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         PrimOp
WordSubOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
lit      )
         PrimOp
IntSubOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
lit      )
         PrimOp
XorOp     -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         PrimOp
XorIOp    -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         PrimOp
_         -> Maybe (Integer -> Integer)
forall a. Maybe a
Nothing

adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
-- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x
adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
adjustDyadicLeft Integer
lit PrimOp
op
  = case PrimOp
op of
         PrimOp
WordAddOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         PrimOp
IntAddOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         PrimOp
WordSubOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
litInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y      )
         PrimOp
IntSubOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
litInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y      )
         PrimOp
XorOp     -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         PrimOp
XorIOp    -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         PrimOp
_         -> Maybe (Integer -> Integer)
forall a. Maybe a
Nothing


adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
-- Given (op x) return a function 'f' s.t.  f (op x) = x
adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
adjustUnary PrimOp
op
  = case PrimOp
op of
         PrimOp
NotOp     -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer -> Integer
forall a. Bits a => a -> a
complement Integer
y)
         PrimOp
NotIOp    -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer -> Integer
forall a. Bits a => a -> a
complement Integer
y)
         PrimOp
IntNegOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\Integer
y -> Integer -> Integer
forall a. Num a => a -> a
negate Integer
y    )
         PrimOp
_         -> Maybe (Integer -> Integer)
forall a. Maybe a
Nothing

tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon
tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon
tx_con_tte DynFlags
_      AltCon
DEFAULT         = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just AltCon
DEFAULT
tx_con_tte DynFlags
_      alt :: AltCon
alt@(LitAlt {}) = String -> SDoc -> Maybe AltCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseRules" (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
alt)
tx_con_tte DynFlags
dflags (DataAlt DataCon
dc)  -- See Note [caseRules for tagToEnum]
  = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just (AltCon -> Maybe AltCon) -> AltCon -> Maybe AltCon
forall a b. (a -> b) -> a -> b
$ Literal -> AltCon
LitAlt (Literal -> AltCon) -> Literal -> AltCon
forall a b. (a -> b) -> a -> b
$ DynFlags -> Integer -> Literal
mkLitInt DynFlags
dflags (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTagZ DataCon
dc

tx_con_dtt :: Type -> AltCon -> Maybe AltCon
tx_con_dtt :: Type -> AltCon -> Maybe AltCon
tx_con_dtt Type
_  AltCon
DEFAULT = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just AltCon
DEFAULT
tx_con_dtt Type
ty (LitAlt (LitNumber LitNumType
LitNumInt Integer
i Type
_))
   | Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
   , Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n_data_cons
   = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just (DataCon -> AltCon
DataAlt ([DataCon]
data_cons [DataCon] -> Int -> DataCon
forall a. [a] -> Int -> a
!! Int
tag))   -- tag is zero-indexed, as is (!!)
   | Bool
otherwise
   = Maybe AltCon
forall a. Maybe a
Nothing
   where
     tag :: Int
tag         = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i :: ConTagZ
     tc :: TyCon
tc          = Type -> TyCon
tyConAppTyCon Type
ty
     n_data_cons :: Int
n_data_cons = TyCon -> Int
tyConFamilySize TyCon
tc
     data_cons :: [DataCon]
data_cons   = TyCon -> [DataCon]
tyConDataCons TyCon
tc

tx_con_dtt Type
_ AltCon
alt = String -> SDoc -> Maybe AltCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseRules" (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
alt)


{- Note [caseRules for tagToEnum]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to transform
   case tagToEnum x of
     False -> e1
     True  -> e2
into
   case x of
     0# -> e1
     1# -> e2

This rule eliminates a lot of boilerplate. For
  if (x>y) then e2 else e1
we generate
  case tagToEnum (x ># y) of
    False -> e1
    True  -> e2
and it is nice to then get rid of the tagToEnum.

Beware (#14768): avoid the temptation to map constructor 0 to
DEFAULT, in the hope of getting this
  case (x ># y) of
    DEFAULT -> e1
    1#      -> e2
That fails utterly in the case of
   data Colour = Red | Green | Blue
   case tagToEnum x of
      DEFAULT -> e1
      Red     -> e2

We don't want to get this!
   case x of
      DEFAULT -> e1
      DEFAULT -> e2

Instead, we deal with turning one branch into DEFAULT in SimplUtils
(add_default in mkCase3).

Note [caseRules for dataToTag]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [dataToTag#] in primpops.txt.pp

We want to transform
  case dataToTag x of
    DEFAULT -> e1
    1# -> e2
into
  case x of
    DEFAULT -> e1
    (:) _ _ -> e2

Note the need for some wildcard binders in
the 'cons' case.

For the time, we only apply this transformation when the type of `x` is a type
headed by a normal tycon. In particular, we do not apply this in the case of a
data family tycon, since that would require carefully applying coercion(s)
between the data family and the data family instance's representation type,
which caseRules isn't currently engineered to handle (#14680).

Note [Unreachable caseRules alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Take care if we see something like
  case dataToTag x of
    DEFAULT -> e1
    -1# -> e2
    100 -> e3
because there isn't a data constructor with tag -1 or 100. In this case the
out-of-range alterantive is dead code -- we know the range of tags for x.

Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating
an alternative that is unreachable.

You may wonder how this can happen: check out #15436.
-}