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

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 AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}

-- | Constant Folder
module GHC.Core.Opt.ConstantFold
   ( primOpRules
   , builtinRules
   , caseRules
   , caseRules2
   )
where

import GHC.Prelude

import GHC.Platform
import GHC.Float

import GHC.Types.Id.Make ( unboxedUnitExpr )
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Types.Name.Occurrence ( occNameFS )
import GHC.Types.Tickish
import GHC.Types.Name ( Name, nameOccName )
import GHC.Types.Basic

import GHC.Core
import GHC.Core.Make
import GHC.Core.SimpleOpt (  exprIsConApp_maybe, exprIsLiteral_maybe )
import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
import GHC.Core.Utils  ( cheapEqExpr, exprIsHNF
                       , stripTicksTop, stripTicksTopT, mkTicks )
import GHC.Core.Multiplicity
import GHC.Core.Rules.Config
import GHC.Core.Type
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon
   ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConFamilySize
   , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon )
import GHC.Core.Map.Expr ( eqCoreExpr )

import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names

import GHC.Cmm.MachOp ( FMASign(..) )
import GHC.Cmm.Type ( Width(..) )

import GHC.Data.FastString
import GHC.Data.Maybe      ( orElse )

import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic

import Control.Applicative ( Alternative(..) )
import Control.Monad
import Data.Functor (($>))
import qualified Data.ByteString as BS
import Data.Ratio
import Data.Word
import Data.Maybe (fromMaybe, fromJust)

{-
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
DataToTagSmallOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 [ RuleM CoreExpr
dataToTagRule ]
   PrimOp
DataToTagLargeOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 [ RuleM CoreExpr
dataToTagRule ]

   -- Int8 operations
   PrimOp
Int8AddOp   -> 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
int8Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroI8
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Int8AddOp NumOps
int8Ops
                                    ]
   PrimOp
Int8SubOp   -> 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
int8Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI8
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI8
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Int8SubOp NumOps
int8Ops
                                    ]
   PrimOp
Int8MulOp   -> 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
int8Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity Literal
oneI8
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Int8MulOp NumOps
int8Ops
                                    ]
   PrimOp
Int8QuotOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int8Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , RuleM CoreExpr
leftZero
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneI8
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
oneI8
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
int8Ops
                                    ]
   PrimOp
Int8RemOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int8Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI8
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI8 ]
   PrimOp
Int8NegOp   -> 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
semiInversePrimOp PrimOp
Int8NegOp ]
   PrimOp
Int8SllOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt8 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI8 ]
   PrimOp
Int8SraOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt8 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI8 ]
   PrimOp
Int8SrlOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt8 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word8
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI8 ]

   -- Word8 operations
   PrimOp
Word8AddOp  -> 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
word8Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW8
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Word8AddOp NumOps
word8Ops
                                    ]
   PrimOp
Word8SubOp  -> 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
word8Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroW8
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW8
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Word8SubOp NumOps
word8Ops
                                    ]
   PrimOp
Word8MulOp  -> 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
word8Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , Literal -> RuleM CoreExpr
identity Literal
oneW8
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Word8MulOp NumOps
word8Ops
                                    ]
   PrimOp
Word8QuotOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word8Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneW8
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
word8Ops
                                    ]
   PrimOp
Word8RemOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word8Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW8
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW8 ]
   PrimOp
Word8AndOp  -> 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
word8Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.))
                                    , RuleM CoreExpr
idempotent
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity (Integer -> Literal
mkLitWord8 Integer
0xFF)
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word8AndOp
                                    , NumOps -> RuleM CoreExpr
andFoldingRules NumOps
word8Ops
                                    ]
   PrimOp
Word8OrOp   -> 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
word8Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.))
                                    , RuleM CoreExpr
idempotent
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW8
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word8OrOp
                                    , NumOps -> RuleM CoreExpr
orFoldingRules NumOps
word8Ops
                                    ]
   PrimOp
Word8XorOp  -> 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
word8Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor)
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW8
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW8 ]
   PrimOp
Word8NotOp  -> 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
semiInversePrimOp PrimOp
Word8NotOp ]
   PrimOp
Word8SllOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord8 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL) ]
   PrimOp
Word8SrlOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord8 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word8 ]


   -- Int16 operations
   PrimOp
Int16AddOp  -> 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
int16Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroI16
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Int16AddOp NumOps
int16Ops
                                    ]
   PrimOp
Int16SubOp  -> 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
int16Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI16
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI16
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Int16SubOp NumOps
int16Ops
                                    ]
   PrimOp
Int16MulOp  -> 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
int16Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity Literal
oneI16
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Int16MulOp NumOps
int16Ops
                                    ]
   PrimOp
Int16QuotOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int16Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , RuleM CoreExpr
leftZero
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneI16
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
oneI16
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
int16Ops
                                    ]
   PrimOp
Int16RemOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int16Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI16
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI16 ]
   PrimOp
Int16NegOp  -> 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
semiInversePrimOp PrimOp
Int16NegOp ]
   PrimOp
Int16SllOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt16 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI16 ]
   PrimOp
Int16SraOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt16 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI16 ]
   PrimOp
Int16SrlOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt16 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word16
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI16 ]

   -- Word16 operations
   PrimOp
Word16AddOp -> 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
word16Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW16
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Word16AddOp NumOps
word16Ops
                                    ]
   PrimOp
Word16SubOp -> 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
word16Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroW16
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW16
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Word16SubOp NumOps
word16Ops
                                    ]
   PrimOp
Word16MulOp -> 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
word16Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , Literal -> RuleM CoreExpr
identity Literal
oneW16
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Word16MulOp NumOps
word16Ops
                                    ]
   PrimOp
Word16QuotOp-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word16Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneW16
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
word16Ops
                                    ]
   PrimOp
Word16RemOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word16Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW16
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW16 ]
   PrimOp
Word16AndOp -> 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
word16Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.))
                                    , RuleM CoreExpr
idempotent
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity (Integer -> Literal
mkLitWord16 Integer
0xFFFF)
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word16AndOp
                                    , NumOps -> RuleM CoreExpr
andFoldingRules NumOps
word16Ops
                                    ]
   PrimOp
Word16OrOp  -> 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
word16Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.))
                                    , RuleM CoreExpr
idempotent
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW16
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word16OrOp
                                    , NumOps -> RuleM CoreExpr
orFoldingRules NumOps
word16Ops
                                    ]
   PrimOp
Word16XorOp -> 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
word16Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor)
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW16
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW16 ]
   PrimOp
Word16NotOp -> 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
semiInversePrimOp PrimOp
Word16NotOp ]
   PrimOp
Word16SllOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord16 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL) ]
   PrimOp
Word16SrlOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord16 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word16 ]


   -- Int32 operations
   PrimOp
Int32AddOp  -> 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
int32Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroI32
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Int32AddOp NumOps
int32Ops
                                    ]
   PrimOp
Int32SubOp  -> 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
int32Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI32
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI32
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Int32SubOp NumOps
int32Ops
                                    ]
   PrimOp
Int32MulOp  -> 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
int32Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity Literal
oneI32
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Int32MulOp NumOps
int32Ops
                                    ]
   PrimOp
Int32QuotOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int32Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , RuleM CoreExpr
leftZero
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneI32
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
oneI32
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
int32Ops
                                    ]
   PrimOp
Int32RemOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int32Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI32
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI32 ]
   PrimOp
Int32NegOp  -> 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
semiInversePrimOp PrimOp
Int32NegOp ]
   PrimOp
Int32SllOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt32 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI32 ]
   PrimOp
Int32SraOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt32 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI32 ]
   PrimOp
Int32SrlOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt32 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word32
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI32 ]

   -- Word32 operations
   PrimOp
Word32AddOp -> 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
word32Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW32
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Word32AddOp NumOps
word32Ops
                                    ]
   PrimOp
Word32SubOp -> 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
word32Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroW32
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW32
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Word32SubOp NumOps
word32Ops
                                    ]
   PrimOp
Word32MulOp -> 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
word32Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , Literal -> RuleM CoreExpr
identity Literal
oneW32
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Word32MulOp NumOps
word32Ops
                                    ]
   PrimOp
Word32QuotOp-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word32Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneW32
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
word32Ops
                                    ]
   PrimOp
Word32RemOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word32Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW32
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW32 ]
   PrimOp
Word32AndOp -> 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
word32Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.))
                                    , RuleM CoreExpr
idempotent
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity (Integer -> Literal
mkLitWord32 Integer
0xFFFFFFFF)
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word32AndOp
                                    , NumOps -> RuleM CoreExpr
andFoldingRules NumOps
word32Ops
                                    ]
   PrimOp
Word32OrOp  -> 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
word32Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.))
                                    , RuleM CoreExpr
idempotent
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW32
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word32OrOp
                                    , NumOps -> RuleM CoreExpr
orFoldingRules NumOps
word32Ops
                                    ]
   PrimOp
Word32XorOp -> 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
word32Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor)
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW32
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW32 ]
   PrimOp
Word32NotOp -> 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
semiInversePrimOp PrimOp
Word32NotOp ]
   PrimOp
Word32SllOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord32 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL) ]
   PrimOp
Word32SrlOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord32 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word32 ]

   -- Int64 operations
   PrimOp
Int64AddOp  -> 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
int64Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroI64
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Int64AddOp NumOps
int64Ops
                                    ]
   PrimOp
Int64SubOp  -> 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
int64Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI64
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI64
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Int64SubOp NumOps
int64Ops
                                    ]
   PrimOp
Int64MulOp  -> 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
int64Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity Literal
oneI64
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Int64MulOp NumOps
int64Ops
                                    ]
   PrimOp
Int64QuotOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int64Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , RuleM CoreExpr
leftZero
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneI64
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
oneI64
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
int64Ops
                                    ]
   PrimOp
Int64RemOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
int64Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI64
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroI64 ]
   PrimOp
Int64NegOp  -> 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
semiInversePrimOp PrimOp
Int64NegOp ]
   PrimOp
Int64SllOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt64 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI64 ]
   PrimOp
Int64SraOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt64 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI64 ]
   PrimOp
Int64SrlOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumInt64 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word64
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroI64 ]

   -- Word64 operations
   PrimOp
Word64AddOp -> 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
word64Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+))
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW64
                                    , PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
Word64AddOp NumOps
word64Ops
                                    ]
   PrimOp
Word64SubOp -> 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
word64Op2 (-))
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
zeroW64
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW64
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
Word64SubOp NumOps
word64Ops
                                    ]
   PrimOp
Word64MulOp -> 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
word64Op2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*))
                                    , Literal -> RuleM CoreExpr
identity Literal
oneW64
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
Word64MulOp NumOps
word64Ops
                                    ]
   PrimOp
Word64QuotOp-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word64Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot)
                                    , Literal -> RuleM CoreExpr
rightIdentity Literal
oneW64
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
word64Ops
                                    ]
   PrimOp
Word64RemOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
word64Op2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW64
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW64 ]
   PrimOp
Word64AndOp -> 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
word64Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.&.))
                                    , RuleM CoreExpr
idempotent
                                    , RuleM CoreExpr
zeroElem
                                    , Literal -> RuleM CoreExpr
identity (Integer -> Literal
mkLitWord64 Integer
0xFFFFFFFFFFFFFFFF)
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word64AndOp
                                    , NumOps -> RuleM CoreExpr
andFoldingRules NumOps
word64Ops
                                    ]
   PrimOp
Word64OrOp  -> 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
word64Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(.|.))
                                    , RuleM CoreExpr
idempotent
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW64
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
Word64OrOp
                                    , NumOps -> RuleM CoreExpr
orFoldingRules NumOps
word64Ops
                                    ]
   PrimOp
Word64XorOp -> 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
word64Op2 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
xor)
                                    , Literal -> RuleM CoreExpr
identity Literal
zeroW64
                                    , RuleM ()
equalArgs RuleM () -> CoreExpr -> RuleM CoreExpr
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
zeroW64 ]
   PrimOp
Word64NotOp -> 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
semiInversePrimOp PrimOp
Word64NotOp ]
   PrimOp
Word64SllOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord64 ((Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL) ]
   PrimOp
Word64SrlOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ LitNumType
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
shiftRule LitNumType
LitNumWord64 ((Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr)
-> (Platform -> Integer -> ConTagZ -> Integer) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ (Integer -> ConTagZ -> Integer)
-> Platform -> Integer -> ConTagZ -> Integer
forall a b. a -> b -> a
const ((Integer -> ConTagZ -> Integer)
 -> Platform -> Integer -> ConTagZ -> Integer)
-> (Integer -> ConTagZ -> Integer)
-> Platform
-> Integer
-> ConTagZ
-> Integer
forall a b. (a -> b) -> a -> b
$ forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word64 ]

   -- 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 -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
IntAddOp NumOps
intOps
                                    ]
   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 a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zeroi
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
IntSubOp NumOps
intOps
                                    ]
   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 a b. RuleM a -> RuleM b -> RuleM b
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
(*))
                                    , RuleM CoreExpr
zeroElem
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform Platform -> Literal
onei
                                    , PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
IntMulOp NumOps
intOps
                                    ]
   PrimOp
IntMul2Op   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ do
                                        [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- RuleM [CoreExpr]
getArgs
                                        platform <- getPlatform
                                        let r = Integer
l1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
l2
                                        pure $ mkCoreUnboxedTuple
                                          [ Lit (if platformInIntRange platform r then zeroi platform else onei platform)
                                          , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform)
                                          , mkIntLitWrap platform r
                                          ]

                                    , RuleM CoreExpr
zeroElem RuleM CoreExpr -> (CoreExpr -> RuleM CoreExpr) -> RuleM CoreExpr
forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CoreExpr
z ->
                                        CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr
z,CoreExpr
z,CoreExpr
z])

                                      -- timesInt2# 1# other
                                      -- ~~~>
                                      -- (# 0#, 0# -# (other >># (WORD_SIZE_IN_BITS-1)), other #)
                                      -- The second element is the sign bit
                                      -- repeated to fill a word.
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform Platform -> Literal
onei RuleM CoreExpr -> (CoreExpr -> RuleM CoreExpr) -> RuleM CoreExpr
forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CoreExpr
other -> do
                                        platform <- RuleM Platform
getPlatform
                                        pure $ mkCoreUnboxedTuple
                                          [ Lit (zeroi platform)
                                          , mkCoreApps (Var (primOpId IntSubOp))
                                              [ Lit (zeroi platform)
                                              , mkCoreApps (Var (primOpId IntSrlOp))
                                                [ other
                                                , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1))
                                                ]
                                              ]
                                          , other
                                          ]
                                    ]
   PrimOp
IntQuotOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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)
                                    , RuleM CoreExpr
leftZero
                                    , (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
onei
                                    , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
onei
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
intOps
                                    ]
   PrimOp
IntRemOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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 a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zeroi ]
   PrimOp
IntAndOp    -> 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
                                    , RuleM CoreExpr
zeroElem
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform (\Platform
p -> Platform -> Integer -> Literal
mkLitInt Platform
p (-Integer
1))
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
IntAndOp
                                    , NumOps -> RuleM CoreExpr
andFoldingRules NumOps
intOps
                                    ]
   PrimOp
