{-
(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 #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}

module PrelRules
   ( primOpRules
   , builtinRules
   , caseRules
   )
where

#include "HsVersions.h"
#include "MachDeps.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, exprIsHNF, exprType )
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 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 nm :: Name
nm TagToEnumOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ RuleM CoreExpr
tagToEnumRule ]
primOpRules nm :: Name
nm DataToTagOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ RuleM CoreExpr
dataToTagRule ]

-- Int operations
primOpRules nm :: Name
nm IntAddOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm IntSubOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm IntAddCOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm IntSubCOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm IntMulOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm IntQuotOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ Int -> RuleM ()
nonZeroLit 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 nm :: Name
nm IntRemOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ Int -> RuleM ()
nonZeroLit 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 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 nm :: Name
nm AndIOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm OrIOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm XorIOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm NotIOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
complementOp
                                               , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
NotIOp ]
primOpRules nm :: Name
nm IntNegOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
negOp
                                               , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
IntNegOp ]
primOpRules nm :: Name
nm ISllOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm ISraOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm ISrlOp      = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule DynFlags -> Integer -> Int -> Integer
shiftRightLogical
                                               , (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zeroi ]

-- Word operations
primOpRules nm :: Name
nm WordAddOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm WordSubOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm WordAddCOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm WordSubCOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm WordMulOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm WordQuotOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ Int -> RuleM ()
nonZeroLit 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 nm :: Name
nm WordRemOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ Int -> RuleM ()
nonZeroLit 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 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 nm :: Name
nm AndOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm OrOp        = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm XorOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm NotOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
complementOp
                                               , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
NotOp ]
primOpRules nm :: Name
nm SllOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm SrlOp       = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule DynFlags -> Integer -> Int -> Integer
shiftRightLogical ]

-- coercions
primOpRules nm :: Name
nm Word2IntOp     = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags DynFlags -> Literal -> Literal
word2IntLit
                                                  , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
Int2WordOp ]
primOpRules nm :: Name
nm Int2WordOp     = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags DynFlags -> Literal -> Literal
int2WordLit
                                                  , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
Word2IntOp ]
primOpRules nm :: Name
nm Narrow8IntOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm Narrow16IntOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm Narrow32IntOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm Narrow8WordOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm Narrow16WordOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm Narrow32WordOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm OrdOp          = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
char2IntLit
                                                  , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
ChrOp ]
primOpRules nm :: Name
nm ChrOp          = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ do [Lit 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 nm :: Name
nm Float2IntOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
float2IntLit ]
primOpRules nm :: Name
nm Int2FloatOp    = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2FloatLit ]
primOpRules nm :: Name
nm Double2IntOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
double2IntLit ]
primOpRules nm :: Name
nm Int2DoubleOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2DoubleLit ]
-- SUP: Not sure what the standard says about precision in the following 2 cases
primOpRules nm :: Name
nm Float2DoubleOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
float2DoubleLit ]
primOpRules nm :: Name
nm Double2FloatOp = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
double2FloatLit ]

-- Float
primOpRules nm :: Name
nm FloatAddOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm FloatSubOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm FloatMulOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm FloatDivOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm FloatNegOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
negOp
                                                , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
FloatNegOp ]

-- Double
primOpRules nm :: Name
nm DoubleAddOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm DoubleSubOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm DoubleMulOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm DoubleDivOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 nm :: Name
nm DoubleNegOp   = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 1 [ (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit DynFlags -> Literal -> Maybe CoreExpr
negOp
                                                 , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
DoubleNegOp ]

-- Relational operators

primOpRules nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm FloatGtOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>)
primOpRules nm :: Name
nm FloatGeOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>=)
primOpRules nm :: Name
nm FloatLeOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<=)
primOpRules nm :: Name
nm FloatLtOp  = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<)
primOpRules nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm DoubleGtOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>)
primOpRules nm :: Name
nm DoubleGeOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(>=)
primOpRules nm :: Name
nm DoubleLeOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<=)
primOpRules nm :: Name
nm DoubleLtOp = Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
(<)
primOpRules nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm 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 nm :: Name
nm AddrAddOp  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 2 [ (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags DynFlags -> Literal
zeroi ]

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

primOpRules _  _          = 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 nm :: Name
nm arity :: Int
arity rules :: [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 nm :: Name
nm cmp :: forall a. Ord a => a -> a -> Bool
cmp extra :: [RuleM CoreExpr]
extra
  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 Trac #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 nm :: Name
nm cmp :: forall a. Ord a => a -> a -> Bool
cmp
  = Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm 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 dflags :: DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitInt  DynFlags
dflags 0
onei :: DynFlags -> Literal
onei  dflags :: DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitInt  DynFlags
dflags 1
zerow :: DynFlags -> Literal
zerow dflags :: DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitWord DynFlags
dflags 0
onew :: DynFlags -> Literal
onew  dflags :: DynFlags
dflags = DynFlags -> Integer -> Literal
mkLitWord DynFlags
dflags 1

zerof, onef, twof, zerod, oned, twod :: Literal
zerof :: Literal
zerof = Rational -> Literal
mkLitFloat 0.0
onef :: Literal
onef  = Rational -> Literal
mkLitFloat 1.0
twof :: Literal
twof  = Rational -> Literal
mkLitFloat 2.0
zerod :: Literal
zerod = Rational -> Literal
mkLitDouble 0.0
oned :: Literal
oned  = Rational -> Literal
mkLitDouble 1.0
twod :: Literal
twod  = Rational -> Literal
mkLitDouble 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 dflags :: DynFlags
dflags cmp :: forall a. Ord a => a -> a -> Bool
cmp = Literal -> Literal -> Maybe CoreExpr
go
  where
    done :: Bool -> Maybe CoreExpr
done 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 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 i1 :: Char
i1)   (LitChar i2 :: Char
i2)   = Bool -> Maybe CoreExpr
done (Char
i1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
`cmp` Char
i2)
    go (LitFloat i1 :: Rational
i1)  (LitFloat i2 :: Rational
i2)  = Bool -> Maybe CoreExpr
done (Rational
i1 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
`cmp` Rational
i2)
    go (LitDouble i1 :: Rational
i1) (LitDouble i2 :: Rational
i2) = Bool -> Maybe CoreExpr
done (Rational
i1 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
`cmp` Rational
i2)
    go (LitNumber nt1 :: LitNumType
nt1 i1 :: Integer
i1 _) (LitNumber nt2 :: LitNumType
nt2 i2 :: Integer
i2 _)
      | 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 _               _               = Maybe CoreExpr
forall a. Maybe a
Nothing

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

negOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Negate
negOp :: DynFlags -> Literal -> Maybe CoreExpr
negOp _      (LitFloat 0.0)  = Maybe CoreExpr
forall a. Maybe a
Nothing  -- can't represent -0.0 as a Rational
negOp dflags :: DynFlags
dflags (LitFloat f :: Rational
f)    = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Rational -> CoreExpr
mkFloatVal DynFlags
dflags (-Rational
f))
negOp _      (LitDouble 0.0) = Maybe CoreExpr
forall a. Maybe a
Nothing
negOp dflags :: DynFlags
dflags (LitDouble d :: Rational
d)   = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (DynFlags -> Rational -> CoreExpr
mkDoubleVal DynFlags
dflags (-Rational
d))
negOp dflags :: DynFlags
dflags (LitNumber nt :: LitNumType
nt i :: Integer
i t :: 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 _      _                = Maybe CoreExpr
forall a. Maybe a
Nothing

complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement
complementOp :: DynFlags -> Literal -> Maybe CoreExpr
complementOp dflags :: DynFlags
dflags (LitNumber nt :: LitNumType
nt i :: Integer
i t :: 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 _      _            = 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' op :: DynFlags -> a -> b -> Integer
op dflags :: DynFlags
dflags (LitNumber LitNumInt i1 :: Integer
i1 _) (LitNumber LitNumInt i2 :: Integer
i2 _) =
  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' _  _      _            _            = 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 op :: a -> b -> Integer
op dflags :: DynFlags
dflags (LitNumber LitNumInt i1 :: Integer
i1 _) (LitNumber LitNumInt i2 :: Integer
i2 _) = 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 _  _      _            _            = 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 dflags :: DynFlags
dflags x :: Integer
x n :: Int
n
  | DynFlags -> Integer
wordSizeInBits DynFlags
dflags Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 32 = 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)
  | DynFlags -> Integer
wordSizeInBits DynFlags
dflags Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 64 = 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)
  | Bool
