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

\section[ConFold]{Constant Folder}

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

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

{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,
    DeriveFunctor, LambdaCase, TypeApplications, MultiWayIf #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}

module GHC.Core.Opt.ConstantFold
   ( primOpRules
   , builtinRules
   , caseRules
   , EnableBignumRules (..)
   )
where

#include "HsVersions.h"

import GHC.Prelude

import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId, voidPrimId )

import GHC.Core
import GHC.Core.Make
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Core.SimpleOpt ( exprIsLiteral_maybe )
import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Core.TyCon
   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons
   , tyConFamilySize )
import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
import GHC.Core.Utils  ( eqExpr, cheapEqExpr, exprIsHNF, exprType
                       , stripTicksTop, stripTicksTopT, mkTicks, stripTicksE )
import GHC.Core.Unfold ( exprIsConApp_maybe )
import GHC.Core.Multiplicity
import GHC.Core.FVs
import GHC.Core.Type
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Name.Occurrence ( occNameFS )
import GHC.Builtin.Names
import GHC.Data.Maybe      ( orElse )
import GHC.Types.Name ( Name, nameOccName )
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Basic
import GHC.Platform
import GHC.Utils.Misc
import GHC.Core.Coercion   (mkUnbranchedAxInstCo,mkSymCo,Role(..))

import Control.Applicative ( Alternative(..) )

import Control.Monad
import Data.Bits as Bits
import qualified Data.ByteString as BS
import Data.Int
import Data.Ratio
import Data.Word
import Data.Maybe (fromMaybe)

{-
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
primOpRules :: Name -> PrimOp -> Maybe CoreRule
primOpRules Name
nm = \case
   PrimOp
TagToEnumOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ RuleM CoreExpr
tagToEnumRule ]
   PrimOp
DataToTagOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ RuleM CoreExpr
dataToTagRule ]

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

   -- Word operations
   PrimOp
WordAddOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform Platform -> Literal
zerow
                                    , PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
WordAddOp Platform -> PrimOps
wordPrimOps
                                    ]
   PrimOp
WordSubOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 (-))
                                    , (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
zerow
                                    , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow
                                    , PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
WordSubOp Platform -> PrimOps
wordPrimOps
                                    ]
   PrimOp
WordAddCOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityCPlatform Platform -> Literal
zerow ]
   PrimOp
WordSubCOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 (-))
                                    , (Platform -> Literal) -> RuleM CoreExpr
rightIdentityCPlatform Platform -> Literal
zerow
                                    , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLitNoC Platform -> Literal
zerow ]
   PrimOp
WordMulOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform Platform -> Literal
onew
                                    , PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
WordMulOp Platform -> PrimOps
wordPrimOps
                                    ]
   PrimOp
WordQuotOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
onew ]
   PrimOp
WordRemOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , (Platform -> Literal) -> RuleM CoreExpr
leftZero Platform -> Literal
zerow
                                    , do Literal
l <- ConTagZ -> RuleM Literal
getLiteral ConTagZ
1
                                         Platform
platform <- RuleM Platform
getPlatform
                                         Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Literal
onew Platform
platform)
                                         (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow
                                    , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow ]
   PrimOp
AndOp       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.))
                                    , RuleM CoreExpr
idempotent
                                    , (Platform -> Literal) -> RuleM CoreExpr
zeroElem Platform -> Literal
zerow ]
   PrimOp
OrOp        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.))
                                    , RuleM CoreExpr
idempotent
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform Platform -> Literal
zerow ]
   PrimOp
XorOp       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor)
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform Platform -> Literal
zerow
                                    , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow ]
   PrimOp
NotOp       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit RuleOpts -> Literal -> Maybe CoreExpr
complementOp
                                    , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
NotOp ]
   PrimOp
SllOp       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
Bits.shiftL) ]
   PrimOp
SrlOp       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord Platform -> Integer -> ConTagZ -> Integer
shiftRightLogical ]

   -- coercions
   PrimOp
Word2IntOp     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
word2IntLit
                                       , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
Int2WordOp ]
   PrimOp
Int2WordOp     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
int2WordLit
                                       , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
Word2IntOp ]
   PrimOp
Narrow8IntOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
AndIOp PrimOp
Narrow8IntOp ConTagZ
8 ]
   PrimOp
Narrow16IntOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
AndIOp PrimOp
Narrow16IntOp ConTagZ
16 ]
   PrimOp
Narrow32IntOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
AndIOp PrimOp
Narrow32IntOp ConTagZ
32 ]
   PrimOp
Narrow8WordOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
AndOp PrimOp
Narrow8WordOp ConTagZ
8 ]
   PrimOp
Narrow16WordOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
AndOp PrimOp
Narrow16WordOp ConTagZ
16 ]
   PrimOp
Narrow32WordOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
AndOp PrimOp
Narrow32WordOp ConTagZ
32 ]
   PrimOp
OrdOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
char2IntLit
                                       , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
ChrOp ]
   PrimOp
ChrOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ do [Lit Literal
lit] <- RuleM [CoreExpr]
getArgs
                                            Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal -> Bool
litFitsInChar Literal
lit)
                                            (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2CharLit
                                       , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
OrdOp ]
   PrimOp
Float2IntOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
float2IntLit ]
   PrimOp
Int2FloatOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2FloatLit ]
   PrimOp
Double2IntOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
double2IntLit ]
   PrimOp
Int2DoubleOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
int2DoubleLit ]
   -- SUP: Not sure what the standard says about precision in the following 2 cases
   PrimOp
Float2DoubleOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
float2DoubleLit ]
   PrimOp
Double2FloatOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
double2FloatLit ]

   -- Float
   PrimOp
FloatAddOp        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
floatOp2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(+))
                                          , Literal -> RuleM CoreExpr
identity Literal
zerof ]
   PrimOp
FloatSubOp        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
floatOp2 (-))
                                          , Literal -> RuleM CoreExpr
rightIdentity Literal
zerof ]
   PrimOp
FloatMulOp        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> 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
   PrimOp
FloatDivOp        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ RuleM ()
guardFloatDiv RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
floatOp2 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
(/))
                                          , Literal -> RuleM CoreExpr
rightIdentity Literal
onef ]
   PrimOp
FloatNegOp        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit RuleOpts -> Literal -> Maybe CoreExpr
negOp
                                          , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
FloatNegOp ]
   PrimOp
FloatDecode_IntOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit RuleOpts -> Literal -> Maybe CoreExpr
floatDecodeOp ]

   -- Double
   PrimOp
DoubleAddOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(+))
                                             , Literal -> RuleM CoreExpr
identity Literal
zerod ]
   PrimOp
DoubleSubOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 (-))
                                             , Literal -> RuleM CoreExpr
rightIdentity Literal
zerod ]
   PrimOp
DoubleMulOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> 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
   PrimOp
DoubleDivOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ RuleM ()
guardDoubleDiv RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Rational -> Rational -> Rational)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
doubleOp2 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
(/))
                                             , Literal -> RuleM CoreExpr
rightIdentity Literal
oned ]
   PrimOp
DoubleNegOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit RuleOpts -> Literal -> Maybe CoreExpr
negOp
                                             , PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
DoubleNegOp ]
   PrimOp
DoubleDecode_Int64Op -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit RuleOpts -> Literal -> Maybe CoreExpr
doubleDecodeOp ]

   -- Relational operators

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

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

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

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

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

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

   PrimOp
AddrAddOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
zeroi ]

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

   PrimOp
_          -> Maybe CoreRule
forall a. Maybe a
Nothing

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

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

mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
            -> [RuleM CoreExpr] -> Maybe CoreRule
mkRelOpRule :: Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
cmp [RuleM CoreExpr]
extra
  = Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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
                    ; Platform
platform <- RuleM Platform
getPlatform
                    ; 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 Platform -> CoreExpr
trueValInt  Platform
platform
                              else Platform -> CoreExpr
falseValInt Platform
platform) }

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

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

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

mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
                    -> Maybe CoreRule
-- See Note [Rules for floating-point comparisons]
mkFloatingRelOpRule :: Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm forall a. Ord a => a -> a -> Bool
cmp
  = Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
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 :: Platform -> Literal
zeroi :: Platform -> Literal
zeroi Platform
platform = Platform -> Integer -> Literal
mkLitInt  Platform
platform Integer
0
onei :: Platform -> Literal
onei  Platform
platform = Platform -> Integer -> Literal
mkLitInt  Platform
platform Integer
1
zerow :: Platform -> Literal
zerow Platform
platform = Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
0
onew :: Platform -> Literal
onew  Platform
platform = Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
1

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

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

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

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

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

complementOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Binary complement
complementOp :: RuleOpts -> Literal -> Maybe CoreExpr
complementOp RuleOpts
env (LitNumber LitNumType
nt Integer
i) =
   CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> LitNumType -> Integer -> Literal
mkLitNumberWrap (RuleOpts -> Platform
roPlatform RuleOpts
env) LitNumType
nt (Integer -> Integer
forall a. Bits a => a -> a
complement Integer
i)))
complementOp RuleOpts
_      Literal
_            = Maybe CoreExpr
forall a. Maybe a
Nothing

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

intOp2' :: (Integral a, Integral b)
        => (RuleOpts -> a -> b -> Integer)
        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
intOp2' :: forall a b.
(Integral a, Integral b) =>
(RuleOpts -> a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
intOp2' RuleOpts -> a -> b -> Integer
op RuleOpts
env (LitNumber LitNumType
LitNumInt Integer
i1) (LitNumber LitNumType
LitNumInt Integer
i2) =
  let o :: a -> b -> Integer
o = RuleOpts -> a -> b -> Integer
op RuleOpts
env
  in  Platform -> Integer -> Maybe CoreExpr
intResult (RuleOpts -> Platform
roPlatform RuleOpts
env) (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' RuleOpts -> a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

intOpC2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
intOpC2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
intOpC2 a -> b -> Integer
op RuleOpts
env (LitNumber LitNumType
LitNumInt Integer
i1) (LitNumber LitNumType
LitNumInt Integer
i2) = do
  Platform -> Integer -> Maybe CoreExpr
intCResult (RuleOpts -> Platform
roPlatform RuleOpts
env) (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i1 a -> b -> Integer
`op` Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
i2)
intOpC2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

shiftRightLogical :: Platform -> 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 :: Platform -> Integer -> ConTagZ -> Integer
shiftRightLogical Platform
platform Integer
x ConTagZ
n =
    case Platform -> PlatformWordSize
platformWordSize Platform
platform of
      PlatformWordSize
PW4 -> Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
x Word32 -> ConTagZ -> Word32
forall a. Bits a => a -> ConTagZ -> a
`shiftR` ConTagZ
n :: Word32)
      PlatformWordSize
PW8 -> Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
x Word64 -> ConTagZ -> Word64
forall a. Bits a => a -> ConTagZ -> a
`shiftR` ConTagZ
n :: Word64)