IntOrOp     -> 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 -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
IntOrOp
                                    , NumOps -> RuleM CoreExpr
orFoldingRules NumOps
intOps
                                    ]
   PrimOp
IntXorOp    -> 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 a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zeroi ]
   PrimOp
IntNotOp    -> 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
semiInversePrimOp PrimOp
IntNotOp ]
   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
semiInversePrimOp PrimOp
IntNegOp ]
   PrimOp
IntSllOp    -> 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
shiftL)
                                    , (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
zeroi ]
   PrimOp
IntSraOp    -> 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
shiftR)
                                    , (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
zeroi ]
   PrimOp
IntSrlOp    -> 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
shiftRightLogicalNative
                                    , (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 -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
WordAddOp NumOps
wordOps
                                    ]
   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 a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow
                                    , PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
WordSubOp NumOps
wordOps
                                    ]
   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 a b. RuleM a -> RuleM b -> RuleM b
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 -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
WordMulOp NumOps
wordOps
                                    ]
   PrimOp
WordQuotOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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
                                    , NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
wordOps
                                    ]
   PrimOp
WordRemOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
2 [ ConTagZ -> RuleM ()
nonZeroLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
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)
                                    , RuleM CoreExpr
leftZero
                                    , ConTagZ -> RuleM ()
oneLit ConTagZ
1 RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow
                                    , RuleM ()
equalArgs RuleM () -> RuleM CoreExpr -> RuleM CoreExpr
forall a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow ]
   PrimOp
WordAndOp   -> 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
                                    , RuleM CoreExpr
zeroElem
                                    , (Platform -> Literal) -> RuleM CoreExpr
identityPlatform (\Platform
p -> Platform -> Integer -> Literal
mkLitWord Platform
p (Platform -> Integer
platformMaxWord Platform
p))
                                    , PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
WordAndOp
                                    , NumOps -> RuleM CoreExpr
andFoldingRules NumOps
wordOps
                                    ]
   PrimOp
WordOrOp    -> 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 -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
WordOrOp
                                    , NumOps -> RuleM CoreExpr
orFoldingRules NumOps
wordOps
                                    ]
   PrimOp
WordXorOp   -> 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 a b. RuleM a -> RuleM b -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
zerow ]
   PrimOp
WordNotOp   -> 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
semiInversePrimOp PrimOp
WordNotOp ]
   PrimOp
WordSllOp   -> 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
shiftL) ]
   PrimOp
WordSrlOp   -> 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
shiftRightLogicalNative ]

   PrimOp
PopCnt8Op   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count @Word8  ]
   PrimOp
PopCnt16Op  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count @Word16 ]
   PrimOp
PopCnt32Op  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count @Word32 ]
   PrimOp
PopCnt64Op  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count @Word64 ]
   PrimOp
PopCntOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ RuleM PlatformWordSize
getWordSize RuleM PlatformWordSize
-> (PlatformWordSize -> RuleM CoreExpr) -> RuleM CoreExpr
forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                        PlatformWordSize
PW4 -> forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count @Word32
                                        PlatformWordSize
PW8 -> forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count @Word64
                                    ]

   PrimOp
Ctz8Op      -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz @Word8  ]
   PrimOp
Ctz16Op     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz @Word16 ]
   PrimOp
Ctz32Op     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz @Word32 ]
   PrimOp
Ctz64Op     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz @Word64 ]
   PrimOp
CtzOp       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ RuleM PlatformWordSize
getWordSize RuleM PlatformWordSize
-> (PlatformWordSize -> RuleM CoreExpr) -> RuleM CoreExpr
forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                        PlatformWordSize
PW4 -> forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz @Word32
                                        PlatformWordSize
PW8 -> forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz @Word64
                                    ]

   PrimOp
Clz8Op      -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz @Word8  ]
   PrimOp
Clz16Op     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz @Word16 ]
   PrimOp
Clz32Op     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz @Word32 ]
   PrimOp
Clz64Op     -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz @Word64 ]
   PrimOp
ClzOp       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ RuleM PlatformWordSize
getWordSize RuleM PlatformWordSize
-> (PlatformWordSize -> RuleM CoreExpr) -> RuleM CoreExpr
forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                        PlatformWordSize
PW4 -> forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz @Word32
                                        PlatformWordSize
PW8 -> forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz @Word64
                                    ]

   -- coercions

   PrimOp
Int8ToIntOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToIntLit ]
   PrimOp
Int16ToIntOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToIntLit ]
   PrimOp
Int32ToIntOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToIntLit ]
   PrimOp
Int64ToIntOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToIntLit ]
   PrimOp
IntToInt8Op    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowInt8Lit
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
IntAndOp PrimOp
IntToInt8Op ConTagZ
8 ]
   PrimOp
IntToInt16Op   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowInt16Lit
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
IntAndOp PrimOp
IntToInt16Op ConTagZ
16 ]
   PrimOp
IntToInt32Op   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowInt32Lit
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
IntAndOp PrimOp
IntToInt32Op ConTagZ
32 ]
   PrimOp
IntToInt64Op   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowInt64Lit ]

   PrimOp
Word8ToWordOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToWordLit
                                       , PrimOp -> Integer -> RuleM CoreExpr
extendNarrowPassthrough PrimOp
WordToWord8Op Integer
0xFF
                                       ]
   PrimOp
Word16ToWordOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToWordLit
                                       , PrimOp -> Integer -> RuleM CoreExpr
extendNarrowPassthrough PrimOp
WordToWord16Op Integer
0xFFFF
                                       ]
   PrimOp
Word32ToWordOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToWordLit
                                       , PrimOp -> Integer -> RuleM CoreExpr
extendNarrowPassthrough PrimOp
WordToWord32Op Integer
0xFFFFFFFF
                                       ]
   PrimOp
Word64ToWordOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform Platform -> Literal -> Literal
convertToWordLit ]

   PrimOp
WordToWord8Op  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowWord8Lit
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
WordAndOp PrimOp
WordToWord8Op ConTagZ
8 ]
   PrimOp
WordToWord16Op -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowWord16Lit
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
WordAndOp PrimOp
WordToWord16Op ConTagZ
16 ]
   PrimOp
WordToWord32Op -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowWord32Lit
                                       , PrimOp -> PrimOp -> ConTagZ -> RuleM CoreExpr
narrowSubsumesAnd PrimOp
WordAndOp PrimOp
WordToWord32Op ConTagZ
32 ]
   PrimOp
WordToWord64Op -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
narrowWord64Lit ]

   PrimOp
Word8ToInt8Op  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumInt8) ]
   PrimOp
Int8ToWord8Op  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumWord8) ]
   PrimOp
Word16ToInt16Op-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumInt16) ]
   PrimOp
Int16ToWord16Op-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumWord16) ]
   PrimOp
Word32ToInt32Op-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumInt32) ]
   PrimOp
Int32ToWord32Op-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumWord32) ]
   PrimOp
Word64ToInt64Op-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumInt64) ]
   PrimOp
Int64ToWord64Op-> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumWord64) ]

   PrimOp
WordToIntOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumInt) ]
   PrimOp
IntToWordOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumCoerce LitNumType
LitNumWord) ]

   PrimOp
Narrow8IntOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumNarrow LitNumType
LitNumInt8)
                                       , 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
IntAndOp PrimOp
Narrow8IntOp ConTagZ
8 ]
   PrimOp
Narrow16IntOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumNarrow LitNumType
LitNumInt16)
                                       , 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
IntAndOp PrimOp
Narrow16IntOp ConTagZ
16 ]
   PrimOp
Narrow32IntOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumNarrow LitNumType
LitNumInt32)
                                       , 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
IntAndOp PrimOp
Narrow32IntOp ConTagZ
32 ]
   PrimOp
Narrow8WordOp  -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumNarrow LitNumType
LitNumWord8)
                                       , 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
WordAndOp PrimOp
Narrow8WordOp ConTagZ
8 ]
   PrimOp
Narrow16WordOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumNarrow LitNumType
LitNumWord16)
                                       , 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
WordAndOp PrimOp
Narrow16WordOp ConTagZ
16 ]
   PrimOp
Narrow32WordOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Platform -> Literal -> Literal) -> RuleM CoreExpr
liftLitPlatform (LitNumType -> Platform -> Literal -> Literal
litNumNarrow LitNumType
LitNumWord32)
                                       , 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
WordAndOp PrimOp
Narrow32WordOp ConTagZ
32 ]

   PrimOp
CastWord64ToDoubleOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1
      [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit ((RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr)
-> (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ \RuleOpts
_env -> \case
         LitNumber LitNumType
_ Integer
n
             | Double
v <- Word64 -> Double
castWord64ToDouble (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
n)
             -- we can't represent those float literals in Core until #18897 is fixed
             , Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
v Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
v Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Double
v)
             -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble Double
v)
         Literal
_   -> Maybe CoreExpr
forall a. Maybe a
Nothing
      ]

   PrimOp
CastWord32ToFloatOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1
      [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit ((RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr)
-> (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ \RuleOpts
_env -> \case
          LitNumber LitNumType
_ Integer
n
              | Float
v <- Word32 -> Float
castWord32ToFloat (Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
n)
              -- we can't represent those float literals in Core until #18897 is fixed
              , Bool -> Bool
not (Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
v Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
v Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero Float
v)
              -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Float -> CoreExpr
forall b. Float -> Expr b
mkFloatLitFloat Float
v)
          Literal
_   -> Maybe CoreExpr
forall a. Maybe a
Nothing
      ]

   PrimOp
CastDoubleToWord64Op -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1
      [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit ((RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr)
-> (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ \RuleOpts
_env -> \case
         LitDouble Rational
n -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Word64 -> CoreExpr
forall b. Word64 -> Expr b
mkWord64LitWord64 (Double -> Word64
castDoubleToWord64 (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
n)))
         Literal
_           -> Maybe CoreExpr
forall a. Maybe a
Nothing
      ]

   PrimOp
CastFloatToWord32Op -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1
      [ (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit ((RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr)
-> (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ \RuleOpts
_env -> \case
          LitFloat Rational
n -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Word32 -> CoreExpr
forall b. Word32 -> Expr b
mkWord32LitWord32 (Float -> Word32
castFloatToWord32 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
n)))
          Literal
_          -> Maybe CoreExpr
forall a. Maybe a
Nothing
      ]

   PrimOp
OrdOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
charToIntLit
                                       , PrimOp -> RuleM CoreExpr
semiInversePrimOp PrimOp
ChrOp ]
   PrimOp
ChrOp          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ do [Lit lit] <- RuleM [CoreExpr]
getArgs
                                            guard (litFitsInChar lit)
                                            liftLit intToCharLit
                                       , PrimOp -> RuleM CoreExpr
semiInversePrimOp PrimOp
OrdOp ]
   PrimOp
FloatToIntOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
floatToIntLit ]
   PrimOp
IntToFloatOp    -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
intToFloatLit ]
   PrimOp
DoubleToIntOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
doubleToIntLit ]
   PrimOp
IntToDoubleOp   -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
intToDoubleLit ]
   -- SUP: Not sure what the standard says about precision in the following 2 cases
   PrimOp
FloatToDoubleOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
floatToDoubleLit ]
   PrimOp
DoubleToFloatOp -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
1 [ (Literal -> Literal) -> RuleM CoreExpr
liftLit Literal -> Literal
doubleToFloatLit ]

   -- 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  ]
   PrimOp
FloatFMAdd        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FMAdd  Width
W32)
   PrimOp
FloatFMSub        -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FMSub  Width
W32)
   PrimOp
FloatFNMAdd       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FNMAdd Width
W32)
   PrimOp
FloatFNMSub       -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FNMSub Width
W32)

             -- 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 a b. RuleM a -> RuleM b -> RuleM b
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
semiInversePrimOp 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  ]
   PrimOp
DoubleFMAdd          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FMAdd  Width
W64)
   PrimOp
DoubleFMSub          -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FMSub  Width
W64)
   PrimOp
DoubleFNMAdd         -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FNMAdd Width
W64)
   PrimOp
DoubleFNMSub         -> Name -> ConTagZ -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule Name
nm ConTagZ
3 (FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
FNMSub Width
W64)
              -- 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 a b. RuleM a -> RuleM b -> RuleM b
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
semiInversePrimOp 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, equality

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

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

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

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

   PrimOp
IntEqOp    -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=) [ Bool -> RuleM CoreExpr
litEq Bool
False ]

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

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

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

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

   PrimOp
WordEqOp   -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=) [ Bool -> RuleM CoreExpr
litEq Bool
False ]

   PrimOp
FloatEqOp  -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm a -> a -> Bool
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=)

   PrimOp
DoubleEqOp -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm a -> a -> Bool
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=)

   -- Relational operators, ordering

   PrimOp
Int8GtOp   -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Int8GeOp   -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Int8LeOp   -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Int8LtOp   -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
Int16GtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Int16GeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Int16LeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Int16LtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
Int32GtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Int32GeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Int32LeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Int32LtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
Int64GtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Int64GeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Int64LeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Int64LtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
IntGtOp    -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
Word8GtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Word8GeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Word8LeOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Word8LtOp  -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
Word16GtOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Word16GeOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Word16LeOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Word16LtOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
Word32GtOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Word32GeOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Word32LeOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Word32LtOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
Word64GtOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Gt ]
   PrimOp
Word64GeOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Ge ]
   PrimOp
Word64LeOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Le ]
   PrimOp
Word64LtOp -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)  [ Comparison -> RuleM CoreExpr
boundsCmp Comparison
Lt ]

   PrimOp
WordGtOp   -> Name
-> (forall a. Ord a => a -> a -> Bool)
-> [RuleM CoreExpr]
-> Maybe CoreRule
mkRelOpRule Name
nm a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)
   PrimOp
FloatGeOp  -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=)
   PrimOp
FloatLeOp  -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
   PrimOp
FloatLtOp  -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm 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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)
   PrimOp
DoubleGeOp -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=)
   PrimOp
DoubleLeOp -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
   PrimOp