otherwise = String -> Integer
forall a. String -> a
panic "shiftRightLogical: unsupported word size"

--------------------------
retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit l :: 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 l :: 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 op :: a -> b -> Integer
op dflags :: DynFlags
dflags (LitNumber LitNumWord w1 :: Integer
w1 _) (LitNumber LitNumWord w2 :: Integer
w2 _)
    = 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 _ _ _ _ = 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 op :: a -> b -> Integer
op dflags :: DynFlags
dflags (LitNumber LitNumWord w1 :: Integer
w1 _) (LitNumber LitNumWord w2 :: Integer
w2 _) =
  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 _ _ _ _ = 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 shift_op :: DynFlags -> Integer -> Int -> Integer
shift_op
  = do { DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; [e1 :: CoreExpr
e1, Lit (LitNumber LitNumInt shift_len :: Integer
shift_len _)] <- RuleM [CoreExpr]
getArgs
       ; case CoreExpr
e1 of
           _ | Integer
shift_len Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 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
< 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 0 (CoreExpr -> Type
exprType CoreExpr
e1)

           -- Do the shift at type Integer, but shift length is Int
           Lit (LitNumber nt :: LitNumType
nt x :: Integer
x t :: Type
t)
             | 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))

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

wordSizeInBits :: DynFlags -> Integer
wordSizeInBits :: DynFlags -> Integer
wordSizeInBits dflags :: DynFlags
dflags = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Platform -> Int
platformWordSize (DynFlags -> Platform
targetPlatform DynFlags
dflags) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 3)

--------------------------
floatOp2 :: (Rational -> Rational -> Rational)
         -> DynFlags -> Literal -> Literal
         -> Maybe (Expr CoreBndr)