--------------------------
retLit :: (Platform -> Literal) -> RuleM CoreExpr
retLit :: (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
l = do Platform
platform <- RuleM Platform
getPlatform
              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
$ Platform -> Literal
l Platform
platform

retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr
retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr
retLitNoC Platform -> Literal
l = do Platform
platform <- RuleM Platform
getPlatform
                 let lit :: Literal
lit = Platform -> Literal
l Platform
platform
                 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 (Platform -> Literal
zeroi Platform
platform)]

wordOp2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOp2 a -> b -> Integer
op RuleOpts
env (LitNumber LitNumType
LitNumWord Integer
w1) (LitNumber LitNumType
LitNumWord Integer
w2)
    = Platform -> Integer -> Maybe CoreExpr
wordResult (RuleOpts -> Platform
roPlatform RuleOpts
env) (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
w1 a -> b -> Integer
`op` Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
w2)
wordOp2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

wordOpC2 :: (Integral a, Integral b)
        => (a -> b -> Integer)
        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 a -> b -> Integer
op RuleOpts
env (LitNumber LitNumType
LitNumWord Integer
w1) (LitNumber LitNumType
LitNumWord Integer
w2) =
  Platform -> Integer -> Maybe CoreExpr
wordCResult (RuleOpts -> Platform
roPlatform RuleOpts
env) (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
w1 a -> b -> Integer
`op` Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
w2)
wordOpC2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

shiftRule :: LitNumType  -- Type of the result, either LitNumInt or LitNumWord
          -> (Platform -> Integer -> Int -> Integer)
          -> RuleM CoreExpr
-- Shifts take an Int; hence third arg of op is Int
-- Used for shift primops
--    ISllOp, ISraOp, ISrlOp :: Int#  -> Int#  -> Int#
--    SllOp, SrlOp           :: Word# -> Int# -> Word#
shiftRule :: LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
lit_num_ty Platform -> Integer -> ConTagZ -> Integer
shift_op
  = do { Platform
platform <- RuleM Platform
getPlatform
       ; [CoreExpr
e1, Lit (LitNumber LitNumType
LitNumInt Integer
shift_len)] <- RuleM [CoreExpr]
getArgs
       ; case CoreExpr
e1 of
           CoreExpr
_ | Integer
shift_len Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
             -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e1
             -- See Note [Guarding against silly shifts]
             | Integer
shift_len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
shift_len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> ConTagZ -> Integer
forall a. Integral a => a -> Integer
toInteger (Platform -> ConTagZ
platformWordSizeInBits Platform
platform)
             -> 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
$ Platform -> LitNumType -> Integer -> Literal
mkLitNumberWrap Platform
platform LitNumType
lit_num_ty Integer
0
                -- Be sure to use lit_num_ty here, so we get a correctly typed zero
                -- of type Int# or Word# resp.  See #18589

           -- Do the shift at type Integer, but shift length is Int
           Lit (LitNumber LitNumType
nt Integer
x)
             | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
shift_len
             , Integer
shift_len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= ConTagZ -> Integer
forall a. Integral a => a -> Integer
toInteger (Platform -> ConTagZ
platformWordSizeInBits Platform
platform)
             -> let op :: Integer -> ConTagZ -> Integer
op = Platform -> Integer -> ConTagZ -> Integer
shift_op Platform
platform
                    y :: Integer
y  = Integer
x Integer -> ConTagZ -> Integer
`op` Integer -> ConTagZ
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 (Platform -> LitNumType -> Integer -> Literal
mkLitNumberWrap Platform
platform LitNumType
nt Integer
y))

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

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

--------------------------
floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
floatDecodeOp RuleOpts
env (LitFloat ((Float -> (Integer, ConTagZ)
forall a. RealFloat a => a -> (Integer, ConTagZ)
decodeFloat (Float -> (Integer, ConTagZ))
-> (Rational -> Float) -> Rational -> (Integer, ConTagZ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational @Float) -> (Integer
m, ConTagZ
e)))
  = 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
intPrimTy, Type
intPrimTy]
                        [ Platform -> Integer -> CoreExpr
mkIntVal (RuleOpts -> Platform
roPlatform RuleOpts
env) (Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
m)
                        , Platform -> Integer -> CoreExpr
mkIntVal (RuleOpts -> Platform
roPlatform RuleOpts
env) (ConTagZ -> Integer
forall a. Integral a => a -> Integer
toInteger ConTagZ
e) ]
floatDecodeOp RuleOpts
_   Literal
_
  = Maybe CoreExpr
forall a. Maybe a
Nothing

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

--------------------------
doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
doubleDecodeOp RuleOpts
env (LitDouble ((Double -> (Integer, ConTagZ)
forall a. RealFloat a => a -> (Integer, ConTagZ)
decodeFloat (Double -> (Integer, ConTagZ))
-> (Rational -> Double) -> Rational -> (Integer, ConTagZ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational @Double) -> (Integer
m, ConTagZ
e)))
  = 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
iNT64Ty, Type
intPrimTy]
                        [ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitINT64 (RuleOpts -> Platform
roPlatform RuleOpts
env) (Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
m))
                        , Platform -> Integer -> CoreExpr
mkIntVal Platform
platform (ConTagZ -> Integer
forall a. Integral a => a -> Integer
toInteger ConTagZ
e) ]
  where
    platform :: Platform
platform = RuleOpts -> Platform
roPlatform RuleOpts
env
    (Type
iNT64Ty, Platform -> Integer -> Literal
mkLitINT64)
      | Platform -> ConTagZ
platformWordSizeInBits Platform
platform ConTagZ -> ConTagZ -> Bool
forall a. Ord a => a -> a -> Bool
< ConTagZ
64
      = (Type
int64PrimTy, Platform -> Integer -> Literal
mkLitInt64Wrap)
      | Bool
otherwise
      = (Type
intPrimTy  , Platform -> Integer -> Literal
mkLitIntWrap)
doubleDecodeOp RuleOpts
_   Literal
_
  = Maybe CoreExpr
forall a. Maybe a
Nothing

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

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

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

litEq :: Bool  -- True <=> equality, False <=> inequality
      -> RuleM CoreExpr
litEq :: Bool -> RuleM CoreExpr
litEq Bool
is_eq = [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
  [ do [Lit Literal
lit, CoreExpr
expr] <- RuleM [CoreExpr]
getArgs
       Platform
platform <- RuleM Platform
getPlatform
       Platform -> Literal -> CoreExpr -> RuleM CoreExpr
forall {m :: * -> *}.
(Monad m, Alternative m) =>
Platform -> Literal -> CoreExpr -> m CoreExpr
do_lit_eq Platform
platform Literal
lit CoreExpr
expr
  , do [CoreExpr
expr, Lit Literal
lit] <- RuleM [CoreExpr]
getArgs
       Platform
platform <- RuleM Platform
getPlatform
       Platform -> Literal -> CoreExpr -> RuleM CoreExpr
forall {m :: * -> *}.
(Monad m, Alternative m) =>
Platform -> Literal -> CoreExpr -> m CoreExpr
do_lit_eq Platform
platform Literal
lit CoreExpr
expr ]
  where
    do_lit_eq :: Platform -> Literal -> CoreExpr -> m CoreExpr
do_lit_eq Platform
platform Literal
lit CoreExpr
expr = do
      Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Literal -> Bool
litIsLifted Literal
lit))
      CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
expr (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted (Type -> Scaled Type) -> Type -> Scaled Type
forall a b. (a -> b) -> a -> b
$ 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     = Platform -> CoreExpr
trueValInt  Platform
platform
                   | Bool
otherwise = Platform -> CoreExpr
falseValInt Platform
platform
        val_if_neq :: CoreExpr
val_if_neq | Bool
is_eq     = Platform -> CoreExpr
falseValInt Platform
platform
                   | Bool
otherwise = Platform -> CoreExpr
trueValInt  Platform
platform


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

data Comparison = Gt | Ge | Lt | Le

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

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

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

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

intResult' :: Platform -> Integer -> CoreExpr
intResult' :: Platform -> Integer -> CoreExpr
intResult' Platform
platform Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitIntWrap Platform
platform 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 :: Platform -> Integer -> Maybe CoreExpr
intCResult :: Platform -> Integer -> Maybe CoreExpr
intCResult Platform
platform Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([CoreExpr] -> CoreExpr
mkPair [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
c])
  where
    mkPair :: [CoreExpr] -> CoreExpr
mkPair = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type
intPrimTy, Type
intPrimTy]
    (Literal
lit, Bool
b) = Platform -> Integer -> (Literal, Bool)
mkLitIntWrapC Platform
platform Integer
result
    c :: Literal
c = if Bool
b then Platform -> Literal
onei Platform
platform else Platform -> Literal
zeroi Platform
platform

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

wordResult' :: Platform -> Integer -> CoreExpr
wordResult' :: Platform -> Integer -> CoreExpr
wordResult' Platform
platform Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWordWrap Platform
platform 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 :: Platform -> Integer -> Maybe CoreExpr
wordCResult :: Platform -> Integer -> Maybe CoreExpr
wordCResult Platform
platform Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([CoreExpr] -> CoreExpr
mkPair [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
c])
  where
    mkPair :: [CoreExpr] -> CoreExpr
mkPair = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type
wordPrimTy, Type
intPrimTy]
    (Literal
lit, Bool
b) = Platform -> Integer -> (Literal, Bool)
mkLitWordWrapC Platform
platform Integer
result
    c :: Literal
c = if Bool
b then Platform -> Literal
onei Platform
platform else Platform -> Literal
zeroi Platform
platform

inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp PrimOp
primop = do
  [Var Id
primop_id `App` 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
PrimOp
this subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
that = do
  [Var Id
primop_id `App` 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 = do
  [e :: CoreExpr
e@(Var Id
primop_id `App` CoreExpr
_)] <- 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

-- | narrow subsumes bitwise `and` with full mask (cf #16402):
--
--       narrowN (x .&. m)
--       m .&. (2^N-1) = 2^N-1
--       ==> narrowN x
--
-- e.g.  narrow16 (x .&. 0xFFFF)
--       ==> narrow16 x
--
narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr
narrowSubsumesAnd :: PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
and_primop PrimOp
narrw ConTagZ
n = do
  [Var Id
primop_id `App` CoreExpr
x `App` CoreExpr
y] <- RuleM [CoreExpr]
getArgs
  PrimOp -> Id -> RuleM ()
matchPrimOpId PrimOp
and_primop Id
primop_id
  let mask :: Integer
mask = ConTagZ -> Integer
forall a. Bits a => ConTagZ -> a
bit ConTagZ
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1
      g :: Arg b -> Expr b -> m (Arg b)
g Arg b
v (Lit (LitNumber LitNumType
_ Integer
m)) = do
         Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
m Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
mask Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
mask)
         Arg b -> m (Arg b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Arg b
forall b. Id -> Expr b
Var (PrimOp -> Id
mkPrimOpId PrimOp
narrw) Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
`App` Arg b
v)
      g Arg b
_ Expr b
_ = m (Arg b)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  CoreExpr -> CoreExpr -> RuleM CoreExpr
forall {m :: * -> *} {b} {b}.
MonadPlus m =>
Arg b -> Expr b -> m (Arg b)
g CoreExpr
x CoreExpr
y RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> CoreExpr -> RuleM CoreExpr
forall {m :: * -> *} {b} {b}.
MonadPlus m =>
Arg b -> Expr b -> m (Arg b)
g CoreExpr
y CoreExpr
x

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

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

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

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

Note the massive shift on line "!!!!".  It can't happen, because we've checked
that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!
Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
can't constant fold it, but if it gets to the assembler 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 [Core let/app invariant] in GHC.Core) 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 Bignums (Integer, Natural): these are handled by bignum_shift.

  Here we could in principle shift by any amount, but we arbitrary
  limit the shift to 4 bits; in particular 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 -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
op_name ConTagZ
n_args RuleM CoreExpr
rm
  = BuiltinRule :: RuleName -> Name -> ConTagZ -> 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 :: ConTagZ
ru_nargs = ConTagZ
n_args,
                  ru_try :: RuleFun
ru_try   = RuleM CoreExpr -> RuleFun
forall r.
RuleM r -> RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r
runRuleM RuleM CoreExpr
rm }

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

instance Applicative RuleM where
    pure :: forall a. a -> RuleM a
pure a
x = (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe a) -> RuleM a
forall r.
(RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe a)
 -> RuleM a)
-> (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe a)
-> RuleM a
forall a b. (a -> b) -> a -> b
$ \RuleOpts
_ InScopeEnv
_ Id
_ [CoreExpr]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    <*> :: forall a b. 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 RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe a
f >>= :: forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
>>= a -> RuleM b
g
    = (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe b) -> RuleM b
forall r.
(RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe b)
 -> RuleM b)
-> (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe b)
-> RuleM b
forall a b. (a -> b) -> a -> b
$ \RuleOpts
env InScopeEnv
iu Id
fn [CoreExpr]
args ->
              case RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe a
f RuleOpts
env InScopeEnv
iu Id
fn [CoreExpr]
args of
                Maybe a
Nothing -> Maybe b
forall a. Maybe a
Nothing
                Just a
r  -> RuleM b -> RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe b
forall r.
RuleM r -> RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r
runRuleM (a -> RuleM b
g a
r) RuleOpts
env InScopeEnv
iu Id
fn [CoreExpr]
args

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

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

instance MonadPlus RuleM

getPlatform :: RuleM Platform
getPlatform :: RuleM Platform
getPlatform = RuleOpts -> Platform
roPlatform (RuleOpts -> Platform) -> RuleM RuleOpts -> RuleM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RuleM RuleOpts
getEnv

getEnv :: RuleM RuleOpts
getEnv :: RuleM RuleOpts
getEnv = (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe RuleOpts)
-> RuleM RuleOpts
forall r.
(RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe RuleOpts)
 -> RuleM RuleOpts)
-> (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe RuleOpts)
-> RuleM RuleOpts
forall a b. (a -> b) -> a -> b
$ \RuleOpts
env InScopeEnv
_ Id
_ [CoreExpr]
_ -> RuleOpts -> Maybe RuleOpts
forall a. a -> Maybe a
Just RuleOpts
env

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

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

liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
f = do
  Platform
platform <- RuleM Platform
getPlatform
  [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 (Platform -> Literal -> Literal
f Platform
platform Literal
lit)

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

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

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

getFunction :: RuleM Id
getFunction :: RuleM Id
getFunction = (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe Id)
-> RuleM Id
forall r.
(RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r) -> RuleM r
RuleM ((RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe Id)
 -> RuleM Id)
-> (RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe Id)
-> RuleM Id
forall a b. (a -> b) -> a -> b
$ \RuleOpts
_ InScopeEnv
_ Id
fn [CoreExpr]
_ -> Id -> Maybe Id
forall a. a -> Maybe a
Just Id
fn

isLiteral :: CoreExpr -> RuleM Literal
isLiteral :: CoreExpr -> RuleM Literal
isLiteral CoreExpr
e = do
    InScopeEnv
env <- RuleM InScopeEnv
getInScopeEnv
    case InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
e of
        Maybe Literal
Nothing -> RuleM Literal
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Literal
l  -> Literal -> RuleM Literal
forall (f :: * -> *) a. Applicative f => a -> f a
pure Literal
l

isNumberLiteral :: CoreExpr -> RuleM Integer
isNumberLiteral :: CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
e = CoreExpr -> RuleM Literal
isLiteral CoreExpr
e RuleM Literal -> (Literal -> RuleM Integer) -> RuleM Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  LitNumber LitNumType
_ Integer
x -> Integer -> RuleM Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  Literal
_             -> RuleM Integer
forall (m :: * -> *) a. MonadPlus m => m a
mzero

isIntegerLiteral :: CoreExpr -> RuleM Integer
isIntegerLiteral :: CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
e = CoreExpr -> RuleM Literal
isLiteral CoreExpr
e RuleM Literal -> (Literal -> RuleM Integer) -> RuleM Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  LitNumber LitNumType
LitNumInteger Integer
x -> Integer -> RuleM Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  Literal
_                         -> RuleM Integer
forall (m :: * -> *) a. MonadPlus m => m a
mzero

isNaturalLiteral :: CoreExpr -> RuleM Integer
isNaturalLiteral :: CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
e = CoreExpr -> RuleM Literal
isLiteral CoreExpr
e RuleM Literal -> (Literal -> RuleM Integer) -> RuleM Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  LitNumber LitNumType
LitNumNatural Integer
x -> Integer -> RuleM Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  Literal
_                         -> RuleM Integer
forall (m :: * -> *) a. MonadPlus m => m a
mzero

isWordLiteral :: CoreExpr -> RuleM Integer
isWordLiteral :: CoreExpr -> RuleM Integer
isWordLiteral CoreExpr
e = CoreExpr -> RuleM Literal
isLiteral CoreExpr
e RuleM Literal -> (Literal -> RuleM Integer) -> RuleM Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  LitNumber LitNumType
LitNumWord Integer
x -> Integer -> RuleM Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  Literal
_                      -> RuleM Integer
forall (m :: * -> *) a. MonadPlus m => m a
mzero

isIntLiteral :: CoreExpr -> RuleM Integer
isIntLiteral :: CoreExpr -> RuleM Integer
isIntLiteral CoreExpr
e = CoreExpr -> RuleM Literal
isLiteral CoreExpr
e RuleM Literal -> (Literal -> RuleM Integer) -> RuleM Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  LitNumber LitNumType
LitNumInt Integer
x -> Integer -> RuleM Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  Literal
_                     -> RuleM Integer
forall (m :: * -> *) a. MonadPlus m => m a
mzero

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

unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit RuleOpts -> Literal -> Maybe CoreExpr
op = do
  RuleOpts
env <- RuleM RuleOpts
getEnv
  [Lit Literal
l] <- RuleM [CoreExpr]
getArgs
  Maybe CoreExpr -> RuleM CoreExpr
forall a. Maybe a -> RuleM a
liftMaybe (Maybe CoreExpr -> RuleM CoreExpr)
-> Maybe CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ RuleOpts -> Literal -> Maybe CoreExpr
op RuleOpts
env (RuleOpts -> Literal -> Literal
convFloating RuleOpts
env Literal
l)

binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit RuleOpts -> Literal -> Literal -> Maybe CoreExpr
op = do
  RuleOpts
env <- RuleM RuleOpts
getEnv
  [Lit Literal
l1, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Maybe CoreExpr -> RuleM CoreExpr
forall a. Maybe a -> RuleM a
liftMaybe (Maybe CoreExpr -> RuleM CoreExpr)
-> Maybe CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ RuleOpts -> Literal -> Literal -> Maybe CoreExpr
op RuleOpts
env (RuleOpts -> Literal -> Literal
convFloating RuleOpts
env Literal
l1) (RuleOpts -> Literal -> Literal
convFloating RuleOpts
env Literal
l2)

binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit :: (forall a. Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit forall a. Ord a => a -> a -> Bool
op = do
  Platform
platform <- RuleM Platform
getPlatform
  (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit (\RuleOpts
_ -> Platform
-> (forall a. Ord a => a -> a -> Bool)
-> Literal
-> Literal
-> Maybe CoreExpr
cmpOp Platform
platform forall a. Ord a => a -> a -> Bool
op)

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

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

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

leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
leftIdentityPlatform Platform -> Literal
id_lit = do
  Platform
platform <- RuleM Platform
getPlatform
  [Lit Literal
l1, CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Literal
id_lit Platform
platform
  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 occurred.
leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
leftIdentityCPlatform Platform -> Literal
id_lit = do
  Platform
platform <- RuleM Platform
getPlatform
  [Lit Literal
l1, CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Literal
id_lit Platform
platform
  let no_c :: Expr b
no_c = Literal -> Expr b
forall b. Literal -> Expr b
Lit (Platform -> Literal
zeroi Platform
platform)
  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])

rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
id_lit = do
  Platform
platform <- RuleM Platform
getPlatform
  [CoreExpr
e1, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l2 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Literal
id_lit Platform
platform
  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 occurred.
rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr
rightIdentityCPlatform Platform -> Literal
id_lit = do
  Platform
platform <- RuleM Platform
getPlatform
  [CoreExpr
e1, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l2 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Literal
id_lit Platform
platform
  let no_c :: Expr b
no_c = Literal -> Expr b
forall b. Literal -> Expr b
Lit (Platform -> Literal
zeroi Platform
platform)
  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])

identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
identityPlatform Platform -> Literal
lit =
  (Platform -> Literal) -> RuleM CoreExpr
leftIdentityPlatform Platform -> Literal
lit RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
lit

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

leftZero :: (Platform -> Literal) -> RuleM CoreExpr
leftZero :: (Platform -> Literal) -> RuleM CoreExpr
leftZero Platform -> Literal
zero = do
  Platform
platform <- RuleM Platform
getPlatform
  [Lit Literal
l1, CoreExpr
_] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Literal
zero Platform
platform
  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 :: (Platform -> Literal) -> RuleM CoreExpr
rightZero :: (Platform -> Literal) -> RuleM CoreExpr
rightZero Platform -> Literal
zero = do
  Platform
platform <- RuleM Platform
getPlatform
  [CoreExpr
_, Lit Literal
l2] <- RuleM [CoreExpr]
getArgs
  Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ Literal
l2 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Literal
zero Platform
platform
  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 :: (Platform -> Literal) -> RuleM CoreExpr
zeroElem :: (Platform -> Literal) -> RuleM CoreExpr
zeroElem Platform -> Literal
lit = (Platform -> Literal) -> RuleM CoreExpr
leftZero Platform -> Literal
lit RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Platform -> Literal) -> RuleM CoreExpr
rightZero Platform -> Literal
lit

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

nonZeroLit :: Int -> RuleM ()
nonZeroLit :: ConTagZ -> RuleM ()
nonZeroLit ConTagZ
n = ConTagZ -> RuleM Literal
getLiteral ConTagZ
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 :: RuleOpts -> Literal -> Literal
convFloating :: RuleOpts -> Literal -> Literal
convFloating RuleOpts
env (LitFloat  Rational
f) | Bool -> Bool
not (RuleOpts -> Bool
roExcessRationalPrecision RuleOpts
env) =
   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 RuleOpts
env (LitDouble Rational
d) | Bool -> Bool
not (RuleOpts -> Bool
roExcessRationalPrecision RuleOpts
env) =
   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 RuleOpts
_ Literal
l = Literal
l

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

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

strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
strengthReduction Literal
two_lit PrimOp
add_op = do -- Note [Strength reduction]
  CoreExpr
arg <- [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ do [CoreExpr
arg, Lit Literal
mult_lit] <- RuleM [CoreExpr]
getArgs
                   Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal
mult_lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
two_lit)
                   CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
arg
              , do [Lit Literal
mult_lit, CoreExpr
arg] <- RuleM [CoreExpr]
getArgs
                   Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Literal
mult_lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
two_lit)
                   CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
arg ]
  CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ 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 :: Platform -> Expr CoreBndr
trueValInt :: Platform -> CoreExpr
trueValInt  Platform
platform = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Platform -> Literal
onei  Platform
platform -- see Note [What's true and false]
falseValInt :: Platform -> CoreExpr
falseValInt Platform
platform = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Platform -> Literal
zeroi Platform
platform

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 :: Platform -> Integer -> Expr CoreBndr
mkIntVal :: Platform -> Integer -> CoreExpr
mkIntVal Platform
platform Integer
i = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitInt Platform
platform Integer
i)
mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr
mkFloatVal :: RuleOpts -> Rational -> CoreExpr
mkFloatVal RuleOpts
env Rational
f = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (RuleOpts -> Literal -> Literal
convFloating RuleOpts
env (Rational -> Literal
LitFloat  Rational
f))
mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr
mkDoubleVal :: RuleOpts -> Rational -> CoreExpr
mkDoubleVal RuleOpts
env Rational
d = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (RuleOpts -> Literal -> Literal
convFloating RuleOpts
env (Rational -> Literal
LitDouble Rational
d))

matchPrimOpId :: PrimOp -> Id -> RuleM ()
matchPrimOpId :: PrimOp -> Id -> RuleM ()
matchPrimOpId PrimOp
op 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   tagToEnum# (T ty) 2# -->  B ty
tagToEnumRule :: RuleM CoreExpr
tagToEnumRule = do
  [Type Type
ty, Lit (LitNumber LitNumType
LitNumInt Integer
i)] <- RuleM [CoreExpr]
getArgs
  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
    Just (TyCon
tycon, [Type]
tc_args) | TyCon -> Bool
isEnumerationTyCon TyCon
tycon -> do
      let tag :: ConTagZ
tag = Integer -> ConTagZ
forall a. Num a => Integer -> a
fromInteger Integer
i
          correct_tag :: DataCon -> Bool
correct_tag DataCon
dc = (DataCon -> ConTagZ
dataConTagZ DataCon
dc) ConTagZ -> ConTagZ -> Bool
forall a. Eq a => a -> a -> Bool
== ConTagZ
tag
      (DataCon
dc:[DataCon]
rest) <- [DataCon] -> RuleM [DataCon]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> RuleM [DataCon]) -> [DataCon] -> RuleM [DataCon]
forall a b. (a -> b) -> a -> b
$ (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filter DataCon -> Bool
correct_tag (TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tycon Maybe [DataCon] -> [DataCon] -> [DataCon]
forall a. Maybe a -> a -> a
`orElse` [])
      ASSERT(null rest) return ()
      CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
dc)) [Type]
tc_args

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