DoubleLtOp -> Name -> (forall a. Ord a => a -> a -> Bool) -> Maybe CoreRule
mkFloatingRelOpRule Name
nm a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)

   -- Misc

   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 a -> a -> Bool
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 <- RuleM Platform
getPlatform
                    ; return (if cmp True True
                              then trueValInt  platform
                              else falseValInt 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 a -> a -> Bool
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

zeroI8, oneI8, zeroW8, oneW8 :: Literal
zeroI8 :: Literal
zeroI8 = Integer -> Literal
mkLitInt8  Integer
0
oneI8 :: Literal
oneI8  = Integer -> Literal
mkLitInt8  Integer
1
zeroW8 :: Literal
zeroW8 = Integer -> Literal
mkLitWord8 Integer
0
oneW8 :: Literal
oneW8  = Integer -> Literal
mkLitWord8 Integer
1

zeroI16, oneI16, zeroW16, oneW16 :: Literal
zeroI16 :: Literal
zeroI16 = Integer -> Literal
mkLitInt16  Integer
0
oneI16 :: Literal
oneI16  = Integer -> Literal
mkLitInt16  Integer
1
zeroW16 :: Literal
zeroW16 = Integer -> Literal
mkLitWord16 Integer
0
oneW16 :: Literal
oneW16  = Integer -> Literal
mkLitWord16 Integer
1

zeroI32, oneI32, zeroW32, oneW32 :: Literal
zeroI32 :: Literal
zeroI32 = Integer -> Literal
mkLitInt32  Integer
0
oneI32 :: Literal
oneI32  = Integer -> Literal
mkLitInt32  Integer
1
zeroW32 :: Literal
zeroW32 = Integer -> Literal
mkLitWord32 Integer
0
oneW32 :: Literal
oneW32  = Integer -> Literal
mkLitWord32 Integer
1

zeroI64, oneI64, zeroW64, oneW64 :: Literal
zeroI64 :: Literal
zeroI64 = Integer -> Literal
mkLitInt64  Integer
0
oneI64 :: Literal
oneI64  = Integer -> Literal
mkLitInt64  Integer
1
zeroW64 :: Literal
zeroW64 = Integer -> Literal
mkLitWord64 Integer
0
oneW64 :: Literal
oneW64  = Integer -> Literal
mkLitWord64 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

int8Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int8Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int8Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumInt8 Integer
i1) (LitNumber LitNumType
LitNumInt8 Integer
i2) =
  Integer -> Maybe CoreExpr
int8Result (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)
int8Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

int16Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int16Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int16Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumInt16 Integer
i1) (LitNumber LitNumType
LitNumInt16 Integer
i2) =
  Integer -> Maybe CoreExpr
int16Result (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)
int16Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

int32Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int32Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int32Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumInt32 Integer
i1) (LitNumber LitNumType
LitNumInt32 Integer
i2) =
  Integer -> Maybe CoreExpr
int32Result (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)
int32Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

int64Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int64Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
int64Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumInt64 Integer
i1) (LitNumber LitNumType
LitNumInt64 Integer
i2) =
  Integer -> Maybe CoreExpr
int64Result (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)
int64Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ 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) =
  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 :: forall t. (Integral t, Bits t) => Integer -> Int -> Integer
shiftRightLogical :: forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical Integer
x ConTagZ
n = t -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> t
forall a. Num a => Integer -> a
fromInteger Integer
x t -> ConTagZ -> t
forall a. Bits a => a -> ConTagZ -> a
`shiftR` ConTagZ
n :: t)

-- | Shift right, putting zeros in rather than sign-propagating as
-- 'Bits.shiftR' would do. Do this by converting to the appropriate Word
-- and back. Obviously this won't work for too-big values, but its ok as
-- we use it here.
shiftRightLogicalNative :: Platform -> Integer -> Int -> Integer
shiftRightLogicalNative :: Platform -> Integer -> ConTagZ -> Integer
shiftRightLogicalNative Platform
platform =
    case Platform -> PlatformWordSize
platformWordSize Platform
platform of
      PlatformWordSize
PW4 -> forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word32
      PlatformWordSize
PW8 -> forall t. (Integral t, Bits t) => Integer -> ConTagZ -> Integer
shiftRightLogical @Word64

--------------------------
retLit :: (Platform -> Literal) -> RuleM CoreExpr
retLit :: (Platform -> Literal) -> RuleM CoreExpr
retLit Platform -> Literal
l = do platform <- RuleM Platform
getPlatform
              return $ Lit $ l platform

retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr
retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr
retLitNoC Platform -> Literal
l = do platform <- RuleM Platform
getPlatform
                 let lit = Platform -> Literal
l Platform
platform
                 return $ mkCoreUnboxedTuple [Lit lit, Lit (zeroi platform)]

word8Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word8Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word8Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumWord8 Integer
i1) (LitNumber LitNumType
LitNumWord8 Integer
i2) =
  Integer -> Maybe CoreExpr
word8Result (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)
word8Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

word16Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word16Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word16Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumWord16 Integer
i1) (LitNumber LitNumType
LitNumWord16 Integer
i2) =
  Integer -> Maybe CoreExpr
word16Result (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)
word16Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

word32Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word32Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word32Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumWord32 Integer
i1) (LitNumber LitNumType
LitNumWord32 Integer
i2) =
  Integer -> Maybe CoreExpr
word32Result (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)
word32Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

word64Op2
  :: (Integral a, Integral b)
  => (a -> b -> Integer)
  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word64Op2 :: forall a b.
(Integral a, Integral b) =>
(a -> b -> Integer)
-> RuleOpts -> Literal -> Literal -> Maybe CoreExpr
word64Op2 a -> b -> Integer
op RuleOpts
_ (LitNumber LitNumType
LitNumWord64 Integer
i1) (LitNumber LitNumType
LitNumWord64 Integer
i2) =
  Integer -> Maybe CoreExpr
word64Result (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)
word64Op2 a -> b -> Integer
_ RuleOpts
_ Literal
_ Literal
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

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
          -> (Platform -> Integer -> Int -> Integer)
          -> RuleM CoreExpr
-- Shifts take an Int; hence third arg of op is Int
-- Used for shift primops
--    IntSllOp, IntSraOp, IntSrlOp :: 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 <- RuleM Platform
getPlatform
  [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs

  bit_size <- case litNumBitSize platform lit_num_ty of
   Maybe Word
Nothing -> RuleM Integer
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
   Just Word
bs -> Integer -> RuleM Integer
forall a. a -> RuleM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Integer
forall a. Integral a => a -> Integer
toInteger Word
bs)

  case e1 of
    CoreExpr
_ | Integer
shift_len Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
e1

      -- See Note [Guarding against silly shifts]
    CoreExpr
_ | 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
>= Integer
bit_size
      -> CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
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
$ 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.
           -- See #18589

    Lit (LitNumber LitNumType
nt Integer
x)
       | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
shift_len Bool -> Bool -> Bool
&& Integer
shift_len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
bit_size
       -> Bool -> RuleM CoreExpr -> RuleM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (LitNumType
nt LitNumType -> LitNumType -> Bool
forall a. Eq a => a -> a -> Bool
== LitNumType
lit_num_ty) (RuleM CoreExpr -> RuleM CoreExpr)
-> RuleM CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$
          let op :: Integer -> ConTagZ -> Integer
op = Platform -> Integer -> ConTagZ -> Integer
shift_op Platform
platform
              -- Do the shift at type Integer, but shift length is Int.
              -- Using host's Int is ok even if target's Int has a different size
              -- because we test that shift_len <= bit_size (which is at most 64)
              y :: Integer
y  = Integer
x Integer -> ConTagZ -> Integer
`op` Integer -> ConTagZ
forall a. Num a => Integer -> a
fromInteger Integer
shift_len
          in CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
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
$ Platform -> LitNumType -> Integer -> Literal
mkLitNumberWrap Platform
platform LitNumType
nt Integer
y

    CoreExpr
_ -> RuleM CoreExpr
forall a. RuleM a
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
$ [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [ 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
$ [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [ Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt64Wrap (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
doubleDecodeOp RuleOpts
_   Literal
_
  = Maybe CoreExpr
forall a. Maybe a
Nothing

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

-- | Constant folding rules for fused multiply-add operations.
fmaRules :: FMASign -> Width -> [RuleM CoreExpr]
fmaRules :: FMASign -> Width -> [RuleM CoreExpr]
fmaRules FMASign
signs Width
width =
     [ FMASign -> Width -> RuleM CoreExpr
fmaLit FMASign
signs Width
width
     , FMASign -> Width -> RuleM CoreExpr
fmaZero_z FMASign
signs Width
width
     , FMASign -> Width -> RuleM CoreExpr
fmaOne FMASign
signs Width
width ]

-- | Compute @a * b + c@ when @a@, @b@, @c@ are all literals.
fmaLit :: FMASign -> Width -> RuleM CoreExpr
fmaLit :: FMASign -> Width -> RuleM CoreExpr
fmaLit FMASign
signs Width
width = do
  env <- RuleM RuleOpts
getRuleOpts
  [Lit l1, Lit l2, Lit l3] <- getArgs
  liftMaybe $
    op env
      (convFloating env l1)
      (convFloating env l2)
      (convFloating env l3)

  where
    op :: RuleOpts -> Literal -> Literal -> Literal -> Maybe CoreExpr
op RuleOpts
env Literal
l1 Literal
l2 Literal
l3 =
      case Width
width of
        Width
W32
          | LitFloat Rational
x <- Literal
l1
          , LitFloat Rational
y <- Literal
l2
          , LitFloat Rational
z <- Literal
l3
          -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ RuleOpts -> Rational -> CoreExpr
mkFloatVal RuleOpts
env (Rational -> CoreExpr) -> Rational -> CoreExpr
forall a b. (a -> b) -> a -> b
$
            case FMASign
signs of
              FMASign
FMAdd  -> Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
z
              FMASign
FMSub  -> Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
z
              FMASign
FNMAdd -> Rational -> Rational
forall a. Num a => a -> a
negate ( Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y ) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
z
              FMASign
FNMSub -> Rational -> Rational
forall a. Num a => a -> a
negate ( Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y ) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
z
        Width
W64
          | LitDouble Rational
x <- Literal
l1
          , LitDouble Rational
y <- Literal
l2
          , LitDouble Rational
z <- Literal
l3
          -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ RuleOpts -> Rational -> CoreExpr
mkDoubleVal RuleOpts
env (Rational -> CoreExpr) -> Rational -> CoreExpr
forall a b. (a -> b) -> a -> b
$
            case FMASign
signs of
              FMASign
FMAdd  -> Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
z
              FMASign
FMSub  -> Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
z
              FMASign
FNMAdd -> Rational -> Rational
forall a. Num a => a -> a
negate ( Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y ) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
z
              FMASign
FNMSub -> Rational -> Rational
forall a. Num a => a -> a
negate ( Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y ) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
z
        Width
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing

-- | @x * y + 0 = x * y@.
fmaZero_z :: FMASign -> Width -> RuleM CoreExpr
fmaZero_z :: FMASign -> Width -> RuleM CoreExpr
fmaZero_z FMASign
signs Width
width = do
  [x, y, Lit z] <- RuleM [CoreExpr]
getArgs
  let
    -- TODO: we should additionally check the sign of z.
    -- FMAdd, FNMAdd: should be -0.0.
    -- FMSub, FNMSub: should be +0.0.
    ok =
      case Width
width of
        Width
W32
          | LitFloat Rational
0 <- Literal
z
          -> Bool
True
        Width
W64
          | LitDouble Rational
0 <- Literal
z
          -> Bool
True
        Width
_ -> Bool
False
    neg = case Width
width of
      Width
W32 ->  PrimOp
FloatNegOp
      Width
W64 -> PrimOp
DoubleNegOp
      Width
_   -> String -> PrimOp
forall a. HasCallStack => String -> a
panic String
"fmaZero_xy: not Float# or Double#"
    mul = case Width
width of
      Width
W32 ->  PrimOp
FloatMulOp
      Width
W64 -> PrimOp
DoubleMulOp
      Width
_   -> String -> PrimOp
forall a. HasCallStack => String -> a
panic String
"fmaZero_z: not Float# or Double#"
  if ok
  then return $ case signs of
    FMASign
FMAdd  -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
mul) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
y
    FMASign
FMSub  -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
mul) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
y
    FMASign
FNMAdd -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
neg) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` (Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
mul) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
y)
    FMASign
FNMSub -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
neg) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` (Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
mul) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
y)
  else mzero

-- | @±1 * y + z ==> z ± y@ and @x * ±1 + z ==> z ± x@.
fmaOne :: FMASign -> Width -> RuleM CoreExpr
fmaOne :: FMASign -> Width -> RuleM CoreExpr
fmaOne FMASign
signs Width
width = do
  [x, y, z] <- RuleM [CoreExpr]
getArgs
  let
    posNegOne_maybe :: Rational -> Maybe Bool
    posNegOne_maybe Rational
i
      | Rational
i Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
1
      = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      | Rational
i Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== -Rational
1
      = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      | Bool
otherwise
      = Maybe Bool
forall a. Maybe a
Nothing
    ok =
      case Width
width of
        Width
W32
          | Lit (LitFloat Rational
i) <- CoreExpr
x
          , Just Bool
sgn <- Rational -> Maybe Bool
posNegOne_maybe Rational
i
          -> (Bool, CoreExpr) -> Maybe (Bool, CoreExpr)
forall a. a -> Maybe a
Just (Bool
sgn, CoreExpr
y)
          | Lit (LitFloat Rational
i) <- CoreExpr
y
          , Just Bool
sgn <- Rational -> Maybe Bool
posNegOne_maybe Rational
i
          -> (Bool, CoreExpr) -> Maybe (Bool, CoreExpr)
forall a. a -> Maybe a
Just (Bool
sgn, CoreExpr
x)
        Width
W64
          | Lit (LitDouble Rational
i) <- CoreExpr
x
          , Just Bool
sgn <- Rational -> Maybe Bool
posNegOne_maybe Rational
i
          -> (Bool, CoreExpr) -> Maybe (Bool, CoreExpr)
forall a. a -> Maybe a
Just (Bool
sgn, CoreExpr
y)
          | Lit (LitDouble Rational
i) <- CoreExpr
y
          , Just Bool
sgn <- Rational -> Maybe Bool
posNegOne_maybe Rational
i
          -> (Bool, CoreExpr) -> Maybe (Bool, CoreExpr)
forall a. a -> Maybe a
Just (Bool
sgn, CoreExpr
x)
        Width
_ -> Maybe (Bool, CoreExpr)
forall a. Maybe a
Nothing
    neg = case Width
width of
      Width
W32 ->  PrimOp
FloatNegOp
      Width
W64 -> PrimOp
DoubleNegOp
      Width
_   -> String -> PrimOp
forall a. HasCallStack => String -> a
panic String
"fmaOne: not Float# or Double#"
    add = case Width
width of
      Width
W32 ->  PrimOp
FloatAddOp
      Width
W64 -> PrimOp
DoubleAddOp
      Width
_   -> String -> PrimOp
forall a. HasCallStack => String -> a
panic String
"fmaOne: not Float# or Double#"
    sub = case Width
width of
      Width
W32 ->  PrimOp
FloatSubOp
      Width
W64 -> PrimOp
DoubleSubOp
      Width
_   -> String -> PrimOp
forall a. HasCallStack => String -> a
panic String
"fmaOne: not Float# or Double#"
  case ok of
    Maybe (Bool, CoreExpr)
Nothing  -> RuleM CoreExpr
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Just (Bool
sgn, CoreExpr
t) -> CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$
      if -- t + z
         |  ( FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
==  FMASign
FMAdd Bool -> Bool -> Bool
&& Bool
sgn Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False )
         Bool -> Bool -> Bool
|| ( FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
== FMASign
FNMAdd Bool -> Bool -> Bool
&& Bool
sgn Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True  )
         -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
add) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
t CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
z
         -- - t + z
         |  FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
==  FMASign
FMAdd
         Bool -> Bool -> Bool
|| FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
== FMASign
FNMAdd
         -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
sub) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
z CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
t
         -- t - z
         |  ( FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
==  FMASign
FMSub Bool -> Bool -> Bool
&& Bool
sgn Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False )
         Bool -> Bool -> Bool
|| ( FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
== FMASign
FNMSub Bool -> Bool -> Bool
&& Bool
sgn Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True  )
         -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
sub) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
t CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
z
         -- - t - z
         |  FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
==  FMASign
FMSub
         Bool -> Bool -> Bool
|| FMASign
signs FMASign -> FMASign -> Bool
forall a. Eq a => a -> a -> Bool
== FMASign
FNMSub
         -> Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
neg) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` (Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
add) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
t CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
z)
         | Bool
otherwise
         -> String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"fmaOne: non-exhaustive pattern match" (SDoc -> CoreExpr) -> SDoc -> CoreExpr
forall a b. (a -> b) -> a -> b
$
              [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"signs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (FMASign -> String
forall a. Show a => a -> String
show FMASign
signs)
                   , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sign:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
sgn ]

--------------------------
{- 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 lit, expr] <- RuleM [CoreExpr]
getArgs
       platform <- getPlatform
       do_lit_eq platform lit expr
  , do [expr, Lit lit] <- RuleM [CoreExpr]
getArgs
       platform <- getPlatform
       do_lit_eq platform lit expr ]
  where
    do_lit_eq :: Platform -> Literal -> CoreExpr -> RuleM CoreExpr
do_lit_eq Platform
platform Literal
lit CoreExpr
expr = do
      Bool -> RuleM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Literal -> Bool
litIsLifted Literal
lit))
      CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
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 -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT      [] CoreExpr
val_if_neq
                    , AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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 <- RuleM Platform
getPlatform
  [a, b] <- getArgs
  liftMaybe $ mkRuleFn platform op a 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

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

int8Result' :: Integer -> CoreExpr
int8Result' :: Integer -> CoreExpr
int8Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt8Wrap Integer
result)

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

int16Result' :: Integer -> CoreExpr
int16Result' :: Integer -> CoreExpr
int16Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt16Wrap Integer
result)

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

int32Result' :: Integer -> CoreExpr
int32Result' :: Integer -> CoreExpr
int32Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt32Wrap Integer
result)

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
mkCoreUnboxedTuple [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
c])
  where
    (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
word8Result :: Integer -> Maybe CoreExpr
word8Result :: Integer -> Maybe CoreExpr
word8Result Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
word8Result' Integer
result)

word8Result' :: Integer -> CoreExpr
word8Result' :: Integer -> CoreExpr
word8Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord8Wrap Integer
result)

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

word16Result' :: Integer -> CoreExpr
word16Result' :: Integer -> CoreExpr
word16Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord16Wrap Integer
result)

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

word32Result' :: Integer -> CoreExpr
word32Result' :: Integer -> CoreExpr
word32Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord32Wrap Integer
result)

-- | 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
mkCoreUnboxedTuple [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
c])
  where
    (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

int64Result :: Integer -> Maybe CoreExpr
int64Result :: Integer -> Maybe CoreExpr
int64Result Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
int64Result' Integer
result)

int64Result' :: Integer -> CoreExpr
int64Result' :: Integer -> CoreExpr
int64Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt64Wrap Integer
result)

word64Result :: Integer -> Maybe CoreExpr
word64Result :: Integer -> Maybe CoreExpr
word64Result Integer
result = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
word64Result' Integer
result)

word64Result' :: Integer -> CoreExpr
word64Result' :: Integer -> CoreExpr
word64Result' Integer
result = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord64Wrap Integer
result)


-- | 'ambient (primop x) = x', but not necessarily 'primop (ambient x) = x'.
semiInversePrimOp :: PrimOp -> RuleM CoreExpr
semiInversePrimOp :: PrimOp -> RuleM CoreExpr
semiInversePrimOp PrimOp
primop = do
  [Var primop_id `App` e] <- RuleM [CoreExpr]
getArgs
  matchPrimOpId primop primop_id
  return e

subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
PrimOp
this subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
`subsumesPrimOp` PrimOp
that = do
  [Var primop_id `App` e] <- RuleM [CoreExpr]
getArgs
  matchPrimOpId that primop_id
  return (Var (primOpId this) `App` e)

subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
subsumedByPrimOp PrimOp
primop = do
  [e@(Var primop_id `App` _)] <- RuleM [CoreExpr]
getArgs
  matchPrimOpId primop primop_id
  return e

-- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF`
extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr
extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr
extendNarrowPassthrough PrimOp
narrow_primop Integer
n = do
  [Var primop_id `App` x] <- RuleM [CoreExpr]
getArgs
  matchPrimOpId narrow_primop primop_id
  return (Var (primOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n))

-- | 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 primop_id `App` x `App` y] <- RuleM [CoreExpr]
getArgs
  matchPrimOpId and_primop primop_id
  let 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 CoreExpr
v (Lit (LitNumber LitNumType
_ Integer
m)) = do
         Bool -> RuleM ()
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)
         CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
Var (PrimOp -> Id
primOpId PrimOp
narrw) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
v)
      g CoreExpr
_ CoreExpr
_ = RuleM CoreExpr
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  g x y <|> g y x

idempotent :: RuleM CoreExpr
idempotent :: RuleM CoreExpr
idempotent = do [e1, e2] <- RuleM [CoreExpr]
getArgs
                guard $ cheapEqExpr e1 e2
                return e1

-- | Match
--       (op (op v e) e)
--    or (op e (op v e))
--    or (op (op e v) e)
--    or (op e (op e v))
--  and return the innermost (op v e) or (op e v).
sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr
sameArgIdempotentCommut PrimOp
op = do
  [a,b] <- RuleM [CoreExpr]
getArgs
  case (a,b) of
    (PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop PrimOp
op -> Just (CoreExpr
e1,CoreExpr
e2), CoreExpr
e3)
      | CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
cheapEqExpr CoreExpr
e2 CoreExpr
e3 -> CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
a
      | CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
cheapEqExpr CoreExpr
e1 CoreExpr
e3 -> CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
a
    (CoreExpr
e3, PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop PrimOp
op -> Just (CoreExpr
e1,CoreExpr
e2))
      | CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
cheapEqExpr CoreExpr
e2 CoreExpr
e3 -> CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
b
      | CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
cheapEqExpr CoreExpr
e1 CoreExpr
e3 -> CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
b
    (CoreExpr, CoreExpr)
_ -> RuleM CoreExpr
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

{-
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-can-float invariant (see Note [Core let-can-float invariant] in
GHC.Core) as noted in #16742.  For the reasons discussed under
"NoEffect" in Note [Classifying primop effects] (in GHC.Builtin.PrimOps)
there is no safe way to rewrite the argument of I# such that it bottoms.

Consequently we instead take advantage of the fact that the result of a
large shift is unspecified (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 IntSll, 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 { 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
$cfmap :: forall a b. (a -> b) -> RuleM a -> RuleM b
fmap :: forall a b. (a -> b) -> RuleM a -> RuleM b
$c<$ :: forall a b. a -> RuleM b -> RuleM a
<$ :: forall a b. a -> RuleM b -> RuleM a
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 a. 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 a. 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
getRuleOpts

getWordSize :: RuleM PlatformWordSize
getWordSize :: RuleM PlatformWordSize
getWordSize = Platform -> PlatformWordSize
platformWordSize (Platform -> PlatformWordSize)
-> RuleM Platform -> RuleM PlatformWordSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RuleM Platform
getPlatform

getRuleOpts :: RuleM RuleOpts
getRuleOpts :: RuleM RuleOpts
getRuleOpts = (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
rule_opts InScopeEnv
_ Id
_ [CoreExpr]
_ -> RuleOpts -> Maybe RuleOpts
forall a. a -> Maybe a
Just RuleOpts
rule_opts

liftMaybe :: Maybe a -> RuleM a
liftMaybe :: forall a. Maybe a -> RuleM a
liftMaybe Maybe a
Nothing = RuleM a
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
liftMaybe (Just a
x) = a -> RuleM a
forall a. 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 <- RuleM Platform
getPlatform
  [Lit lit] <- getArgs
  return $ Lit (f platform lit)

removeOp32 :: RuleM CoreExpr
removeOp32 :: RuleM CoreExpr
removeOp32 = do
  platform <- RuleM Platform
getPlatform
  case platformWordSize platform of
    PlatformWordSize
PW4 -> do
      [e] <- RuleM [CoreExpr]
getArgs
      return e
    PlatformWordSize
PW8 ->
      RuleM CoreExpr
forall a. RuleM a
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
    env <- RuleM InScopeEnv
getInScopeEnv
    case exprIsLiteral_maybe env e of
        Maybe Literal
Nothing -> RuleM Literal
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Literal
l  -> Literal -> RuleM Literal
forall a. a -> RuleM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Literal
l

-- | Match BigNat#, Integer and Natural literals
isBignumLiteral :: CoreExpr -> RuleM Integer
isBignumLiteral :: CoreExpr -> RuleM Integer
isBignumLiteral CoreExpr
e = CoreExpr -> RuleM Integer
isNumberLiteral CoreExpr
e RuleM Integer -> RuleM Integer -> RuleM Integer
forall a. RuleM a -> RuleM a -> RuleM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
e RuleM Integer -> RuleM Integer -> RuleM Integer
forall a. RuleM a -> RuleM a -> RuleM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
e

-- | Match numeric literals
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 a b. RuleM a -> (a -> RuleM b) -> RuleM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  LitNumber LitNumType
_ Integer
x -> Integer -> RuleM Integer
forall a. a -> RuleM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  Literal
_             -> RuleM Integer
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Match the application of a DataCon to a numeric literal.
--
-- Can be used to match e.g.:
--  IS 123#
--  IP bigNatLiteral
--  W# 123##
isLitNumConApp :: CoreExpr -> RuleM (DataCon,Integer)
isLitNumConApp :: CoreExpr -> RuleM (DataCon, Integer)
isLitNumConApp CoreExpr
e = do
  env <- RuleM InScopeEnv
getInScopeEnv
  case exprIsConApp_maybe env e of
    Just (InScopeSet
_env,[FloatBind]
_fb,DataCon
dc,[Type]
_tys,[CoreExpr
arg]) -> case InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
arg of
      Just (LitNumber LitNumType
_ Integer
i) -> (DataCon, Integer) -> RuleM (DataCon, Integer)
forall a. a -> RuleM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataCon
dc,Integer
i)
      Maybe Literal
_                    -> RuleM (DataCon, Integer)
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
_ -> RuleM (DataCon, Integer)
forall a. RuleM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

isIntegerLiteral :: CoreExpr -> RuleM Integer
isIntegerLiteral :: CoreExpr -> RuleM Integer
isIntegerLiteral CoreExpr
e = do
  (dc,i) <- CoreExpr -> RuleM (DataCon, Integer)
isLitNumConApp CoreExpr
e
  if | dc == integerISDataCon -> pure i
     | dc == integerINDataCon -> pure (negate i)
     | dc == integerIPDataCon -> pure i
     | otherwise              -> mzero

isBigIntegerLiteral :: CoreExpr -> RuleM Integer
isBigIntegerLiteral :: CoreExpr -> RuleM Integer
isBigIntegerLiteral CoreExpr
e = do
  (dc,i) <- CoreExpr -> RuleM (DataCon, Integer)
isLitNumConApp CoreExpr
e
  if | dc == integerINDataCon -> pure (negate i)
     | dc == integerIPDataCon -> pure i
     | otherwise              -> mzero

isNaturalLiteral :: CoreExpr -> RuleM Integer
isNaturalLiteral :: CoreExpr -> RuleM Integer
isNaturalLiteral CoreExpr
e = do
  (dc,i) <- CoreExpr -> RuleM (DataCon, Integer)
isLitNumConApp CoreExpr
e
  if | dc == naturalNSDataCon -> pure i
     | dc == naturalNBDataCon -> pure i
     | otherwise              -> 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
  env <- RuleM RuleOpts
getRuleOpts
  [Lit l] <- getArgs
  liftMaybe $ op env (convFloating env 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
  env <- RuleM RuleOpts
getRuleOpts
  [Lit l1, Lit l2] <- getArgs
  liftMaybe $ op env (convFloating env l1) (convFloating env 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 <- RuleM Platform
getPlatform
  binaryLit (\RuleOpts
_ -> Platform
-> (forall a. Ord a => a -> a -> Bool)
-> Literal
-> Literal
-> Maybe CoreExpr
cmpOp Platform
platform a -> a -> Bool
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 a. RuleM a -> RuleM a -> RuleM a
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 <- RuleM Platform
getPlatform
  [Lit l1, e2] <- getArgs
  guard $ l1 == id_lit platform
  return 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 <- RuleM Platform
getPlatform
  [Lit l1, e2] <- getArgs
  guard $ l1 == id_lit platform
  let no_c = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Literal
zeroi Platform
platform)
  return (mkCoreUnboxedTuple [e2, no_c])

rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr
rightIdentityPlatform Platform -> Literal
id_lit = do
  platform <- RuleM Platform
getPlatform
  [e1, Lit l2] <- getArgs
  guard $ l2 == id_lit platform
  return 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 <- RuleM Platform
getPlatform
  [e1, Lit l2] <- getArgs
  guard $ l2 == id_lit platform
  let no_c = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Literal
zeroi Platform
platform)
  return (mkCoreUnboxedTuple [e1, 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 a. RuleM a -> RuleM a -> RuleM a
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 a. RuleM a -> RuleM a -> RuleM a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Platform -> Literal) -> RuleM CoreExpr
rightIdentityCPlatform Platform -> Literal
lit

leftZero :: RuleM CoreExpr
leftZero :: RuleM CoreExpr
leftZero = do
  [Lit l1, _] <- RuleM [CoreExpr]
getArgs
  guard $ isZeroLit l1
  return $ Lit l1

rightZero :: RuleM CoreExpr
rightZero :: RuleM CoreExpr
rightZero = do
  [_, Lit l2] <- RuleM [CoreExpr]
getArgs
  guard $ isZeroLit l2
  return $ Lit l2

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

equalArgs :: RuleM ()
equalArgs :: RuleM ()
equalArgs = do
  [e1, e2] <- RuleM [CoreExpr]
getArgs
  guard $ e1 `cheapEqExpr` e2

nonZeroLit :: Int -> RuleM ()
nonZeroLit :: ConTagZ -> RuleM ()
nonZeroLit ConTagZ
n = ConTagZ -> RuleM Literal
getLiteral ConTagZ
n RuleM Literal -> (Literal -> RuleM ()) -> RuleM ()
forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
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

oneLit :: Int -> RuleM ()
oneLit :: ConTagZ -> RuleM ()
oneLit ConTagZ
n = ConTagZ -> RuleM Literal
getLiteral ConTagZ
n RuleM Literal -> (Literal -> RuleM ()) -> RuleM ()
forall a b. RuleM a -> (a -> RuleM b) -> RuleM b
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
. Literal -> Bool
isOneLit

lift_bits_op :: forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr
lift_bits_op :: forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr
lift_bits_op a -> Integer
op = do
  platform <- RuleM Platform
getPlatform
  [Lit (LitNumber _ l)] <- getArgs
  pure $ mkWordLit platform $ op (fromInteger l :: a)

pop_count :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
pop_count = forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr
lift_bits_op @a (ConTagZ -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConTagZ -> Integer) -> (a -> ConTagZ) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ConTagZ
forall a. Bits a => a -> ConTagZ
popCount)

ctz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
ctz = forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr
lift_bits_op @a (ConTagZ -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConTagZ -> Integer) -> (a -> ConTagZ) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ConTagZ
forall b. FiniteBits b => b -> ConTagZ
countTrailingZeros)

clz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr
clz = forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr
lift_bits_op @a (ConTagZ -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConTagZ -> Integer) -> (a -> ConTagZ) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ConTagZ
forall b. FiniteBits b => b -> ConTagZ
countLeadingZeros)

-- 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 f1), Lit (LitFloat f2)] <- RuleM [CoreExpr]
getArgs
  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
       && f2 /= 0            -- avoid NaN and Infinity/-Infinity