floatOp2 :: (Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
floatOp2 op :: Rational -> Rational -> Rational
op dflags :: DynFlags
dflags (LitFloat f1 :: Rational
f1) (LitFloat f2 :: 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 _ _ _ _ = 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 op :: Rational -> Rational -> Rational
op dflags :: DynFlags
dflags (LitDouble f1 :: Rational
f1) (LitDouble f2 :: 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 _ _ _ _ = 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 is_eq :: Bool
is_eq = [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
  [ do [Lit lit :: Literal
lit, expr :: 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 [expr :: CoreExpr
expr, Lit 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 dflags :: DynFlags
dflags lit :: Literal
lit expr :: 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 op :: Comparison
op = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [a :: CoreExpr
a, b :: 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 dflags :: DynFlags
dflags Gt (Lit 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 dflags :: DynFlags
dflags Le (Lit 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 dflags :: DynFlags
dflags Ge _ (Lit 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 dflags :: DynFlags
dflags Lt _ (Lit 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 dflags :: DynFlags
dflags Ge (Lit 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 dflags :: DynFlags
dflags Lt (Lit 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 dflags :: DynFlags
dflags Gt _ (Lit 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 dflags :: DynFlags
dflags Le _ (Lit 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 _ _ _ _                                       = Maybe CoreExpr
forall a. Maybe a
Nothing

isMinBound :: DynFlags -> Literal -> Bool
isMinBound :: DynFlags -> Literal -> Bool
isMinBound _      (LitChar c :: Char
c)        = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
minBound
isMinBound dflags :: DynFlags
dflags (LitNumber nt :: LitNumType
nt i :: Integer
i _) = case LitNumType
nt of
   LitNumInt     -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Integer
tARGET_MIN_INT DynFlags
dflags
   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)
   LitNumWord    -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0
   LitNumWord64  -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0
   LitNumNatural -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0
   LitNumInteger -> Bool
False
isMinBound _      _                  = Bool
False

isMaxBound :: DynFlags -> Literal -> Bool
isMaxBound :: DynFlags -> Literal -> Bool
isMaxBound _      (LitChar c :: Char
c)       = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
maxBound
isMaxBound dflags :: DynFlags
dflags (LitNumber nt :: LitNumType
nt i :: Integer
i _) = case LitNumType
nt of
   LitNumInt     -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Integer
tARGET_MAX_INT DynFlags
dflags
   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)
   LitNumWord    -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Integer
tARGET_MAX_WORD DynFlags
dflags
   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)
   LitNumNatural -> Bool
False
   LitNumInteger -> Bool
False
isMaxBound _      _                  = 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 dflags :: DynFlags
dflags result :: 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' dflags :: DynFlags
dflags result :: 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 dflags :: DynFlags
dflags result :: 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]
    (lit :: Literal
lit, b :: 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 dflags :: DynFlags
dflags result :: 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' dflags :: DynFlags
dflags result :: 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 dflags :: DynFlags
dflags result :: 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]
    (lit :: Literal
lit, b :: 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
primop = do
  [Var primop_id :: Id
primop_id `App` e :: CoreExpr
e] <- RuleM [CoreExpr]
getArgs
  PrimOp -> Id -> RuleM ()
matchPrimOpId PrimOp
primop Id
primop_id
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e

subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
this :: PrimOp
this subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` that :: PrimOp
that = do
  [Var primop_id :: Id
primop_id `App` e :: CoreExpr
e] <- RuleM [CoreExpr]
getArgs
  PrimOp -> Id -> RuleM ()
matchPrimOpId PrimOp
that Id
primop_id
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
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
primop = do
  [e :: CoreExpr
e@(Var primop_id :: Id
primop_id `App` _)] <- RuleM [CoreExpr]
getArgs
  PrimOp -> Id -> RuleM ()
matchPrimOpId PrimOp
primop Id
primop_id
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e

idempotent :: RuleM CoreExpr
idempotent :: RuleM CoreExpr
idempotent = do [e1 :: CoreExpr
e1, e2 :: 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 op_name :: Name
op_name n_args :: Int
n_args rm :: 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 = \ dflags :: DynFlags
dflags in_scope :: InScopeEnv
in_scope _ -> 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 }

instance Functor RuleM where
    fmap :: (a -> b) -> RuleM a -> RuleM b
fmap = (a -> b) -> RuleM a -> RuleM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative RuleM where
    pure :: a -> RuleM a
pure x :: 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
$ \_ _ _ -> 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 f :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f >>= :: RuleM a -> (a -> RuleM b) -> RuleM b
>>= g :: 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
$ \dflags :: DynFlags
dflags iu :: InScopeEnv
iu e :: [CoreExpr]
e -> case DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f DynFlags
dflags InScopeEnv
iu [CoreExpr]
e of
    Nothing -> Maybe b
forall a. Maybe a
Nothing
    Just r :: 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 _ = 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
$ \_ _ _ -> Maybe a
forall a. Maybe a
Nothing
  RuleM f1 :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe a
f1 <|> :: RuleM a -> RuleM a -> RuleM a
<|> RuleM f2 :: 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
$ \dflags :: DynFlags
dflags iu :: InScopeEnv
iu args :: [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
$ \dflags :: DynFlags
dflags _ _ -> DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just DynFlags
dflags

liftMaybe :: Maybe a -> RuleM a
liftMaybe :: Maybe a -> RuleM a
liftMaybe Nothing = RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
liftMaybe (Just x :: 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 f :: 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 f :: DynFlags -> Literal -> Literal
f = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit 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
  if DynFlags -> Integer
wordSizeInBits DynFlags
dflags Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 32
  then do
    [e :: CoreExpr
e] <- RuleM [CoreExpr]
getArgs
    CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
  else 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
$ \_ _ args :: [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
$ \_ iu :: InScopeEnv
iu _ -> 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 n :: 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
$ \_ _ exprs :: [CoreExpr]
exprs -> case Int -> [CoreExpr] -> [CoreExpr]
forall a. Int -> [a] -> [a]
drop Int
n [CoreExpr]
exprs of
  (Lit l :: Literal
l:_) -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
  _ -> Maybe Literal
forall a. Maybe a
Nothing

unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit op :: DynFlags -> Literal -> Maybe CoreExpr
op = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit l :: 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 op :: DynFlags -> Literal -> Literal -> Maybe CoreExpr
op = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit l1 :: Literal
l1, Lit l2 :: 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 op :: 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
-> (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 id_lit :: 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 id_lit :: 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 lit :: 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 id_lit :: DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit l1 :: Literal
l1, e2 :: 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 id_lit :: DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit l1 :: Literal
l1, e2 :: 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 id_lit :: DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [e1 :: CoreExpr
e1, Lit l2 :: 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 id_lit :: DynFlags -> Literal
id_lit = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [e1 :: CoreExpr
e1, Lit l2 :: 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 lit :: 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 lit :: 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 zero :: DynFlags -> Literal
zero = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [Lit l1 :: Literal
l1, _] <- 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 zero :: DynFlags -> Literal
zero = do
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [_, Lit l2 :: 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 lit :: 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
  [e1 :: CoreExpr
e1, e2 :: 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 n :: 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 dflags :: DynFlags
dflags (LitFloat  f :: 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 dflags :: DynFlags
dflags (LitDouble d :: 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 _ l :: Literal
l = Literal
l

guardFloatDiv :: RuleM ()
guardFloatDiv :: RuleM ()
guardFloatDiv = do
  [Lit (LitFloat f1 :: Rational
f1), Lit (LitFloat f2 :: 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
/=0 Bool -> Bool -> Bool
|| Rational
f2 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> 0) -- see Note [negative zero]
       Bool -> Bool -> Bool
&& Rational
f2 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= 0            -- avoid NaN and Infinity/-Infinity

guardDoubleDiv :: RuleM ()
guardDoubleDiv :: RuleM ()
guardDoubleDiv = do
  [Lit (LitDouble d1 :: Rational
d1), Lit (LitDouble d2 :: 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
/=0 Bool -> Bool -> Bool
|| Rational
d2 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> 0) -- see Note [negative zero]
       Bool -> Bool -> Bool
&& Rational
d2 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 two_lit :: Literal
two_lit add_op :: 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 [arg :: CoreExpr
arg, Lit mult_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 mult_lit :: Literal
mult_lit, arg :: 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
$ Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
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  dflags :: 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 dflags :: 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   = Id -> CoreExpr
forall b. Id -> Expr b
Var Id
trueDataConId -- see Note [What's true and false]
falseValBool :: CoreExpr
falseValBool  = Id -> CoreExpr
forall b. Id -> Expr b
Var Id
falseDataConId

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

mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
mkIntVal :: DynFlags -> Integer -> CoreExpr
mkIntVal dflags :: DynFlags
dflags i :: 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 dflags :: DynFlags
dflags f :: 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 dflags :: DynFlags
dflags d :: 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 -> Id -> RuleM ()
matchPrimOpId op :: PrimOp
op id :: Id
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
$ Id -> Maybe PrimOp
isPrimOpId_maybe Id
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 ty :: Type
ty, Lit (LitNumber LitNumInt i :: Integer
i _)] <- RuleM [CoreExpr]
getArgs
  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
    Just (tycon :: TyCon
tycon, tc_args :: [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 dc :: DataCon
dc = (DataCon -> Int
dataConTagZ DataCon
dc) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tag
      (dc :: DataCon
dc:rest :: [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 (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
dc)) [Type]
tc_args

    -- See Note [tagToEnum#]
    _ -> 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
$ Id -> Type -> String -> CoreExpr
mkRuntimeErrorApp Id
rUNTIME_ERROR_ID Type
ty "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 ty1 :: Type
ty1, Var tag_to_enum :: Id
tag_to_enum `App` Type ty2 :: Type
ty2 `App` tag :: 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
$ Id
tag_to_enum Id -> 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
      [_, val_arg :: CoreExpr
val_arg] <- RuleM [CoreExpr]
getArgs
      InScopeEnv
in_scope <- RuleM InScopeEnv
getInScopeEnv
      (dc :: DataCon
dc,_,_) <- Maybe (DataCon, [Type], [CoreExpr])
-> RuleM (DataCon, [Type], [CoreExpr])
forall a. Maybe a -> RuleM a
liftMaybe (Maybe (DataCon, [Type], [CoreExpr])
 -> RuleM (DataCon, [Type], [CoreExpr]))
-> Maybe (DataCon, [Type], [CoreExpr])
-> RuleM (DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$ InScopeEnv -> CoreExpr -> Maybe (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
$ 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 StgCmmExpr.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 Trac #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 Trac #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)

- StgCmmExpr.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 ty_a :: Type
ty_a, Type _ty_s :: Type
_ty_s, a :: CoreExpr
a, s :: 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 "AppendLitString",
                   ru_fn :: Name
ru_fn = Name
unpackCStringFoldrName,
                   ru_nargs :: Int
ru_nargs = 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 "EqString", ru_fn :: Name
ru_fn = Name
eqStringName,
                   ru_nargs :: Int
ru_nargs = 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 "Inline", ru_fn :: Name
ru_fn = Name
inlineIdName,
                   ru_nargs :: Int
ru_nargs = 2, ru_try :: RuleFun
ru_try = \_ _ _ -> [CoreExpr] -> Maybe CoreExpr
match_inline },
     BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit "MagicDict", ru_fn :: Name
ru_fn = Id -> Name
idName Id
magicDictId,
                   ru_nargs :: Int
ru_nargs = 4, ru_try :: RuleFun
ru_try = \_ _ _ -> [CoreExpr] -> Maybe CoreExpr
match_magicDict },
     Name -> Int -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
divIntName 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 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
          [arg :: CoreExpr
arg, Lit (LitNumber LitNumInt d :: Integer
d _)] <- RuleM [CoreExpr]
getArgs
          Just n :: 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
$ Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
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 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 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
          [arg :: CoreExpr
arg, Lit (LitNumber LitNumInt d :: Integer
d _)] <- RuleM [CoreExpr]
getArgs
          Just _ <- 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
$ Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
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
- 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   "smallInteger"        Name
smallIntegerName,
  String -> Name -> CoreRule
rule_WordToInteger  "wordToInteger"       Name
wordToIntegerName,
  String -> Name -> CoreRule
rule_Int64ToInteger  "int64ToInteger"     Name
int64ToIntegerName,
  String -> Name -> CoreRule
rule_Word64ToInteger "word64ToInteger"    Name
word64ToIntegerName,
  String -> Name -> (DynFlags -> Word -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        "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        "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        "integerToWord64"     Name
integerToWord64Name     (\_ -> 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        "integerToInt64"      Name
integerToInt64Name      (\_ -> Int64 -> CoreExpr
forall b. Int64 -> Expr b
mkInt64LitInt64),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "plusInteger"         Name
plusIntegerName         Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "minusInteger"        Name
minusIntegerName        (-),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "timesInteger"        Name
timesIntegerName        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*),
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           "negateInteger"       Name
negateIntegerName       Integer -> Integer
forall a. Num a => a -> a
negate,
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     "eqInteger#"          Name
eqIntegerPrimName       Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     "neqInteger#"         Name
neqIntegerPrimName      Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(/=),
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           "absInteger"          Name
absIntegerName          Integer -> Integer
forall a. Num a => a -> a
abs,
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           "signumInteger"       Name
signumIntegerName       Integer -> Integer
forall a. Num a => a -> a
signum,
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     "leInteger#"          Name
leIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     "gtInteger#"          Name
gtIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     "ltInteger#"          Name
ltIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<),
  String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
rule_binop_Prim     "geInteger#"          Name
geIntegerPrimName       Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=),
  String -> Name -> (Integer -> Integer -> Ordering) -> CoreRule
rule_binop_Ordering "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    "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        "floatFromInteger"    Name
floatFromIntegerName    (\_ -> Float -> CoreExpr
forall b. Float -> Expr b
mkFloatLitFloat),
  String -> Name -> (Double -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rule_encodeFloat    "encodeDoubleInteger" Name
encodeDoubleIntegerName Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble,
  String -> Name -> CoreRule
rule_decodeDouble   "decodeDoubleInteger" Name
decodeDoubleIntegerName,
  String -> Name -> (DynFlags -> Double -> CoreExpr) -> CoreRule
forall a.
Num a =>
String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert        "doubleFromInteger"   Name
doubleFromIntegerName   (\_ -> Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble),
  String -> Name -> (Float -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rule_rationalTo     "rationalToFloat"     Name
rationalToFloatName     Float -> CoreExpr
mkFloatExpr,
  String -> Name -> (Double -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rule_rationalTo     "rationalToDouble"    Name
rationalToDoubleName    Double -> CoreExpr
mkDoubleExpr,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "gcdInteger"          Name
gcdIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "lcmInteger"          Name
lcmIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
lcm,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "andInteger"          Name
andIntegerName          Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "orInteger"           Name
orIntegerName           Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.),
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop          "xorInteger"          Name
xorIntegerName          Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor,
  String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop           "complementInteger"   Name
complementIntegerName   Integer -> Integer
forall a. Bits a => a -> a
complement,
  String -> Name -> (Integer -> Int -> Integer) -> CoreRule
rule_shift_op       "shiftLInteger"       Name
shiftLIntegerName       Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL,
  String -> Name -> (Integer -> Int -> Integer) -> CoreRule
rule_shift_op       "shiftRInteger"       Name
shiftRIntegerName       Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftR,
  String -> Name -> CoreRule
rule_bitInteger     "bitInteger"          Name
bitIntegerName,
  -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      "quotInteger"         Name
quotIntegerName         Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      "remInteger"          Name
remIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      "divInteger"          Name
divIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div,
  String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_divop_one      "modInteger"          Name
modIntegerName          Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod,
  String
-> Name -> (Integer -> Integer -> (Integer, Integer)) -> CoreRule
rule_divop_both     "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     "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 "smallIntegerToInt"       Name
integerToIntName    Name
smallIntegerName,
  String -> Name -> Name -> CoreRule
rule_XToIntegerToX "wordToIntegerToWord"     Name
integerToWordName   Name
wordToIntegerName,
  String -> Name -> Name -> CoreRule
rule_XToIntegerToX "int64ToIntegerToInt64"   Name
integerToInt64Name  Name
int64ToIntegerName,
  String -> Name -> Name -> CoreRule
rule_XToIntegerToX "word64ToIntegerToWord64" Name
integerToWord64Name Name
word64ToIntegerName,
  String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo "smallIntegerToWord"   Name
integerToWordName     PrimOp
Int2WordOp,
  String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo "smallIntegerToFloat"  Name
floatFromIntegerName  PrimOp
Int2FloatOp,
  String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo "smallIntegerToDouble" Name
doubleFromIntegerName PrimOp
Int2DoubleOp
  ]
    where rule_convert :: String -> Name -> (DynFlags -> a -> CoreExpr) -> CoreRule
rule_convert str :: String
str name :: Name
name convert :: 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 = 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 str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_IntToInteger }
          rule_WordToInteger :: String -> Name -> CoreRule
rule_WordToInteger str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_WordToInteger }
          rule_Int64ToInteger :: String -> Name -> CoreRule
rule_Int64ToInteger str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_Int64ToInteger }
          rule_Word64ToInteger :: String -> Name -> CoreRule
rule_Word64ToInteger str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_Word64ToInteger }
          rule_unop :: String -> Name -> (Integer -> Integer) -> CoreRule
rule_unop str :: String
str name :: Name
name op :: 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 = 1,
                           ru_try :: RuleFun
ru_try = (Integer -> Integer) -> RuleFun
match_Integer_unop Integer -> Integer
op }
          rule_bitInteger :: String -> Name -> CoreRule
rule_bitInteger str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_bitInteger }
          rule_binop :: String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_decodeDouble }
          rule_XToIntegerToX :: String -> Name -> Name -> CoreRule
rule_XToIntegerToX str :: String
str name :: Name
name toIntegerName :: 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 = 1,
                           ru_try :: RuleFun
ru_try = Name -> RuleFun
match_XToIntegerToX Name
toIntegerName }
          rule_smallIntegerTo :: String -> Name -> PrimOp -> CoreRule
rule_smallIntegerTo str :: String
str name :: Name
name primOp :: 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 = 1,
                           ru_try :: RuleFun
ru_try = PrimOp -> RuleFun
match_smallIntegerTo PrimOp
primOp }
          rule_rationalTo :: String -> Name -> (a -> CoreExpr) -> CoreRule
rule_rationalTo str :: String
str name :: Name
name mkLit :: 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 = 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              "plusNatural"        Name
plusNaturalName         Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)
 ,String -> Name -> (Integer -> Integer -> Maybe Integer) -> CoreRule
rule_partial_binop      "minusNatural"       Name
minusNaturalName        (\a :: Integer
a b :: 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              "timesNatural"       Name
timesNaturalName        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*)
 ,String -> Name -> CoreRule
rule_NaturalFromInteger "naturalFromInteger" Name
naturalFromIntegerName
 ,String -> Name -> CoreRule
rule_NaturalToInteger   "naturalToInteger"   Name
naturalToIntegerName
 ,String -> Name -> CoreRule
rule_WordToNatural      "wordToNatural"      Name
wordToNaturalName
 ]
    where rule_binop :: String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
rule_binop str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: Name
name op :: 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 = 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 str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_NaturalToInteger }
          rule_NaturalFromInteger :: String -> Name -> CoreRule
rule_NaturalFromInteger str :: String
str name :: 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 = 1,
                           ru_try :: RuleFun
ru_try = RuleFun
match_NaturalFromInteger }
          rule_WordToNatural :: String -> Name -> CoreRule
rule_WordToNatural str :: String
str name :: 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 = 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 _ id_unf :: InScopeEnv
id_unf _
        [ Type ty1 :: Type
ty1
        , lit1 :: CoreExpr
lit1
        , c1 :: CoreExpr
c1
        , Var unpk :: Id
unpk `App` Type ty2 :: Type
ty2
                   `App` lit2 :: CoreExpr
lit2
                   `App` c2 :: CoreExpr
c2
                   `App` n :: CoreExpr
n
        ]
  | Id
unpk Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringFoldrIdKey Bool -> Bool -> Bool
&&
    CoreExpr
c1 CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
c2
  , Just (LitString s1 :: ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit1
  , Just (LitString s2 :: 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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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` CoreExpr
c1
                   CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
n)

match_append_lit _ _ _ _ = 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 _ id_unf :: InScopeEnv
id_unf _
        [Var unpk1 :: Id
unpk1 `App` lit1 :: CoreExpr
lit1, Var unpk2 :: Id
unpk2 `App` lit2 :: CoreExpr
lit2]
  | Id
unpk1 Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey
  , Id
unpk2 Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey
  , Just (LitString s1 :: ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit1
  , Just (LitString s2 :: 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 _ _ _ _ = 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 _ : e :: CoreExpr
e : _)
  | (Var f :: Id
f, args1 :: [CoreExpr]
args1) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e,
    Just unf :: CoreExpr
unf <- Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (Id -> Unfolding
realIdUnfolding Id
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 _ = 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 _, Var wrap :: Id
wrap `App` Type a :: Type
a `App` Type _ `App` f :: CoreExpr
f, x :: CoreExpr
x, y :: CoreExpr
y ]
  | Just (fieldTy :: Type
fieldTy, _)   <- 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
$ Id -> Type
idType Id
wrap
  , Just (dictTy :: Type
dictTy, _)    <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
fieldTy
  , Just dictTc :: TyCon
dictTc         <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
dictTy
  , Just (_,_,co :: CoAxiom Unbranched
co)       <- TyCon -> Maybe ([Id], 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 _ = 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 _ id_unf :: InScopeEnv
id_unf id :: Id
id [xl :: CoreExpr
xl]
  | Just (LitNumber LitNumWord x :: Integer
x _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (Id -> Type
idType Id
id) of
    Just (_, integerTy :: 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))
    _ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic "match_WordToInteger: Id has the wrong type"
match_WordToInteger _ _ _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing

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

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

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

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

match_WordToNatural :: RuleFun
match_WordToNatural :: RuleFun
match_WordToNatural _ id_unf :: InScopeEnv
id_unf id :: Id
id [xl :: CoreExpr
xl]
  | Just (LitNumber LitNumWord x :: Integer
x _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (Id -> Type
idType Id
id) of
    Just (_, naturalTy :: 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))
    _ ->
        String -> Maybe CoreExpr
forall a. String -> a
panic "match_WordToNatural: Id has the wrong type"
match_WordToNatural _ _ _ _ = 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 Trac #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 dflags :: DynFlags
dflags id_unf :: InScopeEnv
id_unf fn :: Id
fn [arg :: CoreExpr
arg]
  | Just (LitNumber LitNumInt x :: Integer
x _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
arg
  , Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 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
- 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 (Trac #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 (Id -> Type
idType Id
fn) of
    Just (_, integerTy :: 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))
    _ -> String -> Maybe CoreExpr
forall a. String -> a
panic "match_IntToInteger_unop: Id has the wrong type"

match_bitInteger _ _ _ _ = 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 convert :: DynFlags -> a -> CoreExpr
convert dflags :: DynFlags
dflags id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl]
  | Just (LitNumber LitNumInteger x :: Integer
x _) <- 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 _ _ _ _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Integer_unop :: (Integer -> Integer) -> RuleFun
match_Integer_unop :: (Integer -> Integer) -> RuleFun
match_Integer_unop unop :: Integer -> Integer
unop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl]
  | Just (LitNumber LitNumInteger x :: Integer
x i :: 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 _ _ _ _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing

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

match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop binop :: Integer -> Integer -> Integer
binop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl,yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x i :: Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInteger y :: Integer
y _) <- 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 _ _ _ _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Natural_binop binop :: Integer -> Integer -> Integer
binop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl,yl :: CoreExpr
yl]
  | Just (LitNumber LitNumNatural x :: Integer
x i :: Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumNatural y :: Integer
y _) <- 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 _ _ _ _ _ = 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 binop :: Integer -> Integer -> Maybe Integer
binop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl,yl :: CoreExpr
yl]
  | Just (LitNumber LitNumNatural x :: Integer
x i :: Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumNatural y :: Integer
y _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Just z :: 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 _ _ _ _ _ = 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 divop :: Integer -> Integer -> (Integer, Integer)
divop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl,yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x t :: Type
t) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInteger y :: Integer
y _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
  , (r :: Integer
r,s :: 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 _ _ _ _ _ = 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 divop :: Integer -> Integer -> Integer
divop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl,yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x i :: Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInteger y :: Integer
y _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 _ _ _ _ _ = 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 binop :: Integer -> Int -> Integer
binop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl,yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x i :: Type
i) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInt y :: Integer
y _)     <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 0
  , Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 4   -- Restrict constant-folding of shifts on Integers, somewhat
             -- arbitrary.  We can get huge shifts in inaccessible code
             -- (Trac #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 _ _ _ _ _ = 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 binop :: Integer -> Integer -> Bool
binop dflags :: DynFlags
dflags id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl, yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInteger y :: Integer
y _) <- 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 _ _ _ _ _ = 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 binop :: Integer -> Integer -> Ordering
binop _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl, yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInteger y :: Integer
y _) <- 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
             LT -> CoreExpr
ltVal
             EQ -> CoreExpr
eqVal
             GT -> CoreExpr
gtVal
match_Integer_binop_Ordering _ _ _ _ _ = 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 mkLit :: a -> CoreExpr
mkLit _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl,yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInt y :: Integer
y _)     <- 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 _ _ _ _ _ = 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 mkLit :: a -> CoreExpr
mkLit _ id_unf :: InScopeEnv
id_unf _ [xl :: CoreExpr
xl, yl :: CoreExpr
yl]
  | Just (LitNumber LitNumInteger x :: Integer
x _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  , Just (LitNumber LitNumInteger y :: Integer
y _) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
yl
  , Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 _ _ _ _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_decodeDouble :: RuleFun
match_decodeDouble :: RuleFun
match_decodeDouble dflags :: DynFlags
dflags id_unf :: InScopeEnv
id_unf fn :: Id
fn [xl :: CoreExpr
xl]
  | Just (LitDouble x :: Rational
x) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
xl
  = case Type -> Maybe (Type, Type)
splitFunTy_maybe (Id -> Type
idType Id
fn) of
    Just (_, res :: Type
res)
      | Just [_lev1 :: Type
_lev1, _lev2 :: Type
_lev2, integerTy :: Type
integerTy, intHashTy :: 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
           (y :: Integer
y, z :: 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))]
    _ ->
        String -> SDoc -> Maybe CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic "match_decodeDouble: Id has the wrong type"
          (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
fn))
match_decodeDouble _ _ _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_XToIntegerToX :: Name -> RuleFun
match_XToIntegerToX :: Name -> RuleFun
match_XToIntegerToX n :: Name
n _ _ _ [App (Var x :: Id
x) y :: CoreExpr
y]
  | Id -> Name
idName Id
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 _ _ _ _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing

match_smallIntegerTo :: PrimOp -> RuleFun
match_smallIntegerTo :: PrimOp -> RuleFun
match_smallIntegerTo primOp :: PrimOp
primOp _ _ _ [App (Var x :: Id
x) y :: CoreExpr
y]
  | Id -> Name
idName Id
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 (Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
mkPrimOpId PrimOp
primOp)) CoreExpr
y
match_smallIntegerTo _ _ _ _ _ = 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 op :: PrimOp
op dict :: DynFlags -> PrimOps
dict = do
  [e1 :: CoreExpr
e1,e2 :: CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
  DynFlags
dflags <- RuleM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let PrimOps{..} = 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
     x :: Integer
x    :++: (y :: Integer
y :++: v :: 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
     x :: Integer
x    :++: (L y :: Integer
y :-: v :: 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
     x :: Integer
x    :++: (v :: CoreExpr
v   :-: L y :: 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 x :: Integer
x  :-:  (y :: Integer
y :++: v :: 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 x :: Integer
x  :-:  (L y :: Integer
y :-: v :: 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 x :: Integer
x  :-:  (v :: CoreExpr
v   :-: L y :: 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

     (y :: Integer
y :++: v :: CoreExpr
v)    :-: L x :: 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 y :: Integer
y :-: v :: CoreExpr
v)   :-: L x :: 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
     (v :: CoreExpr
v   :-: L y :: Integer
y) :-: L x :: 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 (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

     (x :: Integer
x :++: w :: CoreExpr
w)  :+: (y :: Integer
y :++: v :: 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)
     (w :: CoreExpr
w :-: L x :: Integer
x) :+: (L y :: Integer
y :-: v :: 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)
     (w :: CoreExpr
w :-: L x :: Integer
x) :+: (v :: CoreExpr
v   :-: L y :: 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 (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 x :: Integer
x :-: w :: CoreExpr
w) :+: (L y :: Integer
y :-: v :: 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 x :: Integer
x :-: w :: CoreExpr
w) :+: (v :: CoreExpr
v   :-: L y :: 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)
     (w :: CoreExpr
w :-: L x :: Integer
x) :+: (y :: Integer
y :++: v :: 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 x :: Integer
x :-: w :: CoreExpr
w) :+: (y :: Integer
y :++: v :: 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)
     (y :: Integer
y :++: v :: CoreExpr
v)  :+: (w :: CoreExpr
w :-: L x :: 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)
     (y :: Integer
y :++: v :: CoreExpr
v)  :+: (L x :: Integer
x :-: w :: 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)

     (v :: CoreExpr
v   :-: L y :: Integer
y) :-: (w :: CoreExpr
w :-: L x :: 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)
     (v :: CoreExpr
v   :-: L y :: Integer
y) :-: (L x :: Integer
x :-: w :: 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 (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 y :: Integer
y :-:   v :: CoreExpr
v) :-: (w :: CoreExpr
w :-: L x :: 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 y :: Integer
y :-:   v :: CoreExpr
v) :-: (L x :: Integer
x :-: w :: 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)
     (x :: Integer
x :++: w :: CoreExpr
w)    :-: (y :: Integer
y :++: v :: 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)
     (w :: CoreExpr
w :-: L x :: Integer
x)   :-: (y :: Integer
y :++: v :: 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 (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 x :: Integer
x :-: w :: CoreExpr
w)   :-: (y :: Integer
y :++: v :: 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)
     (y :: Integer
y :++: v :: CoreExpr
v)    :-: (w :: CoreExpr
w :-: L x :: 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)
     (y :: Integer
y :++: v :: CoreExpr
v)    :-: (L x :: Integer
x :-: w :: 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
     x :: Integer
x :**: (y :: Integer
y :**: v :: 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
     (x :: Integer
x :**: w :: CoreExpr
w) :*: (y :: Integer
y :**: v :: 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 +/-
     x :: Integer
x :**: (y :: Integer
y :++: v :: 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)
     x :: Integer
x :**: (L y :: Integer
y :-: v :: 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)
     x :: Integer
x :**: (v :: CoreExpr
v   :-: L y :: 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
     v :: CoreExpr
v :+: w :: 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 2       CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     w :: CoreExpr
w :+: (y :: Integer
y :**: v :: 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 (1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     w :: CoreExpr
w :-: (y :: Integer
y :**: v :: 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 (1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (y :: Integer
y :**: v :: CoreExpr
v) :+: w :: 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
+1)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (y :: Integer
y :**: v :: CoreExpr
v) :-: w :: 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
-1)   CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
v
     (x :: Integer
x :**: w :: CoreExpr
w) :+: (y :: Integer
y :**: v :: 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
     (x :: Integer
x :**: w :: CoreExpr
w) :-: (y :: Integer
y :**: v :: 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
     w :: CoreExpr
w  :+: (y :: Integer
y :++: v :: 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)
     (y :: Integer
y :++: v :: CoreExpr
v) :+: w :: 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)
     w :: CoreExpr
w  :-: (y :: Integer
y :++: v :: 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
     (y :: Integer
y :++: v :: CoreExpr
v) :-: w :: 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)
     w :: CoreExpr
w    :-: (L y :: Integer
y :-: v :: 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 y :: Integer
y :-: v :: CoreExpr
v) :-: w :: 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)
     w :: CoreExpr
w    :+: (L y :: Integer
y :-: v :: 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)
     w :: CoreExpr
w    :+: (v :: CoreExpr
v :-: L y :: 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 y :: Integer
y :-: v :: CoreExpr
v) :+: w :: 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)
     (v :: CoreExpr
v :-: L y :: Integer
y) :+: w :: 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

     _                             -> 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 op :: PrimOp
op = Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
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 e :: CoreExpr
e = case CoreExpr
e of
   L l :: Integer
l :+: x :: CoreExpr
x   -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   x :: CoreExpr
x   :+: L l :: Integer
l -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   _           -> 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 e :: CoreExpr
e = case CoreExpr
e of
   L l :: Integer
l :*: x :: CoreExpr
x   -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   x :: CoreExpr
x   :*: L l :: Integer
l -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   _           -> 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 IntSubOp  = Bool
True
isSubOp WordSubOp = Bool
True
isSubOp _         = Bool
False

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

isMulOp :: PrimOp -> Bool
isMulOp :: PrimOp -> Bool
isMulOp IntMulOp  = Bool
True
isMulOp WordMulOp = Bool
True
isMulOp _         = 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 dflags :: DynFlags
dflags = PrimOps :: (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (Integer -> CoreExpr)
-> PrimOps
PrimOps
   { add :: CoreExpr -> CoreExpr -> CoreExpr
add = \x :: CoreExpr
x y :: CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntAddOp CoreExpr
y
   , sub :: CoreExpr -> CoreExpr -> CoreExpr
sub = \x :: CoreExpr
x y :: CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntSubOp CoreExpr
y
   , mul :: CoreExpr -> CoreExpr -> CoreExpr
mul = \x :: CoreExpr
x y :: 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 dflags :: DynFlags
dflags = PrimOps :: (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (Integer -> CoreExpr)
-> PrimOps
PrimOps
   { add :: CoreExpr -> CoreExpr -> CoreExpr
add = \x :: CoreExpr
x y :: CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
WordAddOp CoreExpr
y
   , sub :: CoreExpr -> CoreExpr -> CoreExpr
sub = \x :: CoreExpr
x y :: CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
WordSubOp CoreExpr
y
   , mul :: CoreExpr -> CoreExpr -> CoreExpr
mul = \x :: CoreExpr
x y :: 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, Id -> CoreExpr)
caseRules dflags :: DynFlags
dflags (App (App (Var f :: Id
f) v :: CoreExpr
v) (Lit l :: Literal
l))   -- v `op` x#
  | Just op :: PrimOp
op <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
  , Just x :: Integer
x  <- Literal -> Maybe Integer
isLitValue_maybe Literal
l
  , Just adjust_lit :: Integer -> Integer
adjust_lit <- PrimOp -> Integer -> Maybe (Integer -> Integer)
adjustDyadicRight PrimOp
op Integer
x
  = (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con DynFlags
dflags Integer -> Integer
adjust_lit
           , \v :: Id
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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v)) (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
l)))

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


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

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

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

caseRules _ _ = Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> 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 _      _      DEFAULT    = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just AltCon
DEFAULT
tx_lit_con dflags :: DynFlags
dflags adjust :: Integer -> Integer
adjust (LitAlt l :: 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 _      _      alt :: AltCon
alt        = String -> SDoc -> Maybe AltCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 op :: PrimOp
op lit :: Integer
lit
  = case PrimOp
op of
         WordAddOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         IntAddOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         WordSubOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
lit      )
         IntSubOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
lit      )
         XorOp     -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         XorIOp    -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         _         -> 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 lit :: Integer
lit op :: PrimOp
op
  = case PrimOp
op of
         WordAddOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         IntAddOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
lit      )
         WordSubOp -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
litInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y      )
         IntSubOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
litInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y      )
         XorOp     -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         XorIOp    -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer
y Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
lit)
         _         -> 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 op :: PrimOp
op
  = case PrimOp
op of
         NotOp     -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer -> Integer
forall a. Bits a => a -> a
complement Integer
y)
         NotIOp    -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer -> Integer
forall a. Bits a => a -> a
complement Integer
y)
         IntNegOp  -> (Integer -> Integer) -> Maybe (Integer -> Integer)
forall a. a -> Maybe a
Just (\y :: Integer
y -> Integer -> Integer
forall a. Num a => a -> a
negate Integer
y    )
         _         -> 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 _      DEFAULT         = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just AltCon
DEFAULT
tx_con_tte _      alt :: AltCon
alt@(LitAlt {}) = String -> SDoc -> Maybe AltCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic "caseRules" (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
alt)
tx_con_tte dflags :: DynFlags
dflags (DataAlt dc :: 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 _  DEFAULT = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just AltCon
DEFAULT
tx_con_dtt ty :: Type
ty (LitAlt (LitNumber LitNumInt i :: Integer
i _))
   | Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 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 _ alt :: AltCon
alt = String -> SDoc -> Maybe AltCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 (Trac #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 Trac #15436.
-}