------------------------------
dataToTagRule :: RuleM CoreExpr
-- See Note [dataToTag#] in primops.txt.pp
dataToTagRule :: RuleM CoreExpr
dataToTagRule = RuleM CoreExpr
a RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` RuleM CoreExpr
b
  where
    -- dataToTag (tagToEnum x)   ==>   x
    a :: RuleM CoreExpr
a = do
      [Type Type
ty1, Var Id
tag_to_enum `App` Type Type
ty2 `App` CoreExpr
tag] <- RuleM [CoreExpr]
getArgs
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> RuleM ()) -> Bool -> RuleM ()
forall a b. (a -> b) -> a -> b
$ 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
      Platform
dflags <- RuleM Platform
getPlatform
      [CoreExpr
_, CoreExpr
val_arg] <- RuleM [CoreExpr]
getArgs
      InScopeEnv
in_scope <- RuleM InScopeEnv
getInScopeEnv
      (InScopeSet
_,[FloatBind]
floats, DataCon
dc,[Type]
_,[CoreExpr]
_) <- Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-> RuleM (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a. Maybe a -> RuleM a
liftMaybe (Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
 -> RuleM (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-> RuleM (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$ InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
HasDebugCallStack =>
InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe InScopeEnv
in_scope CoreExpr
val_arg
      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
      CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats (Platform -> Integer -> CoreExpr
mkIntVal Platform
dflags (ConTagZ -> Integer
forall a. Integral a => a -> Integer
toInteger (DataCon -> ConTagZ
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:

* GHC.Core.Utils.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 GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]

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

* An application like (dataToTag# (Just x)) is optimised by
  dataToTagRule in GHC.Core.Opt.ConstantFold.

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

See #15696 for a long saga.
-}

{- *********************************************************************
*                                                                      *
             unsafeEqualityProof
*                                                                      *
********************************************************************* -}

-- unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)
-- That is, if the two types are equal, it's not unsafe!

unsafeEqualityProofRule :: RuleM CoreExpr
unsafeEqualityProofRule :: RuleM CoreExpr
unsafeEqualityProofRule
  = do { [Type Type
rep, Type Type
t1, Type Type
t2] <- RuleM [CoreExpr]
getArgs
       ; Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type
t1 Type -> Type -> Bool
`eqType` Type
t2)
       ; Id
fn <- RuleM Id
getFunction
       ; let ([Id]
_, Type
ue) = Type -> ([Id], Type)
splitForAllTys (Id -> Type
idType Id
fn)
             tc :: TyCon
tc      = Type -> TyCon
tyConAppTyCon Type
ue  -- tycon:    UnsafeEquality
             (DataCon
dc:[DataCon]
_)  = TyCon -> [DataCon]
tyConDataCons TyCon
tc  -- data con: UnsafeRefl
             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).
             --               UnsafeEquality r a a
       ; CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
dc)) [Type
rep, Type
t1]) }


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

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

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

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

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

Things to note

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

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

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

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

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

Implementing seq#.  The compiler has magic for SeqOp in

- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)

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

- GHC.Core.Utils.exprOkForSpeculation;
  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils

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

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

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

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

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

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

        ....and lower down...

        eqString = ...

Then a rewrite would give

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

and lo, eqString is not in scope.  This only really matters when we
get to code generation.  But the occurrence analyser does a GlomBinds
step when necessary, that does a new SCC analysis on the whole set of
bindings (see occurAnalysePgm), which sorts out the dependency, so all
is fine.
-}

newtype EnableBignumRules = EnableBignumRules Bool

builtinRules :: EnableBignumRules -> [CoreRule]
-- Rules for non-primops that can't be expressed using a RULE pragma
builtinRules :: EnableBignumRules -> [CoreRule]
builtinRules EnableBignumRules
enableBignumRules
  = [BuiltinRule :: RuleName -> Name -> ConTagZ -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"AppendLitString",
                   ru_fn :: Name
ru_fn = Name
unpackCStringFoldrName,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
4, ru_try :: RuleFun
ru_try = RuleFun
match_append_lit_C },
     BuiltinRule :: RuleName -> Name -> ConTagZ -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"AppendLitStringUtf8",
                   ru_fn :: Name
ru_fn = Name
unpackCStringFoldrUtf8Name,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
4, ru_try :: RuleFun
ru_try = RuleFun
match_append_lit_utf8 },
     BuiltinRule :: RuleName -> Name -> ConTagZ -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"EqString", ru_fn :: Name
ru_fn = Name
eqStringName,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
2, ru_try :: RuleFun
ru_try = RuleFun
match_eq_string },
     BuiltinRule :: RuleName -> Name -> ConTagZ -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"CStringLength", ru_fn :: Name
ru_fn = Name
cstringLengthName,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
1, ru_try :: RuleFun
ru_try = RuleFun
match_cstring_length },
     BuiltinRule :: RuleName -> Name -> ConTagZ -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"Inline", ru_fn :: Name
ru_fn = Name
inlineIdName,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
2, ru_try :: RuleFun
ru_try = \RuleOpts
_ InScopeEnv
_ Id
_ -> [CoreExpr] -> Maybe CoreExpr
match_inline },
     BuiltinRule :: RuleName -> Name -> ConTagZ -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"MagicDict", ru_fn :: Name
ru_fn = Id -> Name
idName Id
magicDictId,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
4, ru_try :: RuleFun
ru_try = \RuleOpts
_ InScopeEnv
_ Id
_ -> [CoreExpr] -> Maybe CoreExpr
match_magicDict },

     Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
unsafeEqualityProofName ConTagZ
3 RuleM CoreExpr
unsafeEqualityProofRule,

     Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
divIntName ConTagZ
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
        [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div)
        , (Platform -> Literal) -> RuleM CoreExpr
leftZero Platform -> Literal
zeroi
        , do
          [CoreExpr
arg, Lit (LitNumber LitNumType
LitNumInt Integer
d)] <- RuleM [CoreExpr]
getArgs
          Just Integer
n <- Maybe Integer -> RuleM (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> RuleM (Maybe Integer))
-> Maybe Integer -> RuleM (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
exactLog2 Integer
d
          Platform
platform <- RuleM Platform
getPlatform
          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` Platform -> Integer -> CoreExpr
mkIntVal Platform
platform Integer
n
        ],

     Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkBasicRule Name