guardDoubleDiv :: RuleM ()
guardDoubleDiv :: RuleM ()
guardDoubleDiv = do
  [Lit (LitDouble d1), Lit (LitDouble d2)] <- RuleM [CoreExpr]
getArgs
  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
       && d2 /= 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]
  arg <- [RuleM CoreExpr] -> RuleM CoreExpr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ do [arg, Lit mult_lit] <- RuleM [CoreExpr]
getArgs
                   guard (mult_lit == two_lit)
                   return arg
              , do [Lit mult_lit, arg] <- RuleM [CoreExpr]
getArgs
                   guard (mult_lit == two_lit)
                   return arg ]
  return $ Var (primOpId add_op) `App` arg `App` 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
  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
  guard $ op == 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 ty, Lit (LitNumber LitNumInt i)] <- RuleM [CoreExpr]
getArgs
  case splitTyConApp_maybe 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
      (dc:rest) <- [DataCon] -> RuleM [DataCon]
forall a. a -> RuleM a
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` [])
      massert (null rest)
      return $ mkTyApps (Var (dataConWorkId dc)) tc_args

    -- See Note [tagToEnum#]
    Maybe (TyCon, [Type])
_ -> Bool -> String -> SDoc -> RuleM CoreExpr -> RuleM CoreExpr
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"tagToEnum# on non-enumeration type" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) (RuleM CoreExpr -> RuleM CoreExpr)
-> RuleM CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$
         CoreExpr -> RuleM CoreExpr
forall a. a -> RuleM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> RuleM CoreExpr) -> CoreExpr -> RuleM CoreExpr
forall a b. (a -> b) -> a -> b
$ Type -> String -> CoreExpr
mkImpossibleExpr Type
ty String
"tagToEnum# on non-enumeration type"

------------------------------
dataToTagRule :: RuleM CoreExpr
-- Used for both dataToTagSmall# and dataToTagLarge#.
-- See Note [DataToTag overview] in GHC.Tc.Instance.Class,
-- particularly wrinkle DTW5.
dataToTagRule :: RuleM CoreExpr
dataToTagRule = RuleM CoreExpr
a RuleM CoreExpr -> RuleM CoreExpr -> RuleM CoreExpr
forall a. RuleM a -> RuleM a -> RuleM a
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 _lev, Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- RuleM [CoreExpr]
getArgs
      guard $ tag_to_enum `hasKey` tagToEnumKey
      guard $ ty1 `eqType` ty2
      return 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 <- RuleM Platform
getPlatform
      [_lev, _ty, val_arg] <- getArgs
      in_scope <- getInScopeEnv
      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
      massert (not (isNewTyCon (dataConTyCon dc)))
      return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc)))


{- *********************************************************************
*                                                                      *
             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 rep, Type t1, Type t2] <- RuleM [CoreExpr]
getArgs
       ; guard (t1 `eqType` t2)
       ; fn <- getFunction
       ; let (_, ue) = splitForAllTyCoVars (idType fn)
             tc      = HasDebugCallStack => Type -> TyCon
Type -> TyCon
tyConAppTyCon Type
ue  -- tycon:    UnsafeEquality
             (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl
             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).
             --               UnsafeEquality r a a
       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, 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#

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

- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a
  properly-tagged pointer inside of its unboxed-tuple result.
-}

seqRule :: RuleM CoreExpr
seqRule :: RuleM CoreExpr
seqRule = do
  [Type _ty_a, Type _ty_s, a, s] <- RuleM [CoreExpr]
getArgs
  guard $ exprIsHNF a
  return $ mkCoreUnboxedTuple [s, 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.
-}

builtinRules :: [CoreRule]
-- Rules for non-primops that can't be expressed using a RULE pragma
builtinRules :: [CoreRule]
builtinRules
  = [BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"CStringFoldrLit",
                   ru_fn :: Name
ru_fn = Name
unpackCStringFoldrName,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
4, ru_try :: RuleFun
ru_try = RuleFun
match_cstring_foldr_lit_C },
     BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"CStringFoldrLitUtf8",
                   ru_fn :: Name
ru_fn = Name
unpackCStringFoldrUtf8Name,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
4, ru_try :: RuleFun
ru_try = RuleFun
match_cstring_foldr_lit_utf8 },
     BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"CStringAppendLit",
                   ru_fn :: Name
ru_fn = Name
unpackCStringAppendName,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
2, ru_try :: RuleFun
ru_try = RuleFun
match_cstring_append_lit_C },
     BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"CStringAppendLitUtf8",
                   ru_fn :: Name
ru_fn = Name
unpackCStringAppendUtf8Name,
                   ru_nargs :: ConTagZ
ru_nargs = ConTagZ
2, ru_try :: RuleFun
ru_try = RuleFun
match_cstring_append_lit_utf8 },
     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 { 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 { 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 },

     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 a b. RuleM a -> RuleM b -> RuleM b
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)
        , RuleM CoreExpr
leftZero
        , do
          [arg, Lit (LitNumber LitNumInt d)] <- RuleM [CoreExpr]
getArgs
          Just n <- return $ exactLog2 d
          platform <- getPlatform
          return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform 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 a b. RuleM a -> RuleM b -> RuleM b
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)
        , RuleM CoreExpr
leftZero
        , do
          [arg, Lit (LitNumber LitNumInt d)] <- RuleM [CoreExpr]
getArgs
          Just _ <- return $ exactLog2 d
          platform <- getPlatform
          return $ Var (primOpId IntAndOp)
            `App` arg `App` mkIntVal platform (d - 1)
        ]
     ]
 [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
builtinBignumRules
{-# 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 :: [CoreRule]
builtinBignumRules :: [CoreRule]
builtinBignumRules =
  [ -- 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
natural_to_word String
"Natural -> Word# (wrap)"  Name
naturalToWordName

    -- comparisons (return an unlifted Int#)
  , String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
bignum_bin_pred String
"bigNatEq#"  Name
bignatEqName Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==)

    -- comparisons (return an Ordering)
  , String -> Name -> CoreRule
bignum_compare String
"bignatCompare"      Name
bignatCompareName
  , String -> Name -> CoreRule
bignum_compare String
"bignatCompareWord#" Name
bignatCompareWordName

    -- 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
        [a0,a1] <- RuleM [CoreExpr]
getArgs
        x <- isNaturalLiteral a0
        y <- isNaturalLiteral a1
        -- return an unboxed sum: (# (# #) | Natural #)
        let ret ConTagZ
n CoreExpr
v = CoreExpr -> f CoreExpr
forall a. a -> f a
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
mkCoreUnboxedSum ConTagZ
2 ConTagZ
n [Type
unboxedUnitTy,Type
naturalTy] CoreExpr
v
        platform <- getPlatform
        if x < y
            then ret 1 unboxedUnitExpr
            else ret 2 $ mkNaturalExpr platform (x - y)

    -- unary operations
  , String
-> Name
-> (Platform -> Integer -> CoreExpr)
-> (Integer -> Integer)
-> CoreRule
forall {t}.
String
-> Name
-> (Platform -> t -> CoreExpr)
-> (Integer -> t)
-> CoreRule
bignum_unop String
"integerNegate"     Name
integerNegateName     Platform -> Integer -> CoreExpr
mkIntegerExpr Integer -> Integer
forall a. Num a => a -> a
negate
  , String
-> Name
-> (Platform -> Integer -> CoreExpr)
-> (Integer -> Integer)
-> CoreRule
forall {t}.
String
-> Name
-> (Platform -> t -> CoreExpr)
-> (Integer -> t)
-> CoreRule
bignum_unop String
"integerAbs"        Name
integerAbsName        Platform -> Integer -> CoreExpr
mkIntegerExpr Integer -> Integer
forall a. Num a => a -> a
abs
  , String
-> Name
-> (Platform -> Integer -> CoreExpr)
-> (Integer -> Integer)
-> CoreRule
forall {t}.
String
-> Name
-> (Platform -> t -> CoreExpr)
-> (Integer -> t)
-> CoreRule
bignum_unop String
"integerComplement" Name
integerComplementName Platform -> Integer -> CoreExpr
mkIntegerExpr Integer -> Integer
forall a. Bits a => a -> a
complement

  , 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

    -- Bits.bit
  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
forall {t}.
Bits t =>
String -> Name -> (Platform -> t -> CoreExpr) -> CoreRule
bignum_bit String
"integerBit" Name
integerBitName Platform -> Integer -> CoreExpr
mkIntegerExpr
  , String -> Name -> (Platform -> Integer -> CoreExpr) -> CoreRule
forall {t}.
Bits t =>
String -> Name -> (Platform -> t -> CoreExpr) -> CoreRule
bignum_bit String
"naturalBit" Name
naturalBitName Platform -> Integer -> CoreExpr
mkNaturalExpr

    -- 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)
-> (Platform -> Integer -> CoreExpr)
-> CoreRule
forall {t} {t}.
Num t =>
String
-> Name
-> (Integer -> t -> t)
-> (Platform -> t -> CoreExpr)
-> CoreRule
bignum_shift String
"integerShiftL" Name
integerShiftLName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL Platform -> Integer -> CoreExpr
mkIntegerExpr
  , String
-> Name
-> (Integer -> ConTagZ -> Integer)
-> (Platform -> Integer -> CoreExpr)
-> CoreRule
forall {t} {t}.
Num t =>
String
-> Name
-> (Integer -> t -> t)
-> (Platform -> t -> CoreExpr)
-> CoreRule
bignum_shift String
"integerShiftR" Name
integerShiftRName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR Platform -> Integer -> CoreExpr
mkIntegerExpr
  , String
-> Name
-> (Integer -> ConTagZ -> Integer)
-> (Platform -> Integer -> CoreExpr)
-> CoreRule
forall {t} {t}.
Num t =>
String
-> Name
-> (Integer -> t -> t)
-> (Platform -> t -> CoreExpr)
-> CoreRule
bignum_shift String
"naturalShiftL" Name
naturalShiftLName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftL Platform -> Integer -> CoreExpr
mkNaturalExpr
  , String
-> Name
-> (Integer -> ConTagZ -> Integer)
-> (Platform -> Integer -> CoreExpr)
-> CoreRule
forall {t} {t}.
Num t =>
String
-> Name
-> (Integer -> t -> t)
-> (Platform -> t -> CoreExpr)
-> CoreRule
bignum_shift String
"naturalShiftR" Name
naturalShiftRName Integer -> ConTagZ -> Integer
forall a. Bits a => a -> ConTagZ -> a
shiftR Platform -> Integer -> CoreExpr
mkNaturalExpr

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

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

    -- 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
    mkRule :: String -> Name -> ConTagZ -> RuleM CoreExpr -> CoreRule
mkRule String
str Name
name ConTagZ
nargs RuleM CoreExpr
f = 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 -> RuleFun) -> RuleM CoreExpr -> RuleFun
forall a b. (a -> b) -> a -> b
$ do
          env <- RuleM RuleOpts
getRuleOpts
          guard (roBignumRules env)
          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
      [a0] <- RuleM [CoreExpr]
getArgs
      platform <- getPlatform
      -- we only match on Big Integer literals. Small literals
      -- are matched by the "Int# -> Integer -> *" rules
      x <- isBigIntegerLiteral a0
      pure (convert platform x)

    natural_to_word :: String -> Name -> CoreRule
natural_to_word 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
      [a0] <- RuleM [CoreExpr]
getArgs
      n <- isNaturalLiteral a0
      platform <- getPlatform
      pure (Lit (mkLitWordWrap platform 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
      [a0] <- RuleM [CoreExpr]
getArgs
      x <- isIntegerLiteral a0
      platform <- getPlatform
      if | x >= 0    -> pure $ mkNaturalExpr platform x
         | thrw      -> mzero
         | clamp     -> pure $ mkNaturalExpr platform 0       -- clamp to 0
         | otherwise -> pure $ mkNaturalExpr platform (abs 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
      [a0] <- RuleM [CoreExpr]
getArgs
      platform <- getPlatform
      i <- isBignumLiteral a0
      -- convert any numeric literal into an Integer literal
      pure (mkIntegerExpr platform i)

    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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      x <- isIntegerLiteral a0
      y <- isIntegerLiteral a1
      platform <- getPlatform
      pure (mkIntegerExpr platform (x `op` 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      x <- isNaturalLiteral a0
      y <- isNaturalLiteral a1
      platform <- getPlatform
      pure (mkNaturalExpr platform (x `op` 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      x <- isNaturalLiteral a0
      y <- isNaturalLiteral a1
      guard (x >= y)
      platform <- getPlatform
      pure (mkNaturalExpr platform (x - y))

    bignum_bin_pred :: String -> Name -> (Integer -> Integer -> Bool) -> CoreRule
bignum_bin_pred 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 <- RuleM Platform
getPlatform
      [a0,a1] <- getArgs
      x <- isBignumLiteral a0
      y <- isBignumLiteral a1
      pure $ if x `op` y
              then trueValInt platform
              else falseValInt 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      x <- isBignumLiteral a0
      y <- isBignumLiteral a1
      pure $ case x `compare` y of
              Ordering
LT -> CoreExpr
ltVal
              Ordering
EQ -> CoreExpr
eqVal
              Ordering
GT -> CoreExpr
gtVal

    bignum_unop :: String
-> Name
-> (Platform -> t -> CoreExpr)
-> (Integer -> t)
-> CoreRule
bignum_unop String
str Name
name Platform -> t -> CoreExpr
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
      [a0] <- RuleM [CoreExpr]
getArgs
      x <- isBignumLiteral a0
      platform <- getPlatform
      pure $ mk_lit platform (op 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 <- 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.
      guard (platformWordSizeInBits platform <= finiteBitSize (0 :: Word))
      [a0] <- getArgs
      x <- isBignumLiteral a0
      pure $ Lit (mk_lit platform (fromIntegral (popCount x)))

    bignum_bit :: String -> Name -> (Platform -> t -> CoreExpr) -> CoreRule
bignum_bit String
str Name
name Platform -> t -> CoreExpr
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
      [a0] <- RuleM [CoreExpr]
getArgs
      platform <- getPlatform
      n <- isNumberLiteral 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)
      guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits 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).
      pure $ mk_lit platform (bit (fromIntegral 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      platform <- getPlatform
      x <- isBignumLiteral a0
      n <- isNumberLiteral a1
      -- ensure that we can store 'n' in a host Int
      guard (n >= 0 && n <= fromIntegral (maxBound :: Int))
      pure $ if testBit x (fromIntegral n)
              then trueValInt platform
              else falseValInt platform

    bignum_shift :: String
-> Name
-> (Integer -> t -> t)
-> (Platform -> t -> CoreExpr)
-> CoreRule
bignum_shift String
str Name
name Integer -> t -> t
shift_op Platform -> t -> 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      x <- isBignumLiteral a0
      n <- isNumberLiteral 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)
      guard (n <= 4)
      platform <- getPlatform
      pure $ mk_lit platform (x `shift_op` fromIntegral n)

    divop_one :: String
-> Name
-> (Integer -> Integer -> t)
-> (Platform -> t -> CoreExpr)
-> CoreRule
divop_one String
str Name
name Integer -> Integer -> t
divop Platform -> t -> 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      n <- isBignumLiteral a0
      d <- isBignumLiteral a1
      guard (d /= 0)
      platform <- getPlatform
      pure $ mk_lit platform (n `divop` d)

    divop_both :: String
-> Name
-> (Integer -> Integer -> (t, t))
-> (Platform -> t -> CoreExpr)
-> CoreRule
divop_both String
str Name
name Integer -> Integer -> (t, t)
divop Platform -> t -> 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      n <- isBignumLiteral a0
      d <- isBignumLiteral a1
      guard (d /= 0)
      let (r,s) = n `divop` d
      platform <- getPlatform
      pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform 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
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      x <- isIntegerLiteral a0
      y <- isNumberLiteral a1
      -- check that y (a target Int) is in the host Int range
      guard (y <= fromIntegral (maxBound :: Int))
      pure (mk_lit $ encodeFloat x (fromInteger 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).
      [a0,a1] <- RuleM [CoreExpr]
getArgs
      n <- isIntegerLiteral a0
      d <- isIntegerLiteral 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
      guard (d /= 0)
      pure $ mk_lit (fromRational (n % d))


---------------------------------------------------
-- The rules are:
--      unpackAppendCString*# "foo"# (unpackCString*# "baz"#)
--      =  unpackCString*# "foobaz"#
--
--      unpackAppendCString*# "foo"# (unpackAppendCString*# "baz"# e)
--      =  unpackAppendCString*# "foobaz"# e
--

-- CString version
match_cstring_append_lit_C :: RuleFun
match_cstring_append_lit_C :: RuleFun
match_cstring_append_lit_C = Unique -> Unique -> RuleFun
match_cstring_append_lit Unique
unpackCStringAppendIdKey Unique
unpackCStringIdKey

-- CStringUTF8 version
match_cstring_append_lit_utf8 :: RuleFun
match_cstring_append_lit_utf8 :: RuleFun
match_cstring_append_lit_utf8 = Unique -> Unique -> RuleFun
match_cstring_append_lit Unique
unpackCStringAppendUtf8IdKey Unique
unpackCStringUtf8IdKey

{-# INLINE match_cstring_append_lit #-}
match_cstring_append_lit :: Unique -> Unique -> RuleFun
match_cstring_append_lit :: Unique -> Unique -> RuleFun
match_cstring_append_lit Unique
append_key Unique
unpack_key RuleOpts
_ InScopeEnv
env Id
_ [CoreExpr
lit1, CoreExpr
e2]
  | Just (LitString ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
lit1
  , ([CoreTickish]
strTicks, Var Id
unpk `App` CoreExpr
lit2) <- InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks InScopeEnv
env CoreExpr
e2
  , Id
unpk Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpack_key
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
lit2
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
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` Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (ByteString
s1 ByteString -> ByteString -> ByteString
`BS.append` ByteString
s2))

  | Just (LitString ByteString
s1) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
lit1
  , ([CoreTickish]
strTicks, Var Id
appnd `App` CoreExpr
lit2 `App` CoreExpr
e) <- InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks InScopeEnv
env CoreExpr
e2
  , Id
appnd Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
append_key
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
lit2
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
strTicks
         (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
Var Id
appnd CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (ByteString
s1 ByteString -> ByteString -> ByteString
`BS.append` ByteString
s2)) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e

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

---------------------------------------------------
-- 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_cstring_foldr_lit_C :: RuleFun
match_cstring_foldr_lit_C :: RuleFun
match_cstring_foldr_lit_C = Unique -> RuleFun
match_cstring_foldr_lit Unique
unpackCStringFoldrIdKey

-- CStringUTF8 version
match_cstring_foldr_lit_utf8 :: RuleFun
match_cstring_foldr_lit_utf8 :: RuleFun
match_cstring_foldr_lit_utf8 = Unique -> RuleFun
match_cstring_foldr_lit Unique
unpackCStringFoldrUtf8IdKey

{-# INLINE match_cstring_foldr_lit #-}
match_cstring_foldr_lit :: Unique -> RuleFun
match_cstring_foldr_lit :: Unique -> RuleFun
match_cstring_foldr_lit Unique
foldVariant RuleOpts
_ InScopeEnv
env Id
_
        [ Type Type
ty1
        , CoreExpr
lit1
        , CoreExpr
c1
        , CoreExpr
e2
        ]
  | ([CoreTickish]
strTicks, Var Id
unpk `App` Type Type
ty2
                        `App` CoreExpr
lit2
                        `App` CoreExpr
c2
                        `App` CoreExpr
n) <- InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks InScopeEnv
env 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
env CoreExpr
lit1
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
lit2
  , CoreExpr -> CoreExpr -> Bool
eqCoreExpr CoreExpr
c1 CoreExpr
c2
  , ([CoreTickish]
c1Ticks, CoreExpr
c1') <- InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks InScopeEnv
env CoreExpr
c1
  , [CoreTickish]
c2Ticks <- CoreExpr -> [CoreTickish]
stripStrTopTicksT CoreExpr
c2
  = Bool -> Maybe CoreExpr -> Maybe CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$
    CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
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` [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks ([CoreTickish]
c1Ticks [CoreTickish] -> [CoreTickish] -> [CoreTickish]
forall a. [a] -> [a] -> [a]
++ [CoreTickish]
c2Ticks) CoreExpr
c1'
                    CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
n

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


-- N.B. Ensure that we strip off any ticks (e.g. source notes) from the
-- argument, lest this may fail to fire when building with -g3. See #16740.
--
-- Also, look into variable's unfolding just in case the expression we look for
-- is in a top-level thunk.
stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks (ISE InScopeSet
_ IdUnfoldingFun
id_unf) CoreExpr
e = case CoreExpr
e of
  Var Id
v
    | Just CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
v)
    -> (CoreTickish -> Bool) -> CoreExpr -> ([CoreTickish], CoreExpr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
rhs
  CoreExpr
_ -> (CoreTickish -> Bool) -> CoreExpr -> ([CoreTickish], CoreExpr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
e

stripStrTopTicksT :: CoreExpr -> [CoreTickish]
stripStrTopTicksT :: CoreExpr -> [CoreTickish]
stripStrTopTicksT CoreExpr
e = (CoreTickish -> Bool) -> CoreExpr -> [CoreTickish]
forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksTopT CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
e

---------------------------------------------------
-- 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
env Id
_ [CoreExpr
e1, CoreExpr
e2]
  | ([CoreTickish]
ticks1, Var Id
unpk1 `App` CoreExpr
lit1) <- InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks InScopeEnv
env CoreExpr
e1
  , ([CoreTickish]
ticks2, Var Id
unpk2 `App` CoreExpr
lit2) <- InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
stripStrTopTicks InScopeEnv
env CoreExpr
e2
  , 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 a. Eq a => a -> [a] -> 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
env CoreExpr
lit1
  , Just (LitString ByteString
s2) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env CoreExpr
lit2
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks ([CoreTickish]
ticks1 [CoreTickish] -> [CoreTickish] -> [CoreTickish]
forall a. [a] -> [a] -> [a]
++ [CoreTickish]
ticks2)
         (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (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
rule_env InScopeEnv
env Id
_ [CoreExpr
lit1]
  | Just (LitString ByteString
str) <- InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env 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
rule_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 (IdUnfoldingFun
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

--------------------------------------------------------
-- 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) *, `and`, `or`  simplification
--    ops = *, `and`, `or` 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]

addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
addFoldingRules PrimOp
op NumOps
num_ops = do
   Bool -> RuleM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== NumOps -> PrimOp
numAdd NumOps
num_ops)
   env <- RuleM RuleOpts
getRuleOpts
   guard (roNumConstantFolding env)
   [arg1,arg2] <- getArgs
   platform <- getPlatform
   liftMaybe
      -- commutativity for + is handled here
      (addFoldingRules' platform arg1 arg2 num_ops
       <|> addFoldingRules' platform arg2 arg1 num_ops)

subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
subFoldingRules PrimOp
op NumOps
num_ops = do
   Bool -> RuleM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== NumOps -> PrimOp
numSub NumOps
num_ops)
   env <- RuleM RuleOpts
getRuleOpts
   guard (roNumConstantFolding env)
   [arg1,arg2] <- getArgs
   platform <- getPlatform
   liftMaybe (subFoldingRules' platform arg1 arg2 num_ops)

mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr
mulFoldingRules PrimOp
op NumOps
num_ops = do
   Bool -> RuleM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== NumOps -> PrimOp
numMul NumOps
num_ops)
   env <- RuleM RuleOpts
getRuleOpts
   guard (roNumConstantFolding env)
   [arg1,arg2] <- getArgs
   platform <- getPlatform
   liftMaybe
      -- commutativity for * is handled here
      (mulFoldingRules' platform arg1 arg2 num_ops
       <|> mulFoldingRules' platform arg2 arg1 num_ops)

andFoldingRules :: NumOps -> RuleM CoreExpr
andFoldingRules :: NumOps -> RuleM CoreExpr
andFoldingRules NumOps
num_ops = do
   env <- RuleM RuleOpts
getRuleOpts
   guard (roNumConstantFolding env)
   [arg1,arg2] <- getArgs
   platform <- getPlatform
   liftMaybe
      -- commutativity for `and` is handled here
      (andFoldingRules' platform arg1 arg2 num_ops
       <|> andFoldingRules' platform arg2 arg1 num_ops)

orFoldingRules :: NumOps -> RuleM CoreExpr
orFoldingRules :: NumOps -> RuleM CoreExpr
orFoldingRules NumOps
num_ops = do
   env <- RuleM RuleOpts
getRuleOpts
   guard (roNumConstantFolding env)
   [arg1,arg2] <- getArgs
   platform <- getPlatform
   liftMaybe
      -- commutativity for `or` is handled here
      (orFoldingRules' platform arg1 arg2 num_ops
       <|> orFoldingRules' platform arg2 arg1 num_ops)

quotFoldingRules :: NumOps -> RuleM CoreExpr
quotFoldingRules :: NumOps -> RuleM CoreExpr
quotFoldingRules NumOps
num_ops = do
   env <- RuleM RuleOpts
getRuleOpts
   guard (roNumConstantFolding env)
   [arg1,arg2] <- getArgs
   platform <- getPlatform
   liftMaybe (quotFoldingRules' platform arg1 arg2 num_ops)

addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
addFoldingRules' Platform
platform CoreExpr
arg1 CoreExpr
arg2 NumOps
num_ops = case (CoreExpr
arg1, CoreExpr
arg2) of

      -- x + (-y) ==> x-y
      (CoreExpr
x, NumOps -> CoreExpr -> Maybe CoreExpr
is_neg NumOps
num_ops -> Just CoreExpr
y)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y)

      -- R1) +/- simplification

      -- l1 + (l2 + x) ==> (l1+l2) + x
      (L Integer
l1, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l2,CoreExpr
x))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
x)

      -- l1 + (l2 - x) ==> (l1+l2) - x
      (L Integer
l1, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
x))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
x)

      -- l1 + (x - l2) ==> (l1-l2) + x
      (L Integer
l1, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x,L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
x)

      -- (l1 + x) + (l2 + y) ==> (l1+l2) + (x+y)
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- (l1 + x) + (l2 - y) ==> (l1+l2) + (x-y)
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y))

      -- (l1 + x) + (y - l2) ==> (l1-l2) + (x+y)
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- (l1 - x) + (l2 - y) ==> (l1+l2) - (x+y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- (l1 - x) + (y - l2) ==> (l1-l2) + (y-x)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
y CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
x))

      -- (x - l1) + (y - l2) ==> (0-l1-l2) + (x+y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x,L Integer
l1), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- R4) Simple factorization

      -- x + x ==> 2 * x
      (CoreExpr, CoreExpr)
_ | Just Integer
l1 <- NumOps -> CoreExpr -> CoreExpr -> Maybe Integer
is_expr_mul NumOps
num_ops CoreExpr
arg1 CoreExpr
arg2
        -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
arg1)

      -- (l1 * x) + x ==> (l1+1) * x
      (CoreExpr, CoreExpr)
_ | Just Integer
l1 <- NumOps -> CoreExpr -> CoreExpr -> Maybe Integer
is_expr_mul NumOps
num_ops CoreExpr
arg2 CoreExpr
arg1
        -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
arg2)

      -- (l1 * x) + (l2 * x) ==> (l1+l2) * x
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_mul NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> CoreExpr -> Maybe Integer
is_expr_mul NumOps
num_ops CoreExpr
x -> Just Integer
l2)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
x)

      -- R5) +/- propagation: these transformations push literals outwards
      -- with the hope that other rules can then be applied.

      -- In the following rules, x can't be a literal otherwise another
      -- rule would have combined it with the other literal in arg2. So we
      -- don't have to check this to avoid loops here.

      -- x + (l1 + y) ==> l1 + (x + y)
      (CoreExpr
_, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL Integer
l1 CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- x + (l1 - y) ==> l1 + (x - y)
      (CoreExpr
_, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL Integer
l1 CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y))

      -- x + (y - l1) ==> (x + y) - l1
      (CoreExpr
_, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l1))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ((CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
l1)

      (CoreExpr, CoreExpr)
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing

   where
      mkL :: Integer -> CoreExpr
mkL = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr)
-> (Integer -> Literal) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> NumOps -> Integer -> Literal
mkNumLiteral Platform
platform NumOps
num_ops
      add :: CoreExpr -> CoreExpr -> CoreExpr
add CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numAdd NumOps
num_ops) CoreExpr
y
      sub :: CoreExpr -> CoreExpr -> CoreExpr
sub CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numSub NumOps
num_ops) CoreExpr
y
      mul :: CoreExpr -> CoreExpr -> CoreExpr
mul CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numMul NumOps
num_ops) CoreExpr
y

subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
subFoldingRules' Platform
platform CoreExpr
arg1 CoreExpr
arg2 NumOps
num_ops = case (CoreExpr
arg1,CoreExpr
arg2) of
      -- x - (-y) ==> x+y
      (CoreExpr
x, NumOps -> CoreExpr -> Maybe CoreExpr
is_neg NumOps
num_ops -> Just CoreExpr
y)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y)

      -- R1) +/- simplification

      -- l1 - (l2 + x) ==> (l1-l2) - x
      (L Integer
l1, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l2,CoreExpr
x))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
x)

      -- l1 - (l2 - x) ==> (l1-l2) + x
      (L Integer
l1, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
x))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
x)

      -- l1 - (x - l2) ==> (l1+l2) - x
      (L Integer
l1, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x, L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
x)

      -- (l1 + x) - l2 ==> (l1-l2) + x
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), L Integer
l2)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
x)

      -- (l1 - x) - l2 ==> (l1-l2) - x
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
x), L Integer
l2)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
x)

      -- (x - l1) - l2 ==> x - (l1+l2)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x,L Integer
l1), L Integer
l2)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2))


      -- (l1 + x) - (l2 + y) ==> (l1-l2) + (x-y)
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y))

      -- (l1 + x) - (l2 - y) ==> (l1-l2) + (x+y)
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- (l1 + x) - (y - l2) ==> (l1+l2) + (x-y)
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y))

      -- (l1 - x) - (l2 + y) ==> (l1-l2) - (x+y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- (x - l1) - (l2 + y) ==> (0-l1-l2) + (x-y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x,L Integer
l1), NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y))

      -- (l1 - x) - (l2 - y) ==> (l1-l2) + (y-x)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
y CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
x))

      -- (l1 - x) - (y - l2) ==> (l1+l2) - (x+y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- (x - l1) - (l2 - y) ==> (0-l1-l2) + (x+y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x,L Integer
l1), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y))

      -- (x - l1) - (y - l2) ==> (l2-l1) + (x-y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x,L Integer
l1), NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l2))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l1) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y))

       -- R4) Simple factorization

      -- x - (l1 * x) ==> (1-l1) * x
      (CoreExpr, CoreExpr)
_ | Just Integer
l1 <- NumOps -> CoreExpr -> CoreExpr -> Maybe Integer
is_expr_mul NumOps
num_ops CoreExpr
arg1 CoreExpr
arg2
        -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l1) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
arg1)

      -- (l1 * x) - x ==> (l1-1) * x
      (CoreExpr, CoreExpr)
_ | Just Integer
l1 <- NumOps -> CoreExpr -> CoreExpr -> Maybe Integer
is_expr_mul NumOps
num_ops CoreExpr
arg2 CoreExpr
arg1
        -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
arg2)

      -- (l1 * x) - (l2 * x) ==> (l1-l2) * x
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_mul NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> CoreExpr -> Maybe Integer
is_expr_mul NumOps
num_ops CoreExpr
x -> Just Integer
l2)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
x)

      -- R5) +/- propagation: these transformations push literals outwards
      -- with the hope that other rules can then be applied.

      -- In the following rules, x can't be a literal otherwise another
      -- rule would have combined it with the other literal in arg2. So we
      -- don't have to check this to avoid loops here.

      -- x - (l1 + y) ==> (x - y) - l1
      (CoreExpr
_, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ((CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
l1)

      -- (l1 + x) - y ==> l1 + (x - y)
      (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), CoreExpr
_)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL Integer
l1 CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
arg2))

      -- x - (l1 - y) ==> (x + y) - l1
      (CoreExpr
_, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
y))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ((CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
y) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
l1)

      -- x - (y - l1) ==> l1 + (x - y)
      (CoreExpr
_, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
y,L Integer
l1))
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL Integer
l1 CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
y))

      -- (l1 - x) - y ==> l1 - (x + y)
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l1,CoreExpr
x), CoreExpr
_)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL Integer
l1 CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`add` CoreExpr
arg2))

      -- (x - l1) - y ==> (x - y) - l1
      (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x,L Integer
l1), CoreExpr
_)
         -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ((CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`sub` CoreExpr
arg2) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL Integer
l1)

      (CoreExpr, CoreExpr)
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing
   where
      mkL :: Integer -> CoreExpr
mkL = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr)
-> (Integer -> Literal) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> NumOps -> Integer -> Literal
mkNumLiteral Platform
platform NumOps
num_ops
      add :: CoreExpr -> CoreExpr -> CoreExpr
add CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numAdd NumOps
num_ops) CoreExpr
y
      sub :: CoreExpr -> CoreExpr -> CoreExpr
sub CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numSub NumOps
num_ops) CoreExpr
y
      mul :: CoreExpr -> CoreExpr -> CoreExpr
mul CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numMul NumOps
num_ops) CoreExpr
y

mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
mulFoldingRules' Platform
platform CoreExpr
arg1 CoreExpr
arg2 NumOps
num_ops = case (CoreExpr
arg1,CoreExpr
arg2) of
   -- (-x) * (-y) ==> x*y
   (NumOps -> CoreExpr -> Maybe CoreExpr
is_neg NumOps
num_ops -> Just CoreExpr
x, NumOps -> CoreExpr -> Maybe CoreExpr
is_neg NumOps
num_ops -> Just CoreExpr
y)
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
y)

   -- l1 * (-x) ==> (-l1) * x
   (L Integer
l1, NumOps -> CoreExpr -> Maybe CoreExpr
is_neg NumOps
num_ops -> Just CoreExpr
x)
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (-Integer
l1) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
x)

   -- l1 * (l2 * x) ==> (l1*l2) * x
   (L Integer
l1, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_mul NumOps
num_ops -> Just (Integer
l2,CoreExpr
x))
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
x)

   -- l1 * (l2 + x) ==> (l1*l2) + (l1 * x)
   (L Integer
l1, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops -> Just (Integer
l2,CoreExpr
x))
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`add` (CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
x))

   -- l1 * (l2 - x) ==> (l1*l2) - (l1 * x)
   (L Integer
l1, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (L Integer
l2,CoreExpr
x))
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`sub` (CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
x))

   -- l1 * (x - l2) ==> (l1 * x) - (l1*l2)
   (L Integer
l1, NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops -> Just (CoreExpr
x, L Integer
l2))
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ((CoreExpr
arg1 CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
x) CoreExpr -> CoreExpr -> CoreExpr
`sub` Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
l2))

   -- (l1 * x) * (l2 * y) ==> (l1*l2) * (x * y)
   (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_mul NumOps
num_ops -> Just (Integer
l1,CoreExpr
x), NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_mul NumOps
num_ops -> Just (Integer
l2,CoreExpr
y))
      -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`mul` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`mul` CoreExpr
y))

   (CoreExpr, CoreExpr)
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing
   where
      mkL :: Integer -> CoreExpr
mkL = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr)
-> (Integer -> Literal) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> NumOps -> Integer -> Literal
mkNumLiteral Platform
platform NumOps
num_ops
      add :: CoreExpr -> CoreExpr -> CoreExpr
add CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numAdd NumOps
num_ops) CoreExpr
y
      sub :: CoreExpr -> CoreExpr -> CoreExpr
sub CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numSub NumOps
num_ops) CoreExpr
y
      mul :: CoreExpr -> CoreExpr -> CoreExpr
mul CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (NumOps -> PrimOp
numMul NumOps
num_ops) CoreExpr
y

andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
andFoldingRules' Platform
platform CoreExpr
arg1 CoreExpr
arg2 NumOps
num_ops = case (CoreExpr
arg1, CoreExpr
arg2) of
    -- R2) * `or` `and` simplifications
    -- l1 and (l2 and x) ==> (l1 and l2) and x
    (L Integer
l1, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_and NumOps
num_ops -> Just (Integer
l2, CoreExpr
x))
       -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`and` CoreExpr
x)

    -- l1 and (l2 or x) ==> (l1 and l2) or (l1 and x)
    -- does not decrease operations

    -- (l1 and x) and (l2 and y) ==> (l1 and l2) and (x and y)
    (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_and NumOps
num_ops -> Just (Integer
l1, CoreExpr
x), NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_and NumOps
num_ops -> Just (Integer
l2, CoreExpr
y))
       -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`and` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`and` CoreExpr
y))

    -- (l1 and x) and (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)
    -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
    -- increase operation numbers

    (CoreExpr, CoreExpr)
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing
    where
      mkL :: Integer -> CoreExpr
mkL = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr)
-> (Integer -> Literal) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> NumOps -> Integer -> Literal
mkNumLiteral Platform
platform NumOps
num_ops
      and :: CoreExpr -> CoreExpr -> CoreExpr
and CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (Maybe PrimOp -> PrimOp
forall a. HasCallStack => Maybe a -> a
fromJust (NumOps -> Maybe PrimOp
numAnd NumOps
num_ops)) CoreExpr
y

orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
orFoldingRules' Platform
platform CoreExpr
arg1 CoreExpr
arg2 NumOps
num_ops = case (CoreExpr
arg1, CoreExpr
arg2) of
    -- R2) *  `or` `and` simplifications
    -- l1 or (l2 or x) ==> (l1 or l2) or x
    (L Integer
l1, NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_or NumOps
num_ops -> Just (Integer
l2, CoreExpr
x))
       -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`or` CoreExpr
x)

    -- l1 or (l2 and x) ==> (l1 or l2) and (l1 and x)
    -- does not decrease operations

    -- (l1 or x) or (l2 or y) ==> (l1 or l2) or (x or y)
    (NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_or NumOps
num_ops -> Just (Integer
l1, CoreExpr
x), NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_or NumOps
num_ops -> Just (Integer
l2, CoreExpr
y))
       -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
mkL (Integer
l1 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
l2) CoreExpr -> CoreExpr -> CoreExpr
`or` (CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
`or` CoreExpr
y))

    -- (l1 and x) or (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)
    -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
    -- increase operation numbers

    (CoreExpr, CoreExpr)
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing
    where
      mkL :: Integer -> CoreExpr
mkL = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr)
-> (Integer -> Literal) -> Integer -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> NumOps -> Integer -> Literal
mkNumLiteral Platform
platform NumOps
num_ops
      or :: CoreExpr -> CoreExpr -> CoreExpr
or CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (Maybe PrimOp -> PrimOp
forall a. HasCallStack => Maybe a -> a
fromJust (NumOps -> Maybe PrimOp
numOr NumOps
num_ops)) CoreExpr
y

quotFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
quotFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr
quotFoldingRules' Platform
platform CoreExpr
arg1 CoreExpr
arg2 NumOps
num_ops = case (CoreExpr
arg1, CoreExpr
arg2) of

  -- (x / l1) / l2
  -- l1 and l2 /= 0
  -- l1*l2 doesn't overflow
  -- ==> x / (l1 * l2)
  (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_div NumOps
num_ops -> Just (CoreExpr
x, L Integer
l1), L Integer
l2)
    | Integer
l1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
    , Integer
l2 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
    -- check that the result of the multiplication is in range
    , Just Literal
l <- Platform -> NumOps -> Integer -> Maybe Literal
mkNumLiteralMaybe Platform
platform NumOps
num_ops (Integer
l1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
l2)
    -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> CoreExpr -> CoreExpr
div CoreExpr
x (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
l))
      -- NB: we could directly return 0 or (-1) in case of overflow,
      -- but we would need to know
      --  (1) if we're dealing with a quot or a div operation
      --  (2) if it's an underflow or an overflow.
      -- Left as future work for now.

  (CoreExpr, CoreExpr)
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing
  where
    div :: CoreExpr -> CoreExpr -> CoreExpr
div CoreExpr
x CoreExpr
y = CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x (Maybe PrimOp -> PrimOp
forall a. HasCallStack => Maybe a -> a
fromJust (NumOps -> Maybe PrimOp
numDiv NumOps
num_ops)) CoreExpr
y

is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)
is_binop :: PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop PrimOp
op CoreExpr
e = case CoreExpr
e of
 BinOpApp CoreExpr
x PrimOp
op' CoreExpr
y | PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== PrimOp
op' -> (CoreExpr, CoreExpr) -> Maybe (CoreExpr, CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
x,CoreExpr
y)
 CoreExpr
_                            -> Maybe (CoreExpr, CoreExpr)
forall a. Maybe a
Nothing

is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr)
is_op :: PrimOp -> CoreExpr -> Maybe CoreExpr
is_op PrimOp
op CoreExpr
e = case CoreExpr
e of
 App (OpVal PrimOp
op') CoreExpr
x | PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== PrimOp
op' -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
x
 CoreExpr
_                             -> Maybe CoreExpr
forall a. Maybe a
Nothing

is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)
is_add :: NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_add NumOps
num_ops CoreExpr
e = PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop (NumOps -> PrimOp
numAdd NumOps
num_ops) CoreExpr
e
is_sub :: NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_sub NumOps
num_ops CoreExpr
e = PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop (NumOps -> PrimOp
numSub NumOps
num_ops) CoreExpr
e
is_mul :: NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_mul NumOps
num_ops CoreExpr
e = PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop (NumOps -> PrimOp
numMul NumOps
num_ops) CoreExpr
e
is_and :: NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_and NumOps
num_ops CoreExpr
e = NumOps -> Maybe PrimOp
numAnd NumOps
num_ops Maybe PrimOp
-> (PrimOp -> Maybe (CoreExpr, CoreExpr))
-> Maybe (CoreExpr, CoreExpr)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PrimOp
op -> PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop PrimOp
op CoreExpr
e
is_or :: NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_or  NumOps
num_ops CoreExpr
e = NumOps -> Maybe PrimOp
numOr  NumOps
num_ops Maybe PrimOp
-> (PrimOp -> Maybe (CoreExpr, CoreExpr))
-> Maybe (CoreExpr, CoreExpr)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PrimOp
op -> PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop PrimOp
op CoreExpr
e
is_div :: NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_div NumOps
num_ops CoreExpr
e = NumOps -> Maybe PrimOp
numDiv NumOps
num_ops Maybe PrimOp
-> (PrimOp -> Maybe (CoreExpr, CoreExpr))
-> Maybe (CoreExpr, CoreExpr)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PrimOp
op -> PrimOp -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_binop PrimOp
op CoreExpr
e

is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr)
is_neg :: NumOps -> CoreExpr -> Maybe CoreExpr
is_neg NumOps
num_ops CoreExpr
e = NumOps -> Maybe PrimOp
numNeg NumOps
num_ops Maybe PrimOp -> (PrimOp -> Maybe CoreExpr) -> Maybe CoreExpr
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PrimOp
op -> PrimOp -> CoreExpr -> Maybe CoreExpr
is_op PrimOp
op CoreExpr
e

-- match operation with a literal (handles commutativity)
is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)
is_lit_add :: NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_add NumOps
num_ops CoreExpr
e = (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr))
-> NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit' NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_add NumOps
num_ops CoreExpr
e
is_lit_mul :: NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_mul NumOps
num_ops CoreExpr
e = (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr))
-> NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit' NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_mul NumOps
num_ops CoreExpr
e
is_lit_and :: NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_and NumOps
num_ops CoreExpr
e = (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr))
-> NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit' NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_and NumOps
num_ops CoreExpr
e
is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_or  NumOps
num_ops CoreExpr
e = (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr))
-> NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit' NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
is_or  NumOps
num_ops CoreExpr
e

is_lit' :: (NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)) -> NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)
is_lit' :: (NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr))
-> NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit' NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
f NumOps
num_ops CoreExpr
e = case NumOps -> CoreExpr -> Maybe (CoreExpr, CoreExpr)
f NumOps
num_ops CoreExpr
e of
  Just (L Integer
l, CoreExpr
x  ) -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
  Just (CoreExpr
x  , L Integer
l) -> (Integer, CoreExpr) -> Maybe (Integer, CoreExpr)
forall a. a -> Maybe a
Just (Integer
l,CoreExpr
x)
  Maybe (CoreExpr, CoreExpr)
_               -> Maybe (Integer, CoreExpr)
forall a. Maybe a
Nothing

-- match given "x": return 1
-- match "lit * x": return lit value (handles commutativity)
is_expr_mul :: NumOps -> Expr CoreBndr -> Expr CoreBndr -> Maybe Integer
is_expr_mul :: NumOps -> CoreExpr -> CoreExpr -> Maybe Integer
is_expr_mul NumOps
num_ops CoreExpr
x CoreExpr
e = if
   | CoreExpr
x CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
e
   -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1
   | Just (Integer
k,CoreExpr
x') <- NumOps -> CoreExpr -> Maybe (Integer, CoreExpr)
is_lit_mul NumOps
num_ops CoreExpr
e
   , CoreExpr
x CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqExpr` CoreExpr
x'
   -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
k
   | Bool
otherwise
   -> Maybe Integer
forall a. Maybe a
Nothing


-- | Match the application of a binary primop
pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
pattern $mBinOpApp :: forall {r}.
CoreExpr
-> (CoreExpr -> PrimOp -> CoreExpr -> r) -> ((# #) -> 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) -> ((# #) -> 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
primOpId PrimOp
op)

-- | Match a literal
pattern L :: Integer -> Arg CoreBndr
pattern $mL :: forall {r}. CoreExpr -> (Integer -> r) -> ((# #) -> r) -> r
L i <- Lit (LitNumber _ i)

-- | Explicit "type-class"-like dictionary for numeric primops
data NumOps = NumOps
   { NumOps -> PrimOp
numAdd     :: !PrimOp         -- ^ Add two numbers
   , NumOps -> PrimOp
numSub     :: !PrimOp         -- ^ Sub two numbers
   , NumOps -> PrimOp
numMul     :: !PrimOp         -- ^ Multiply two numbers
   , NumOps -> Maybe PrimOp
numDiv     :: !(Maybe PrimOp) -- ^ Divide two numbers
   , NumOps -> Maybe PrimOp
numAnd     :: !(Maybe PrimOp) -- ^ And two numbers
   , NumOps -> Maybe PrimOp
numOr      :: !(Maybe PrimOp) -- ^ Or two numbers
   , NumOps -> Maybe PrimOp
numNeg     :: !(Maybe PrimOp) -- ^ Negate a number
   , NumOps -> LitNumType
numLitType :: !LitNumType     -- ^ Literal type
   }

-- | Create a numeric literal
mkNumLiteral :: Platform -> NumOps -> Integer -> Literal
mkNumLiteral :: Platform -> NumOps -> Integer -> Literal
mkNumLiteral Platform
platform NumOps
ops Integer
i = Platform -> LitNumType -> Integer -> Literal
mkLitNumberWrap Platform
platform (NumOps -> LitNumType
numLitType NumOps
ops) Integer
i

-- | Create a numeric literal if it is in range
mkNumLiteralMaybe :: Platform -> NumOps -> Integer -> Maybe Literal
mkNumLiteralMaybe :: Platform -> NumOps -> Integer -> Maybe Literal
mkNumLiteralMaybe Platform
platform NumOps
ops Integer
i = Platform -> LitNumType -> Integer -> Maybe Literal
mkLitNumberMaybe Platform
platform (NumOps -> LitNumType
numLitType NumOps
ops) Integer
i

int8Ops :: NumOps
int8Ops :: NumOps
int8Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Int8AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Int8SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Int8MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int8QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numOr :: Maybe PrimOp
numOr      = Maybe PrimOp
forall a. Maybe a
Nothing
   , numNeg :: Maybe PrimOp
numNeg     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int8NegOp
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumInt8
   }

word8Ops :: NumOps
word8Ops :: NumOps
word8Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Word8AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Word8SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Word8MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word8QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word8AndOp
   , numOr :: Maybe PrimOp
numOr      = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word8OrOp
   , numNeg :: Maybe PrimOp
numNeg     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumWord8
   }

int16Ops :: NumOps
int16Ops :: NumOps
int16Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Int16AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Int16SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Int16MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int16QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numOr :: Maybe PrimOp
numOr      = Maybe PrimOp
forall a. Maybe a
Nothing
   , numNeg :: Maybe PrimOp
numNeg     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int16NegOp
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumInt16
   }

word16Ops :: NumOps
word16Ops :: NumOps
word16Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Word16AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Word16SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Word16MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word16QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word16AndOp
   , numOr :: Maybe PrimOp
numOr      = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word16OrOp
   , numNeg :: Maybe PrimOp
numNeg     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumWord16
   }

int32Ops :: NumOps
int32Ops :: NumOps
int32Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Int32AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Int32SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Int32MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int32QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numOr :: Maybe PrimOp
numOr      = Maybe PrimOp
forall a. Maybe a
Nothing
   , numNeg :: Maybe PrimOp
numNeg     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int32NegOp
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumInt32
   }