modIntName ConTagZ
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
        [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (RuleOpts -> Literal -> Literal -> Maybe CoreExpr)
-> RuleM CoreExpr
binaryLit ((Integer -> Integer -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
intOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod)
        , (Platform -> Literal) -> RuleM CoreExpr
leftZero Platform -> Literal
zeroi
        , do
          [CoreExpr
arg, Lit (LitNumber LitNumType
LitNumInt Integer
d)] <- RuleM [CoreExpr]
getArgs
          Just Integer
_ <- Maybe Integer -> RuleM (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> RuleM (Maybe Integer))
-> Maybe Integer -> RuleM (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
exactLog2 Integer
d
          Platform
platform <- RuleM Platform
getPlatform
          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` Platform -> Integer -> CoreExpr
mkIntVal Platform
platform (Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
        ]
     ]
 [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ EnableBignumRules -> [CoreRule]
builtinBignumRules EnableBignumRules
enableBignumRules
{-# 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.

builtinBignumRules :: EnableBignumRules -> [CoreRule]
builtinBignumRules :: EnableBignumRules -> [CoreRule]
builtinBignumRules (EnableBignumRules Bool
False) = []
builtinBignumRules EnableBignumRules
_ =
  [ -- conversions
    String -> Name -> CoreRule
lit_to_integer String
"Word# -> Integer"   Name
integerFromWordName
  , String -> Name -> CoreRule
lit_to_integer String
"Int64# -> Integer"  Name
integerFromInt64Name
  , String -> Name -> CoreRule
lit_to_integer String
"Word64# -> Integer" Name
integerFromWord64Name
  , String -> Name -> CoreRule
lit_to_integer String
"Natural -> Integer" Name
integerFromNaturalName

  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
integer_to_lit String
"Integer -> Word# (wrap)"   Name
integerToWordName   Platform -> Integer -> CoreExpr
forall b. Platform -> Integer -> Expr b
mkWordLitWrap
  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
integer_to_lit String
"Integer -> Int# (wrap)"    Name
integerToIntName    Platform -> Integer -> CoreExpr
forall b. Platform -> Integer -> Expr b
mkIntLitWrap
  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
integer_to_lit String
"Integer -> Word64# (wrap)" Name
integerToWord64Name (\Platform
_ -> Word64 -> CoreExpr
forall b. Word64 -> Expr b
mkWord64LitWord64 (Word64 -> CoreExpr) -> (Integer -> Word64) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word64
forall a. Num a => Integer -> a
fromInteger)
  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
integer_to_lit String
"Integer -> Int64# (wrap)"  Name
integerToInt64Name  (\Platform
_ -> Int64 -> CoreExpr
forall b. Int64 -> Expr b
mkInt64LitInt64 (Int64 -> CoreExpr) -> (Integer -> Int64) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a. Num a => Integer -> a
fromInteger)
  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
integer_to_lit String
"Integer -> Float#"         Name
integerToFloatName  (\Platform
_ -> Float -> CoreExpr
forall b. Float -> Expr b
mkFloatLitFloat (Float -> CoreExpr) -> (Integer -> Float) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Float
forall a. Num a => Integer -> a
fromInteger)
  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
integer_to_lit String
"Integer -> Double#"        Name
integerToDoubleName (\Platform
_ -> Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble (Double -> CoreExpr) -> (Integer -> Double) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a. Num a => Integer -> a
fromInteger)

  , String -> Name -> Bool -> Bool -> CoreRule
integer_to_natural String
"Integer -> Natural (clamp)" Name
integerToNaturalClampName Bool
False Bool
True
  , String -> Name -> Bool -> Bool -> CoreRule
integer_to_natural String
"Integer -> Natural (wrap)"  Name
integerToNaturalName      Bool
False Bool
False
  , String -> Name -> Bool -> Bool -> CoreRule
integer_to_natural String
"Integer -> Natural (throw)" Name
integerToNaturalThrowName Bool
True Bool
False

  , String -> Name -> CoreRule
lit_to_natural  String
"Word# -> Natural"         Name
naturalNSName
  , String -> Name -> Bool -> CoreRule
natural_to_word String
"Natural -> Word# (wrap)"  Name
naturalToWordName      Bool
False
  , String -> Name -> Bool -> CoreRule
natural_to_word String
"Natural -> Word# (clamp)" Name
naturalToWordClampName Bool
True

    -- comparisons (return an unlifted Int#)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
integer_cmp String
"integerEq#" Name
integerEqName Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
integer_cmp String
"integerNe#" Name
integerNeName Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(/=)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
integer_cmp String
"integerLe#" Name
integerLeName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
integer_cmp String
"integerGt#" Name
integerGtName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
integer_cmp String
"integerLt#" Name
integerLtName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
integer_cmp String
"integerGe#" Name
integerGeName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=)

  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
natural_cmp String
"naturalEq#" Name
naturalEqName Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
natural_cmp String
"naturalNe#" Name
naturalNeName Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(/=)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
natural_cmp String
"naturalLe#" Name
naturalLeName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
natural_cmp String
"naturalGt#" Name
naturalGtName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
natural_cmp String
"naturalLt#" Name
naturalLtName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
natural_cmp String
"naturalGe#" Name
naturalGeName Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=)

    -- comparisons (return an Ordering)
  , String -> Name -> CoreRule
bignum_compare String
"integerCompare" Name
integerCompareName
  , String -> Name -> CoreRule
bignum_compare String
"naturalCompare" Name
naturalCompareName

    -- binary operations
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerAdd" Name
integerAddName Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerSub" Name
integerSubName (-)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerMul" Name
integerMulName Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerGcd" Name
integerGcdName Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerLcm" Name
integerLcmName Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
lcm
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerAnd" Name
integerAndName Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerOr"  Name
integerOrName  Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
"integerXor" Name
integerXorName Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor

  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
"naturalAdd" Name
naturalAddName Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
"naturalMul" Name
naturalMulName Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
"naturalGcd" Name
naturalGcdName Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
"naturalLcm" Name
naturalLcmName Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
lcm
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
"naturalAnd" Name
naturalAndName Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
"naturalOr"  Name
naturalOrName  Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.)
  , String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
"naturalXor" Name
naturalXorName Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor

    -- Natural subtraction: it's a binop but it can fail because of underflow so
    -- we have several primitives to handle here.
  , String -> Name -> CoreRule
natural_sub String
"naturalSubUnsafe" Name
naturalSubUnsafeName
  , String -> Name -> CoreRule
natural_sub String
"naturalSubThrow"  Name
naturalSubThrowName
  , String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
"naturalSub" Name
naturalSubName ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
        [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
        Integer
x <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a0
        Integer
y <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a1
        -- return an unboxed sum: (# (# #) | Natural #)
        let ret :: ConTagZ -> CoreExpr -> f CoreExpr
ret ConTagZ
n CoreExpr
v = CoreExpr -> f CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> f CoreExpr) -> CoreExpr -> f CoreExpr
forall a b. (a -> b) -> a -> b
$ ConTagZ -> ConTagZ -> [Type] -> CoreExpr -> CoreExpr
mkCoreUbxSum ConTagZ
2 ConTagZ
n [Type
voidPrimTy,Type
naturalTy] CoreExpr
v
        if Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
y
            then ConTagZ -> CoreExpr -> RuleM CoreExpr
forall {f :: * -> *}.
Applicative f =>
ConTagZ -> CoreExpr -> f CoreExpr
ret ConTagZ
1 (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
Var Id
voidPrimId
            else ConTagZ -> CoreExpr -> RuleM CoreExpr
forall {f :: * -> *}.
Applicative f =>
ConTagZ -> CoreExpr -> f CoreExpr
ret ConTagZ
2 (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitNatural (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y))

    -- unary operations
  , String
-> Name -> (Integer -> Literal) -> (Integer -> Integer) -> CoreRule
forall {t}.
String -> Name -> (t -> Literal) -> (Integer -> t) -> CoreRule
bignum_unop String
"integerNegate"     Name
integerNegateName     Integer -> Literal
mkLitInteger Integer -> Integer
forall a. Num a => a -> a
negate
  , String
-> Name -> (Integer -> Literal) -> (Integer -> Integer) -> CoreRule
forall {t}.
String -> Name -> (t -> Literal) -> (Integer -> t) -> CoreRule
bignum_unop String
"integerAbs"        Name
integerAbsName        Integer -> Literal
mkLitInteger Integer -> Integer
forall a. Num a => a -> a
abs
  , String
-> Name -> (Integer -> Literal) -> (Integer -> Integer) -> CoreRule
forall {t}.
String -> Name -> (t -> Literal) -> (Integer -> t) -> CoreRule
bignum_unop String
"integerSignum"     Name
integerSignumName     Integer -> Literal
mkLitInteger Integer -> Integer
forall a. Num a => a -> a
signum
  , String
-> Name -> (Integer -> Literal) -> (Integer -> Integer) -> CoreRule
forall {t}.
String -> Name -> (t -> Literal) -> (Integer -> t) -> CoreRule
bignum_unop String
"integerComplement" Name
integerComplementName Integer -> Literal
mkLitInteger Integer -> Integer
forall a. Bits a => a -> a
complement

  , String
-> Name -> (Integer -> Literal) -> (Integer -> Integer) -> CoreRule
forall {t}.
String -> Name -> (t -> Literal) -> (Integer -> t) -> CoreRule
bignum_unop String
"naturalSignum"     Name
naturalSignumName     Integer -> Literal
mkLitNatural Integer -> Integer
forall a. Num a => a -> a
signum

  , String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
"naturalNegate" Name
naturalNegateName ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
        [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
        Integer
x <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a0
        Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) -- negate is only valid for (0 :: Natural)
        CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
a0

  , String -> Name -> (Platform -> Integer -> Literal) -> CoreRule
forall {t}.
Num t =>
String -> Name -> (Platform -> t -> Literal) -> CoreRule
bignum_popcount String
"integerPopCount" Name
integerPopCountName Platform -> Integer -> Literal
mkLitIntWrap
  , String -> Name -> (Platform -> Integer -> Literal) -> CoreRule
forall {t}.
Num t =>
String -> Name -> (Platform -> t -> Literal) -> CoreRule
bignum_popcount String
"naturalPopCount" Name
naturalPopCountName Platform -> Integer -> Literal
mkLitWordWrap

    -- identity passthrough
  , String -> Name -> Name -> CoreRule
id_passthrough String
"Int# -> Integer -> Int#"       Name
integerToIntName    Name
integerISName
  , String -> Name -> Name -> CoreRule
id_passthrough String
"Word# -> Integer -> Word#"     Name
integerToWordName   Name
integerFromWordName
  , String -> Name -> Name -> CoreRule
id_passthrough String
"Int64# -> Integer -> Int64#"   Name
integerToInt64Name  Name
integerFromInt64Name
  , String -> Name -> Name -> CoreRule
id_passthrough String
"Word64# -> Integer -> Word64#" Name
integerToWord64Name Name
integerFromWord64Name
  , String -> Name -> Name -> CoreRule
id_passthrough String
"Word# -> Natural -> Word#"     Name
naturalToWordName   Name
naturalNSName

    -- identity passthrough with a conversion that can be done directly instead
  , String -> Name -> Name -> Id -> CoreRule
small_passthrough String
"Int# -> Integer -> Word#"
        Name
integerISName Name
integerToWordName   (PrimOp -> Id
mkPrimOpId PrimOp
Int2WordOp)
  , String -> Name -> Name -> Id -> CoreRule
small_passthrough String
"Int# -> Integer -> Float#"
        Name
integerISName Name
integerToFloatName  (PrimOp -> Id
mkPrimOpId PrimOp
Int2FloatOp)
  , String -> Name -> Name -> Id -> CoreRule
small_passthrough String
"Int# -> Integer -> Double#"
        Name
integerISName Name
integerToDoubleName (PrimOp -> Id
mkPrimOpId PrimOp
Int2DoubleOp)
  , String -> Name -> Name -> Id -> CoreRule
small_passthrough String
"Word# -> Natural -> Int#"
        Name
naturalNSName Name
naturalToWordName   (PrimOp -> Id
mkPrimOpId PrimOp
Word2IntOp)

    -- Bits.bit
  , String -> Name -> (Integer -> Literal) -> CoreRule
forall {t}. Bits t => String -> Name -> (t -> Literal) -> CoreRule
bignum_bit String
"integerBit" Name
integerBitName Integer -> Literal
mkLitInteger
  , String -> Name -> (Integer -> Literal) -> CoreRule
forall {t}. Bits t => String -> Name -> (t -> Literal) -> CoreRule
bignum_bit String
"naturalBit" Name
naturalBitName Integer -> Literal
mkLitNatural

    -- Bits.testBit
  , String -> Name -> CoreRule
bignum_testbit String
"integerTestBit" Name
integerTestBitName
  , String -> Name -> CoreRule
bignum_testbit String
"naturalTestBit" Name
naturalTestBitName

    -- Bits.shift
  , String
-> Name
-> (Integer -> ConTagZ -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t} {t}.
Num t =>
String -> Name -> (Integer -> t -> t) -> (t -> Literal) -> CoreRule
bignum_shift String
"integerShiftL" Name
integerShiftLName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL Integer -> Literal
mkLitInteger
  , String
-> Name
-> (Integer -> ConTagZ -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t} {t}.
Num t =>
String -> Name -> (Integer -> t -> t) -> (t -> Literal) -> CoreRule
bignum_shift String
"integerShiftR" Name
integerShiftRName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR Integer -> Literal
mkLitInteger
  , String
-> Name
-> (Integer -> ConTagZ -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t} {t}.
Num t =>
String -> Name -> (Integer -> t -> t) -> (t -> Literal) -> CoreRule
bignum_shift String
"naturalShiftL" Name
naturalShiftLName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL Integer -> Literal
mkLitNatural
  , String
-> Name
-> (Integer -> ConTagZ -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t} {t}.
Num t =>
String -> Name -> (Integer -> t -> t) -> (t -> Literal) -> CoreRule
bignum_shift String
"naturalShiftR" Name
naturalShiftRName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR Integer -> Literal
mkLitNatural

    -- division
  , String
-> Name
-> (Integer -> Integer -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t}.
String
-> Name -> (Integer -> Integer -> t) -> (t -> Literal) -> CoreRule
divop_one  String
"integerQuot"    Name
integerQuotName    Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot    Integer -> Literal
mkLitInteger
  , String
-> Name
-> (Integer -> Integer -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t}.
String
-> Name -> (Integer -> Integer -> t) -> (t -> Literal) -> CoreRule
divop_one  String
"integerRem"     Name
integerRemName     Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem     Integer -> Literal
mkLitInteger
  , String
-> Name
-> (Integer -> Integer -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t}.
String
-> Name -> (Integer -> Integer -> t) -> (t -> Literal) -> CoreRule
divop_one  String
"integerDiv"     Name
integerDivName     Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div     Integer -> Literal
mkLitInteger
  , String
-> Name
-> (Integer -> Integer -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t}.
String
-> Name -> (Integer -> Integer -> t) -> (t -> Literal) -> CoreRule
divop_one  String
"integerMod"     Name
integerModName     Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod     Integer -> Literal
mkLitInteger
  , String
-> Name
-> (Integer -> Integer -> (Integer, Integer))
-> (Integer -> Literal)
-> Type
-> CoreRule
forall {t}.
String
-> Name
-> (Integer -> Integer -> (t, t))
-> (t -> Literal)
-> Type
-> CoreRule
divop_both String
"integerDivMod"  Name
integerDivModName  Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
divMod  Integer -> Literal
mkLitInteger Type
integerTy
  , String
-> Name
-> (Integer -> Integer -> (Integer, Integer))
-> (Integer -> Literal)
-> Type
-> CoreRule
forall {t}.
String
-> Name
-> (Integer -> Integer -> (t, t))
-> (t -> Literal)
-> Type
-> CoreRule
divop_both String
"integerQuotRem" Name
integerQuotRemName Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
quotRem Integer -> Literal
mkLitInteger Type
integerTy

  , String
-> Name
-> (Integer -> Integer -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t}.
String
-> Name -> (Integer -> Integer -> t) -> (t -> Literal) -> CoreRule
divop_one  String
"naturalQuot"    Name
naturalQuotName    Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot    Integer -> Literal
mkLitNatural
  , String
-> Name
-> (Integer -> Integer -> Integer)
-> (Integer -> Literal)
-> CoreRule
forall {t}.
String
-> Name -> (Integer -> Integer -> t) -> (t -> Literal) -> CoreRule
divop_one  String
"naturalRem"     Name
naturalRemName     Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem     Integer -> Literal
mkLitNatural
  , String
-> Name
-> (Integer -> Integer -> (Integer, Integer))
-> (Integer -> Literal)
-> Type
-> CoreRule
forall {t}.
String
-> Name
-> (Integer -> Integer -> (t, t))
-> (t -> Literal)
-> Type
-> CoreRule
divop_both String
"naturalQuotRem" Name
naturalQuotRemName Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
quotRem Integer -> Literal
mkLitNatural Type
naturalTy

    -- conversions from Rational for Float/Double literals
  , String -> Name -> (Float -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rational_to String
"rationalToFloat"  Name
rationalToFloatName  Float -> CoreExpr
mkFloatExpr
  , String -> Name -> (Double -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rational_to String
"rationalToDouble" Name
rationalToDoubleName Double -> CoreExpr
mkDoubleExpr

    -- conversions from Integer for Float/Double literals
  , String -> Name -> (Float -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
integer_encode_float String
"integerEncodeFloat"  Name
integerEncodeFloatName  Float -> CoreExpr
forall b. Float -> Expr b
mkFloatLitFloat
  , String -> Name -> (Double -> CoreExpr) -> CoreRule
forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
integer_encode_float String
"integerEncodeDouble" Name
integerEncodeDoubleName Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble
  ]
  where
    -- The rule is matching against an occurrence of a data constructor in a
    -- Core expression. It must match either its worker name or its wrapper
    -- name, /not/ the DataCon name itself, which is different.
    -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892
    --
    -- But data constructor wrappers deliberately inline late; See Note
    -- [Activation for data constructor wrappers] in GHC.Types.Id.Make.
    -- Suppose there is a wrapper and the rule matches on the worker: the
    -- wrapper won't be inlined until rules have finished firing and the rule
    -- will never fire.
    --
    -- Hence the rule must match on the wrapper, if there is one, otherwise on
    -- the worker. That is exactly the dataConWrapId for the data constructor.
    -- The data constructor may or may not have a wrapper, but if not
    -- dataConWrapId will return the worker
    --
    integerISName :: Name
integerISName = Id -> Name
idName (DataCon -> Id
dataConWrapId DataCon
integerISDataCon)
    naturalNSName :: Name
naturalNSName = Id -> Name
idName (DataCon -> Id
dataConWrapId DataCon
naturalNSDataCon)

    mkRule :: String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
nargs RuleM CoreExpr
f = BuiltinRule :: RuleName -> Name -> ConTagZ -> RuleFun -> CoreRule
BuiltinRule
      { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
str
      , ru_fn :: Name
ru_fn = Name
name
      , ru_nargs :: ConTagZ
ru_nargs = ConTagZ
nargs
      , ru_try :: RuleFun
ru_try = RuleM CoreExpr -> RuleFun
forall r.
RuleM r -> RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r
runRuleM RuleM CoreExpr
f
      }

    integer_to_lit :: String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
integer_to_lit String
str Name
name Platform -> Integer -> CoreExpr
convert = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      Platform
platform <- RuleM Platform
getPlatform
      Integer
x <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a0
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Platform -> Integer -> CoreExpr
convert Platform
platform Integer
x)

    natural_to_word :: String -> Name -> Bool -> CoreRule
natural_to_word String
str Name
name Bool
clamp = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      Integer
n <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a0
      Platform
platform <- RuleM Platform
getPlatform
      if Bool
clamp Bool -> Bool -> Bool
&& Bool -> Bool
not (Platform -> Integer -> Bool
platformInWordRange Platform
platform Integer
n)
          then CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWord Platform
platform (Platform -> Integer
platformMaxWord Platform
platform)))
          else CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWordWrap Platform
platform Integer
n))

    integer_to_natural :: String -> Name -> Bool -> Bool -> CoreRule
integer_to_natural String
str Name
name Bool
thrw Bool
clamp = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a0
      if | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0    -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
$ Integer -> Literal
mkLitNatural Integer
x
         | Bool
thrw      -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero
         | Bool
clamp     -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
$ Integer -> Literal
mkLitNatural Integer
0       -- clamp to 0
         | Bool
otherwise -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
$ Integer -> Literal
mkLitNatural (Integer -> Integer
forall a. Num a => a -> a
abs Integer
x) -- negate/wrap

    lit_to_integer :: String -> Name -> CoreRule
lit_to_integer String
str Name
name = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      CoreExpr -> RuleM Literal
isLiteral CoreExpr
a0 RuleM Literal -> (Literal -> RuleM CoreExpr) -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- convert any numeric literal into an Integer literal
        LitNumber LitNumType
_ Integer
i -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInteger Integer
i))
        Literal
_             -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    lit_to_natural :: String -> Name -> CoreRule
lit_to_natural String
str Name
name = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      CoreExpr -> RuleM Literal
isLiteral CoreExpr
a0 RuleM Literal -> (Literal -> RuleM CoreExpr) -> RuleM CoreExpr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- convert any *positive* numeric literal into a Natural literal
        LitNumber LitNumType
_ Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitNatural Integer
i))
        Literal
_                      -> RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    integer_binop :: String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
integer_binop String
str Name
name Integer -> Integer -> Integer
op = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a0
      Integer
y <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a1
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInteger (Integer
x Integer -> Integer -> Integer
`op` Integer
y)))

    natural_binop :: String -> Name -> (Integer -> Integer -> Integer) -> CoreRule
natural_binop String
str Name
name Integer -> Integer -> Integer
op = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a0
      Integer
y <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a1
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitNatural (Integer
x Integer -> Integer -> Integer
`op` Integer
y)))

    natural_sub :: String -> Name -> CoreRule
natural_sub String
str Name
name = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a0
      Integer
y <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a1
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
y)
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitNatural (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y)))

    integer_cmp :: String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
integer_cmp String
str Name
name Integer -> Integer -> Bool
op = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      Platform
platform <- RuleM Platform
getPlatform
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a0
      Integer
y <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a1
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ if Integer
x Integer -> Integer -> Bool
`op` Integer
y
              then Platform -> CoreExpr
trueValInt Platform
platform
              else Platform -> CoreExpr
falseValInt Platform
platform

    natural_cmp :: String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
natural_cmp String
str Name
name Integer -> Integer -> Bool
op = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      Platform
platform <- RuleM Platform
getPlatform
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a0
      Integer
y <- CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
a1
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ if Integer
x Integer -> Integer -> Bool
`op` Integer
y
              then Platform -> CoreExpr
trueValInt Platform
platform
              else Platform -> CoreExpr
falseValInt Platform
platform

    bignum_compare :: String -> Name -> CoreRule
bignum_compare String
str Name
name = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      Integer
y <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a1
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ case Integer
x Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Integer
y of
              Ordering
LT -> CoreExpr
ltVal
              Ordering
EQ -> CoreExpr
eqVal
              Ordering
GT -> CoreExpr
gtVal

    bignum_unop :: String -> Name -> (t -> Literal) -> (Integer -> t) -> CoreRule
bignum_unop String
str Name
name t -> Literal
mk_lit Integer -> t
op = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (t -> Literal
mk_lit (Integer -> t
op Integer
x))

    bignum_popcount :: String -> Name -> (Platform -> t -> Literal) -> CoreRule
bignum_popcount String
str Name
name Platform -> t -> Literal
mk_lit = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      Platform
platform <- RuleM Platform
getPlatform
      -- We use a host Int to compute the popCount. If we compile on a 32-bit
      -- host for a 64-bit target, the result may be different than if computed
      -- by the target. So we disable this rule if sizes don't match.
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Platform -> ConTagZ
platformWordSizeInBits Platform
platform ConTagZ -> ConTagZ -> Bool
forall a. Eq a => a -> a -> Bool
== Word -> ConTagZ
forall b. FiniteBits b => b -> ConTagZ
finiteBitSize (Word
0 :: Word))
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> t -> Literal
mk_lit Platform
platform (ConTagZ -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> ConTagZ
forall a. Bits a => a -> ConTagZ
popCount Integer
x)))

    id_passthrough :: String -> Name -> Name -> CoreRule
id_passthrough String
str Name
to_x Name
from_x = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
to_x ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [App (Var Id
f) CoreExpr
x] <- RuleM [CoreExpr]
getArgs
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Id -> Name
idName Id
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
from_x)
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
x

    small_passthrough :: String -> Name -> Name -> Id -> CoreRule
small_passthrough String
str Name
from_x Name
to_y Id
x_to_y = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
to_y ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [App (Var Id
f) CoreExpr
x] <- RuleM [CoreExpr]
getArgs
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Id -> Name
idName Id
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
from_x)
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM 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 Id
x_to_y) CoreExpr
x

    bignum_bit :: String -> Name -> (t -> Literal) -> CoreRule
bignum_bit String
str Name
name t -> Literal
mk_lit = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
1 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0] <- RuleM [CoreExpr]
getArgs
      Platform
platform <- RuleM Platform
getPlatform
      Integer
n <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      -- Make sure n is positive and small enough to yield a decently
      -- small number. Attempting to construct the Integer for
      --    (integerBit 9223372036854775807#)
      -- would be a bad idea (#14959)
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= ConTagZ -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Platform -> ConTagZ
platformWordSizeInBits Platform
platform))
      -- it's safe to convert a target Int value into a host Int value
      -- to perform the "bit" operation because n is very small (<= 64).
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (t -> Literal
mk_lit (ConTagZ -> t
forall a. Bits a => ConTagZ -> a
bit (Integer -> ConTagZ
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)))

    bignum_testbit :: String -> Name -> CoreRule
bignum_testbit String
str Name
name = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Platform
platform <- RuleM Platform
getPlatform
      Integer
x <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      Integer
n <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a1
      -- ensure that we can store 'n' in a host Int
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= ConTagZ -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConTagZ
forall a. Bounded a => a
maxBound :: Int))
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ if Integer -> ConTagZ -> Bool
forall a. Bits a => a -> ConTagZ -> Bool
testBit Integer
x (Integer -> ConTagZ
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
              then Platform -> CoreExpr
trueValInt Platform
platform
              else Platform -> CoreExpr
falseValInt Platform
platform

    bignum_shift :: String -> Name -> (Integer -> t -> t) -> (t -> Literal) -> CoreRule
bignum_shift String
str Name
name Integer -> t -> t
shift_op t -> Literal
mk_lit = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      Integer
n <- CoreExpr -> RuleM Integer
isWordLiteral CoreExpr
a1
      -- See Note [Guarding against silly shifts]
      -- Restrict constant-folding of shifts on Integers, somewhat arbitrary.
      -- We can get huge shifts in inaccessible code (#15673)
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
4)
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (t -> Literal
mk_lit (Integer
x Integer -> t -> t
`shift_op` Integer -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n))

    divop_one :: String
-> Name -> (Integer -> Integer -> t) -> (t -> Literal) -> CoreRule
divop_one String
str Name
name Integer -> Integer -> t
divop t -> Literal
mk_lit = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
n <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      Integer
d <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a1
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (t -> Literal
mk_lit (Integer
n Integer -> Integer -> t
`divop` Integer
d))

    divop_both :: String
-> Name
-> (Integer -> Integer -> (t, t))
-> (t -> Literal)
-> Type
-> CoreRule
divop_both String
str Name
name Integer -> Integer -> (t, t)
divop t -> Literal
mk_lit Type
ty = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
n <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a0
      Integer
d <- CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
a1
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)
      let (t
r,t
s) = Integer
n Integer -> Integer -> (t, t)
`divop` Integer
d
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (t -> Literal
mk_lit t
r), Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (t -> Literal
mk_lit t
s)]

    integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule
    integer_encode_float :: forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
integer_encode_float String
str Name
name a -> CoreExpr
mk_lit = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
x <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a0
      Integer
y <- CoreExpr -> RuleM Integer
isIntLiteral CoreExpr
a1
      -- check that y (a target Int) is in the host Int range
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= ConTagZ -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConTagZ
forall a. Bounded a => a
maxBound :: Int))
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> CoreExpr
mk_lit (a -> CoreExpr) -> a -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> ConTagZ -> a
forall a. RealFloat a => Integer -> ConTagZ -> a
encodeFloat Integer
x (Integer -> ConTagZ
forall a. Num a => Integer -> a
fromInteger Integer
y))

    rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule
    rational_to :: forall a.
RealFloat a =>
String -> Name -> (a -> CoreExpr) -> CoreRule
rational_to String
str Name
name a -> CoreExpr
mk_lit = String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
2 (RuleM CoreExpr -> CoreRule) -> RuleM CoreExpr -> CoreRule
forall a b. (a -> b) -> a -> b
$ do
      -- This turns `rationalToFloat n d` where `n` and `d` are literals into
      -- a literal Float (and similarly for Double).
      [CoreExpr
a0,CoreExpr
a1] <- RuleM [CoreExpr]
getArgs
      Integer
n <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a0
      Integer
d <- CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
a1
      -- 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
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)
      CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ a -> CoreExpr
mk_lit (Rational -> a
forall a. Fractional a => Rational -> a
fromRational (Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
d))


---------------------------------------------------
-- The rule is this:
--      unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n)
--      =  unpackFoldrCString*# "foobaz"# c n
--
-- See also Note [String literals in GHC] in CString.hs

-- CString version
match_append_lit_C :: RuleFun
match_append_lit_C :: RuleFun
match_append_lit_C = Unique -> RuleFun
match_append_lit Unique
unpackCStringFoldrIdKey

-- CStringUTF8 version
match_append_lit_utf8 :: RuleFun
match_append_lit_utf8 :: RuleFun
match_append_lit_utf8 = Unique -> RuleFun
match_append_lit Unique
unpackCStringFoldrUtf8IdKey

{-# INLINE match_append_lit #-}
match_append_lit :: Unique -> RuleFun
match_append_lit :: Unique -> RuleFun
match_append_lit Unique
foldVariant RuleOpts
_ InScopeEnv
id_unf Id
_
        [ Type Type
ty1
        , CoreExpr
lit1
        , CoreExpr
c1
        , CoreExpr
e2
        ]
  -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the
  -- `lit` and `c` arguments, lest this may fail to fire when building with
  -- -g3. See #16740.
  | ([Tickish Id]
strTicks, Var Id
unpk `App` Type Type
ty2
                        `App` CoreExpr
lit2
                        `App` CoreExpr
c2
                        `App` CoreExpr
n) <- (Tickish Id -> Bool) -> CoreExpr -> ([Tickish Id], CoreExpr)
forall b. (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
e2
  , Id
unpk Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
foldVariant
  , Just (LitString ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit1
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit2
  , let freeVars :: InScopeSet
freeVars = (VarSet -> InScopeSet
mkInScopeSet (CoreExpr -> VarSet
exprFreeVars CoreExpr
c1 VarSet -> VarSet -> VarSet
`unionVarSet` CoreExpr -> VarSet
exprFreeVars CoreExpr
c2))
    in InScopeSet -> CoreExpr -> CoreExpr -> Bool
eqExpr InScopeSet
freeVars CoreExpr
c1 CoreExpr
c2
  , ([Tickish Id]
c1Ticks, CoreExpr
c1') <- (Tickish Id -> Bool) -> CoreExpr -> ([Tickish Id], CoreExpr)
forall b. (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
c1
  , [Tickish Id]
c2Ticks <- (Tickish Id -> Bool) -> CoreExpr -> [Tickish Id]
forall b. (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksTopT Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
c2
  = ASSERT( ty1 `eqType` ty2 )
    CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks [Tickish Id]
strTicks
         (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ 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` [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks ([Tickish Id]
c1Ticks [Tickish Id] -> [Tickish Id] -> [Tickish Id]
forall a. [a] -> [a] -> [a]
++ [Tickish Id]
c2Ticks) CoreExpr
c1'
                    CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
n

match_append_lit Unique
_ RuleOpts
_ InScopeEnv
_ Id
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

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

match_eq_string :: RuleFun
match_eq_string :: RuleFun
match_eq_string RuleOpts
_ InScopeEnv
id_unf Id
_
        [Var Id
unpk1 `App` CoreExpr
lit1, Var Id
unpk2 `App` CoreExpr
lit2]
  | Unique
unpk_key1 <- Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
unpk1
  , Unique
unpk_key2 <- Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
unpk2
  , Unique
unpk_key1 Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpk_key2
  -- For now we insist the literals have to agree in their encoding
  -- to keep the rule simple. But we could check if the decoded strings
  -- compare equal in here as well.
  , Unique
unpk_key1 Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
unpackCStringUtf8IdKey, Unique
unpackCStringIdKey]
  , Just (LitString ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit1
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit2
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (if ByteString
s1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
s2 then CoreExpr
trueValBool else CoreExpr
falseValBool)

match_eq_string RuleOpts
_ InScopeEnv
_ Id
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

-----------------------------------------------------------------------
-- Illustration of this rule:
--
-- cstringLength# "foobar"# --> 6
-- cstringLength# "fizz\NULzz"# --> 4
--
-- Nota bene: Addr# literals are suffixed by a NUL byte when they are
-- compiled to read-only data sections. That's why cstringLength# is
-- well defined on Addr# literals that do not explicitly have an embedded
-- NUL byte.
--
-- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly
-- helpful when using OverloadedStrings to create a ByteString since the
-- function computing the length of such ByteStrings can often be constant
-- folded.
match_cstring_length :: RuleFun
match_cstring_length :: RuleFun
match_cstring_length RuleOpts
env InScopeEnv
id_unf Id
_ [CoreExpr
lit1]
  | Just (LitString ByteString
str) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
id_unf CoreExpr
lit1
    -- If elemIndex returns Just, it has the index of the first embedded NUL
    -- in the string. If no NUL bytes are present (the common case) then use
    -- full length of the byte string.
  = let len :: ConTagZ
len = ConTagZ -> Maybe ConTagZ -> ConTagZ
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> ConTagZ
BS.length ByteString
str) (Word8 -> ByteString -> Maybe ConTagZ
BS.elemIndex Word8
0 ByteString
str)
     in CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitInt (RuleOpts -> Platform
roPlatform RuleOpts
env) (ConTagZ -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConTagZ
len)))
match_cstring_length RuleOpts
_ InScopeEnv
_ Id
_ [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

---------------------------------------------------
{- Note [inlineId magic]
~~~~~~~~~~~~~~~~~~~~~~~~
The call 'inline f' arranges that 'f' is inlined, regardless of
its size. More precisely, the call 'inline f' rewrites to the
right-hand side of 'f's definition. This allows the programmer to
control inlining from a particular call site rather than the
definition site of the function.

The moving parts are simple:

* A very simple definition in the library base:GHC.Magic
     {-# NOINLINE[0] inline #-}
     inline :: a -> a
     inline x = x
  So in phase 0, 'inline' will be inlined, so its use imposes
  no overhead.

* A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes
  (inline f) inline, implemented by match_inline.
  The rule for the 'inline' function 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
      either  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, so the call may look like
        inline (map @Int @Bool) g xs

  Also, don't forget about 'inline's type argument!
-}

match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_inline :: [CoreExpr] -> Maybe CoreExpr
match_inline (Type Type
_ : CoreExpr
e : [CoreExpr]
_)
  | (Var Id
f, [CoreExpr]
args1) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e,
    Just 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 [CoreExpr]
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

---------------------------------------------------
-- See Note [magicDictId magic] in "GHC.Types.Id.Make"
-- for a description of what is going on here.
match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_magicDict :: [CoreExpr] -> Maybe CoreExpr
match_magicDict [Type Type
_, ((Tickish Id -> Bool) -> CoreExpr -> CoreExpr
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksE (Bool -> Tickish Id -> Bool
forall a b. a -> b -> a
const Bool
True) -> (Var Id
wrap `App` Type Type
a `App` Type Type
_ `App` CoreExpr
f)), CoreExpr
x, CoreExpr
y ]
  | Just (Type
_, Type
fieldTy, Type
_)  <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe (Type -> Maybe (Type, Type, Type))
-> Type -> Maybe (Type, 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 (Type
_, Type
dictTy, Type
_)   <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fieldTy
  , Just TyCon
dictTc           <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
dictTy
  , Just ([Id]
_,Type
_,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 -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
x (CoercionR -> CoercionR
mkSymCo (Role -> CoAxiom Unbranched -> [Type] -> [CoercionR] -> CoercionR
mkUnbranchedAxInstCo Role
Representational CoAxiom Unbranched
co [Type
a] []))
      CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
y

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

--------------------------------------------------------
-- 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 -> (Platform -> PrimOps) -> RuleM CoreExpr
numFoldingRules :: PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr
numFoldingRules PrimOp
op Platform -> PrimOps
dict = do
  RuleOpts
env <- RuleM RuleOpts
getEnv
  if Bool -> Bool
not (RuleOpts -> Bool
roNumConstantFolding RuleOpts
env)
   then RuleM CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a
mzero
   else do
    [CoreExpr
e1,CoreExpr
e2] <- RuleM [CoreExpr]
getArgs
    Platform
platform <- RuleM Platform
getPlatform
    let PrimOps{Integer -> CoreExpr
CoreExpr -> CoreExpr -> CoreExpr
mkL :: PrimOps -> Integer -> CoreExpr
mul :: PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
sub :: PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
add :: PrimOps -> CoreExpr -> CoreExpr -> CoreExpr
mkL :: Integer -> CoreExpr
mul :: CoreExpr -> CoreExpr -> CoreExpr
sub :: CoreExpr -> CoreExpr -> CoreExpr
add :: CoreExpr -> CoreExpr -> CoreExpr
..} = Platform -> PrimOps
dict Platform
platform
    case CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
e1 PrimOp
op CoreExpr
e2 of
     -- R1) +/- simplification
     Integer
x    :++: (Integer
y :++: CoreExpr
v)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v
     Integer
x    :++: (L Integer
y :-: CoreExpr
v)         -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v
     Integer
x    :++: (CoreExpr
v   :-: L Integer
y)       -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v
     L Integer
x  :-:  (Integer
y :++: CoreExpr
v)          -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v
     L Integer
x  :-:  (L Integer
y :-: CoreExpr
v)         -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
v
     L Integer
x  :-:  (CoreExpr
v   :-: L Integer
y)       -> CoreExpr -> RuleM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Integer -> CoreExpr
mkL (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)   CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
v

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

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

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

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

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

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

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

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



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

-- | Match a primop
pattern OpVal   :: PrimOp  -> Arg CoreBndr
pattern $mOpVal :: forall {r}. CoreExpr -> (PrimOp -> r) -> (Void# -> r) -> r
$bOpVal :: PrimOp -> CoreExpr
OpVal   op     <- Var (isPrimOpId_maybe -> Just op) where
   OpVal 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 CoreExpr
e = case CoreExpr
e of
   L Integer
l :+: CoreExpr
x   -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   CoreExpr
x   :+: L Integer
l -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
   CoreExpr
_           -> Maybe (Integer, CoreExpr)
forall a. Maybe a
Nothing

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

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

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


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

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

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

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

-- | Explicit "type-class"-like dictionary for numeric primops
--
-- Depends on Platform because creating a literal value depends on Platform
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 :: Platform -> PrimOps
intPrimOps :: Platform -> PrimOps
intPrimOps Platform
platform = PrimOps :: (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (Integer -> CoreExpr)
-> PrimOps
PrimOps
   { add :: CoreExpr -> CoreExpr -> CoreExpr
add = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntAddOp CoreExpr
y
   , sub :: CoreExpr -> CoreExpr -> CoreExpr
sub = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntSubOp CoreExpr
y
   , mul :: CoreExpr -> CoreExpr -> CoreExpr
mul = \CoreExpr
x CoreExpr
y -> CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
IntMulOp CoreExpr
y
   , mkL :: Integer -> CoreExpr
mkL = Platform -> Integer -> CoreExpr
intResult' Platform
platform
   }

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


--------------------------------------------------------
-- Constant folding through case-expressions
--
-- cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils
--------------------------------------------------------

-- | Match the scrutinee of a case and potentially return a new scrutinee and a
-- function to apply to each literal alternative.
caseRules :: Platform
          -> 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 :: Platform
-> CoreExpr
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
caseRules Platform
platform (App (App (Var Id
f) CoreExpr
v) (Lit Literal
l))   -- v `op` x#
  | Just PrimOp
op <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
  , Just Integer
x  <- Literal -> Maybe Integer
isLitValue_maybe Literal
l
  , Just Integer -> Integer
adjust_lit <- PrimOp -> Integer -> Maybe (Integer -> Integer)
adjustDyadicRight PrimOp
op Integer
x
  = (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con Platform
platform Integer -> Integer
adjust_lit
           , \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 Platform
platform (App (App (Var Id
f) (Lit Literal
l)) CoreExpr
v)   -- x# `op` v
  | Just PrimOp
op <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
  , Just Integer
x  <- Literal -> Maybe Integer
isLitValue_maybe Literal
l
  , Just Integer -> Integer
adjust_lit <- Integer -> PrimOp -> Maybe (Integer -> Integer)
adjustDyadicLeft Integer
x PrimOp
op
  = (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con Platform
platform Integer -> Integer
adjust_lit
           , \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 Platform
platform (App (Var Id
f) CoreExpr
v              )   -- op v
  | Just PrimOp
op <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
  , Just 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, Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con Platform
platform Integer -> Integer
adjust_lit
           , \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 Platform
platform (App (App (Var Id
f) CoreExpr
type_arg) CoreExpr
v)
  | Just PrimOp
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, Platform -> AltCon -> Maybe AltCon
tx_con_tte Platform
platform
           , \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 Platform
_ (App (App (Var Id
f) (Type Type
ty)) CoreExpr
v)       -- dataToTag x
  | Just PrimOp
DataToTagOp <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
  , Just (TyCon
tc, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
  , TyCon -> Bool
isAlgTyCon TyCon
tc
  = (CoreExpr, AltCon -> Maybe AltCon, 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
           , \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 Platform
_ CoreExpr
_ = Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. Maybe a
Nothing


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

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

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


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

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

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

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


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

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

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

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

Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils
(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 alternative is dead code -- we know the range of tags for x.

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

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