word32Ops :: NumOps
word32Ops :: NumOps
word32Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Word32AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Word32SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Word32MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word32QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word32AndOp
   , numOr :: Maybe PrimOp
numOr      = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word32OrOp
   , numNeg :: Maybe PrimOp
numNeg     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumWord32
   }

int64Ops :: NumOps
int64Ops :: NumOps
int64Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Int64AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Int64SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Int64MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int64QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numOr :: Maybe PrimOp
numOr      = Maybe PrimOp
forall a. Maybe a
Nothing
   , numNeg :: Maybe PrimOp
numNeg     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Int64NegOp
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumInt64
   }

word64Ops :: NumOps
word64Ops :: NumOps
word64Ops = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
Word64AddOp
   , numSub :: PrimOp
numSub     = PrimOp
Word64SubOp
   , numMul :: PrimOp
numMul     = PrimOp
Word64MulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word64QuotOp
   , numAnd :: Maybe PrimOp
numAnd     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word64AndOp
   , numOr :: Maybe PrimOp
numOr      = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
Word64OrOp
   , numNeg :: Maybe PrimOp
numNeg     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumWord64
   }

intOps :: NumOps
intOps :: NumOps
intOps = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
IntAddOp
   , numSub :: PrimOp
numSub     = PrimOp
IntSubOp
   , numMul :: PrimOp
numMul     = PrimOp
IntMulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
IntQuotOp
   , numAnd :: Maybe PrimOp
numAnd     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
IntAndOp
   , numOr :: Maybe PrimOp
numOr      = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
IntOrOp
   , numNeg :: Maybe PrimOp
numNeg     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
IntNegOp
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumInt
   }

wordOps :: NumOps
wordOps :: NumOps
wordOps = NumOps
   { numAdd :: PrimOp
numAdd     = PrimOp
WordAddOp
   , numSub :: PrimOp
numSub     = PrimOp
WordSubOp
   , numMul :: PrimOp
numMul     = PrimOp
WordMulOp
   , numDiv :: Maybe PrimOp
numDiv     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
WordQuotOp
   , numAnd :: Maybe PrimOp
numAnd     = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
WordAndOp
   , numOr :: Maybe PrimOp
numOr      = PrimOp -> Maybe PrimOp
forall a. a -> Maybe a
Just PrimOp
WordOrOp
   , numNeg :: Maybe PrimOp
numNeg     = Maybe PrimOp
forall a. Maybe a
Nothing
   , numLitType :: LitNumType
numLitType = LitNumType
LitNumWord
   }

--------------------------------------------------------
-- 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
  , LitNumber LitNumType
_ Integer
x <- 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
  , LitNumber LitNumType
_ Integer
x <- 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
_ (Var Id
f `App` Type Type
lev `App` Type Type
ty `App` CoreExpr
v) -- dataToTag x
  | Just PrimOp
op <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
  , PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== PrimOp
DataToTagSmallOp Bool -> Bool -> Bool
|| PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
== PrimOp
DataToTagLargeOp
  = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
      Just (TyCon
tc, [Type]
_) | TyCon -> Bool
isValidDTT2TyCon TyCon
tc
        -> (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
v, TyCon -> AltCon -> Maybe AltCon
tx_con_dtt TyCon
tc
                , \Id
v' -> Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CoreExpr
forall b. Type -> Expr b
Type Type
lev CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v')
      Maybe (TyCon, [Type])
_ -> SDoc
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
-> Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. HasCallStack => SDoc -> a -> a
pprTraceUserWarning SDoc
warnMsg Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. Maybe a
Nothing
  where
    warnMsg :: SDoc
warnMsg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
forall doc. IsLine doc => String -> doc
text
      [ String
"Found dataToTag primop applied to a non-ADT type. This could"
      , String
"be a future bug in GHC, or it may be caused by an unsupported"
      , String
"use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#."
      , String
"In either case, the GHC developers would like to know about it!"
      , String
"Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug"
      ]

caseRules Platform
_ CoreExpr
_ = Maybe (CoreExpr, AltCon -> Maybe AltCon, Id -> CoreExpr)
forall a. Maybe a
Nothing


-- | Case rules
--
-- It's important that occurrence info are present, hence the use of In* types.
caseRules2
   :: InExpr  -- ^ Scutinee
   -> InId    -- ^ Case-binder
   -> [InAlt] -- ^ Alternatives in standard (increasing) order
   -> Maybe (InExpr, InId, [InAlt])
caseRules2 :: CoreExpr -> Id -> [CoreAlt] -> Maybe (CoreExpr, Id, [CoreAlt])
caseRules2 CoreExpr
scrut Id
bndr [CoreAlt]
alts

  -- case quotRem# x y of
  --    (# q, _ #) -> body
  -- ====>
  --  case quot# x y of
  --    q -> body
  --
  -- case quotRem# x y of
  --    (# _, r #) -> body
  -- ====>
  --  case rem# x y of
  --    r -> body
  | BinOpApp CoreExpr
x PrimOp
op CoreExpr
y <- CoreExpr
scrut
  , Just (PrimOp
quot,PrimOp
rem) <- PrimOp -> Maybe (PrimOp, PrimOp)
is_any_quot_rem PrimOp
op
  , [Alt (DataAlt DataCon
_) [Id
q,Id
r] CoreExpr
body] <- [CoreAlt]
alts
  , Id -> Bool
isDeadBinder Id
bndr
  , Bool
dead_q <- Id -> Bool
isDeadBinder Id
q
  , Bool
dead_r <- Id -> Bool
isDeadBinder Id
r
  , Bool
dead_q Bool -> Bool -> Bool
|| Bool
dead_r
  = if
      | Bool
dead_q    -> (CoreExpr, Id, [CoreAlt]) -> Maybe (CoreExpr, Id, [CoreAlt])
forall a. a -> Maybe a
Just ((CoreExpr, Id, [CoreAlt]) -> Maybe (CoreExpr, Id, [CoreAlt]))
-> (CoreExpr, Id, [CoreAlt]) -> Maybe (CoreExpr, Id, [CoreAlt])
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
rem  CoreExpr
y, Id
r, [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])
      | Bool
dead_r    -> (CoreExpr, Id, [CoreAlt]) -> Maybe (CoreExpr, Id, [CoreAlt])
forall a. a -> Maybe a
Just ((CoreExpr, Id, [CoreAlt]) -> Maybe (CoreExpr, Id, [CoreAlt]))
-> (CoreExpr, Id, [CoreAlt]) -> Maybe (CoreExpr, Id, [CoreAlt])
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> PrimOp -> CoreExpr -> CoreExpr
BinOpApp CoreExpr
x PrimOp
quot CoreExpr
y, Id
q, [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])
      | Bool
otherwise -> Maybe (CoreExpr, Id, [CoreAlt])
forall a. Maybe a
Nothing

  | Bool
otherwise
  = Maybe (CoreExpr, Id, [CoreAlt])
forall a. Maybe a
Nothing


-- | If the given primop is a quotRem, return the corresponding (quot,rem).
is_any_quot_rem :: PrimOp -> Maybe (PrimOp, PrimOp)
is_any_quot_rem :: PrimOp -> Maybe (PrimOp, PrimOp)
is_any_quot_rem = \case
  PrimOp
IntQuotRemOp    -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
IntQuotOp ,  PrimOp
IntRemOp)
  PrimOp
Int8QuotRemOp   -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
Int8QuotOp,  PrimOp
Int8RemOp)
  PrimOp
Int16QuotRemOp  -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
Int16QuotOp, PrimOp
Int16RemOp)
  PrimOp
Int32QuotRemOp  -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
Int32QuotOp, PrimOp
Int32RemOp)
  -- Int64QuotRemOp doesn't exist (yet)

  PrimOp
WordQuotRemOp   -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
WordQuotOp,   PrimOp
WordRemOp)
  PrimOp
Word8QuotRemOp  -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
Word8QuotOp,  PrimOp
Word8RemOp)
  PrimOp
Word16QuotRemOp -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
Word16QuotOp, PrimOp
Word16RemOp)
  PrimOp
Word32QuotRemOp -> (PrimOp, PrimOp) -> Maybe (PrimOp, PrimOp)
forall a. a -> Maybe a
Just (PrimOp
Word32QuotOp, PrimOp
Word32RemOp)
  -- Word64QuotRemOp doesn't exist (yet)

  PrimOp
_ -> Maybe (PrimOp, PrimOp)
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
WordXorOp -> (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
IntXorOp  -> (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
WordXorOp -> (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
IntXorOp  -> (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
WordNotOp -> (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
IntNotOp  -> (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 :: TyCon -> AltCon -> Maybe AltCon
tx_con_dtt :: TyCon -> AltCon -> Maybe AltCon
tx_con_dtt TyCon
_  AltCon
DEFAULT = AltCon -> Maybe AltCon
forall a. a -> Maybe a
Just AltCon
DEFAULT
tx_con_dtt TyCon
tc (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. HasCallStack => [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
     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 TyCon
_ AltCon
alt = String -> SDoc -> Maybe AltCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseRules/dataToTag: bad alt" (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

See #8317.   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, when possible, we turn one branch into DEFAULT in
GHC.Core.Opt.Simplify.Utils.mkCase2; see Note [Literal cases]
in that module.

Note [caseRules for dataToTag]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [DataToTag overview] in GHC.Tc.Instance.Class.

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

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

This transformation often enables further optimisation via
case-flattening and case-of-known-constructor and can be very
important for code using derived Eq instances.

We can apply this transformation only when we can easily get the
constructors from the type at which dataToTagSmall# is used.  And we
cannot apply this transformation at "type data"-related types without
breaking invariant I1 from Note [Type data declarations] in
GHC.Rename.Module.  That leaves exactly the types satisfying condition
DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class.

All of the above applies identically for `dataToTagLarge#`.  And
thanks to wrinkle DTW5, there is no need to worry about large-tag
arguments for `dataToTagSmall#`; those cause undefined behavior anyway.


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.
-}