module GHC.Core.Opt.Simplify.Utils (
mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
preInlineUnconditionally, postInlineUnconditionally,
activeUnfolding, activeRule,
getUnfoldingInRuleMatch,
simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,
SimplCont(..), DupFlag(..), StaticEnv,
isSimplified, contIsStop,
contIsDupable, contResultType, contHoleType, contHoleScaling,
contIsTrivial, contArgs,
countArgs,
mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
interestingCallContext,
ArgInfo(..), ArgSpec(..), mkArgInfo,
addValArgTo, addCastTo, addTyArgTo,
argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,
isStrictArgInfo, lazyArgContext,
abstractFloats,
isExitJoinId
) where
import GHC.Prelude
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) )
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Core
import qualified GHC.Core.Subst
import GHC.Core.Ppr
import GHC.Core.TyCo.Ppr ( pprParendType )
import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Tickish
import GHC.Types.Var
import GHC.Types.Demand
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Type hiding( substTy )
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
import GHC.Core.Multiplicity
import GHC.Utils.Misc
import GHC.Data.OrdList ( isNilOL )
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Core.Opt.ConstantFold
import GHC.Data.FastString ( fsLit )
import Control.Monad ( when )
import Data.List ( sortBy )
data SimplCont
= Stop
OutType
CallCtxt
| CastIt
OutCoercion
SimplCont
| ApplyToVal
{ SimplCont -> DupFlag
sc_dup :: DupFlag
, SimplCont -> OutType
sc_hole_ty :: OutType
, SimplCont -> InExpr
sc_arg :: InExpr
, SimplCont -> StaticEnv
sc_env :: StaticEnv
, SimplCont -> SimplCont
sc_cont :: SimplCont }
| ApplyToTy
{ SimplCont -> OutType
sc_arg_ty :: OutType
, sc_hole_ty :: OutType
, sc_cont :: SimplCont }
| Select
{ sc_dup :: DupFlag
, SimplCont -> InId
sc_bndr :: InId
, SimplCont -> [InAlt]
sc_alts :: [InAlt]
, sc_env :: StaticEnv
, sc_cont :: SimplCont }
| StrictBind
{ sc_dup :: DupFlag
, sc_bndr :: InId
, SimplCont -> [InId]
sc_bndrs :: [InBndr]
, SimplCont -> InExpr
sc_body :: InExpr
, sc_env :: StaticEnv
, sc_cont :: SimplCont }
| StrictArg
{ sc_dup :: DupFlag
, SimplCont -> ArgInfo
sc_fun :: ArgInfo
, SimplCont -> OutType
sc_fun_ty :: OutType
, sc_cont :: SimplCont }
| TickIt
CoreTickish
SimplCont
type StaticEnv = SimplEnv
data DupFlag = NoDup
| Simplified
| OkToDup
isSimplified :: DupFlag -> Bool
isSimplified :: DupFlag -> Bool
isSimplified DupFlag
NoDup = Bool
False
isSimplified DupFlag
_ = Bool
True
perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type
perhapsSubstTy :: DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
dup StaticEnv
env OutType
ty
| DupFlag -> Bool
isSimplified DupFlag
dup = OutType
ty
| Bool
otherwise = StaticEnv -> OutType -> OutType
substTy StaticEnv
env OutType
ty
instance Outputable DupFlag where
ppr :: DupFlag -> SDoc
ppr DupFlag
OkToDup = String -> SDoc
text String
"ok"
ppr DupFlag
NoDup = String -> SDoc
text String
"nodup"
ppr DupFlag
Simplified = String -> SDoc
text String
"simpl"
instance Outputable SimplCont where
ppr :: SimplCont -> SDoc
ppr (Stop OutType
ty CallCtxt
interesting) = String -> SDoc
text String
"Stop" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (CallCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallCtxt
interesting) SDoc -> SDoc -> SDoc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
ty
ppr (CastIt OutCoercion
co SimplCont
cont ) = (String -> SDoc
text String
"CastIt" SDoc -> SDoc -> SDoc
<+> OutCoercion -> SDoc
pprOptCo OutCoercion
co) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (TickIt CoreTickish
t SimplCont
cont) = (String -> SDoc
text String
"TickIt" SDoc -> SDoc -> SDoc
<+> CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
t) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (ApplyToTy { sc_arg_ty :: SimplCont -> OutType
sc_arg_ty = OutType
ty, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"ApplyToTy" SDoc -> SDoc -> SDoc
<+> OutType -> SDoc
pprParendType OutType
ty) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (ApplyToVal { sc_arg :: SimplCont -> InExpr
sc_arg = InExpr
arg, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont, sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
hole_ty })
= (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"ApplyToVal" SDoc -> SDoc -> SDoc
<+> DupFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr DupFlag
dup SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"hole" SDoc -> SDoc -> SDoc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
hole_ty)
Int
2 (InExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr InExpr
arg))
SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (StrictBind { sc_bndr :: SimplCont -> InId
sc_bndr = InId
b, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"StrictBind" SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InId
b) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
ai, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"StrictArg" SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ArgInfo -> InId
ai_fun ArgInfo
ai)) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (Select { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_bndr :: SimplCont -> InId
sc_bndr = InId
bndr, sc_alts :: SimplCont -> [InAlt]
sc_alts = [InAlt]
alts, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
text String
"Select" SDoc -> SDoc -> SDoc
<+> DupFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr DupFlag
dup SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InId
bndr) SDoc -> SDoc -> SDoc
$$
SDoc -> SDoc
whenPprDebug (Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [TvSubstEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (StaticEnv -> TvSubstEnv
seTvSubst StaticEnv
se), [InAlt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InAlt]
alts]) SDoc -> SDoc -> SDoc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
data ArgInfo
= ArgInfo {
ArgInfo -> InId
ai_fun :: OutId,
ArgInfo -> [ArgSpec]
ai_args :: [ArgSpec],
ArgInfo -> FunRules
ai_rules :: FunRules,
ArgInfo -> Bool
ai_encl :: Bool,
ArgInfo -> [Demand]
ai_dmds :: [Demand],
ArgInfo -> [Int]
ai_discs :: [Int]
}
data ArgSpec
= ValArg { ArgSpec -> Demand
as_dmd :: Demand
, ArgSpec -> InExpr
as_arg :: OutExpr
, ArgSpec -> OutType
as_hole_ty :: OutType }
| TyArg { ArgSpec -> OutType
as_arg_ty :: OutType
, as_hole_ty :: OutType }
| CastBy OutCoercion
instance Outputable ArgInfo where
ppr :: ArgInfo -> SDoc
ppr (ArgInfo { ai_fun :: ArgInfo -> InId
ai_fun = InId
fun, ai_args :: ArgInfo -> [ArgSpec]
ai_args = [ArgSpec]
args, ai_dmds :: ArgInfo -> [Demand]
ai_dmds = [Demand]
dmds })
= String -> SDoc
text String
"ArgInfo" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces
([SDoc] -> SDoc
sep [ String -> SDoc
text String
"fun =" SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InId
fun
, String -> SDoc
text String
"dmds =" SDoc -> SDoc -> SDoc
<+> [Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
dmds
, String -> SDoc
text String
"args =" SDoc -> SDoc -> SDoc
<+> [ArgSpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ArgSpec]
args ])
instance Outputable ArgSpec where
ppr :: ArgSpec -> SDoc
ppr (ValArg { as_arg :: ArgSpec -> InExpr
as_arg = InExpr
arg }) = String -> SDoc
text String
"ValArg" SDoc -> SDoc -> SDoc
<+> InExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InExpr
arg
ppr (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty }) = String -> SDoc
text String
"TyArg" SDoc -> SDoc -> SDoc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
ty
ppr (CastBy OutCoercion
c) = String -> SDoc
text String
"CastBy" SDoc -> SDoc -> SDoc
<+> OutCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutCoercion
c
addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
addValArgTo :: ArgInfo -> InExpr -> OutType -> ArgInfo
addValArgTo ArgInfo
ai InExpr
arg OutType
hole_ty
| ArgInfo { ai_dmds :: ArgInfo -> [Demand]
ai_dmds = Demand
dmd:[Demand]
dmds, ai_discs :: ArgInfo -> [Int]
ai_discs = Int
_:[Int]
discs, ai_rules :: ArgInfo -> FunRules
ai_rules = FunRules
rules } <- ArgInfo
ai
, let arg_spec :: ArgSpec
arg_spec = ValArg :: Demand -> InExpr -> OutType -> ArgSpec
ValArg { as_arg :: InExpr
as_arg = InExpr
arg, as_hole_ty :: OutType
as_hole_ty = OutType
hole_ty, as_dmd :: Demand
as_dmd = Demand
dmd }
= ArgInfo
ai { ai_args :: [ArgSpec]
ai_args = ArgSpec
arg_spec ArgSpec -> [ArgSpec] -> [ArgSpec]
forall a. a -> [a] -> [a]
: ArgInfo -> [ArgSpec]
ai_args ArgInfo
ai
, ai_dmds :: [Demand]
ai_dmds = [Demand]
dmds
, ai_discs :: [Int]
ai_discs = [Int]
discs
, ai_rules :: FunRules
ai_rules = FunRules -> FunRules
decRules FunRules
rules }
| Bool
otherwise
= String -> SDoc -> ArgInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addValArgTo" (ArgInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr ArgInfo
ai SDoc -> SDoc -> SDoc
$$ InExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InExpr
arg)
addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo
addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo
addTyArgTo ArgInfo
ai OutType
arg_ty OutType
hole_ty = ArgInfo
ai { ai_args :: [ArgSpec]
ai_args = ArgSpec
arg_spec ArgSpec -> [ArgSpec] -> [ArgSpec]
forall a. a -> [a] -> [a]
: ArgInfo -> [ArgSpec]
ai_args ArgInfo
ai
, ai_rules :: FunRules
ai_rules = FunRules -> FunRules
decRules (ArgInfo -> FunRules
ai_rules ArgInfo
ai) }
where
arg_spec :: ArgSpec
arg_spec = TyArg :: OutType -> OutType -> ArgSpec
TyArg { as_arg_ty :: OutType
as_arg_ty = OutType
arg_ty, as_hole_ty :: OutType
as_hole_ty = OutType
hole_ty }
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo ArgInfo
ai OutCoercion
co = ArgInfo
ai { ai_args :: [ArgSpec]
ai_args = OutCoercion -> ArgSpec
CastBy OutCoercion
co ArgSpec -> [ArgSpec] -> [ArgSpec]
forall a. a -> [a] -> [a]
: ArgInfo -> [ArgSpec]
ai_args ArgInfo
ai }
isStrictArgInfo :: ArgInfo -> Bool
isStrictArgInfo :: ArgInfo -> Bool
isStrictArgInfo (ArgInfo { ai_dmds :: ArgInfo -> [Demand]
ai_dmds = [Demand]
dmds })
| Demand
dmd:[Demand]
_ <- [Demand]
dmds = Demand -> Bool
isStrUsedDmd Demand
dmd
| Bool
otherwise = Bool
False
argInfoAppArgs :: [ArgSpec] -> [OutExpr]
argInfoAppArgs :: [ArgSpec] -> [InExpr]
argInfoAppArgs [] = []
argInfoAppArgs (CastBy {} : [ArgSpec]
_) = []
argInfoAppArgs (ValArg { as_arg :: ArgSpec -> InExpr
as_arg = InExpr
arg } : [ArgSpec]
as) = InExpr
arg InExpr -> [InExpr] -> [InExpr]
forall a. a -> [a] -> [a]
: [ArgSpec] -> [InExpr]
argInfoAppArgs [ArgSpec]
as
argInfoAppArgs (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty } : [ArgSpec]
as) = OutType -> InExpr
forall b. OutType -> Expr b
Type OutType
ty InExpr -> [InExpr] -> [InExpr]
forall a. a -> [a] -> [a]
: [ArgSpec] -> [InExpr]
argInfoAppArgs [ArgSpec]
as
pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs :: StaticEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs StaticEnv
_env [] SimplCont
k = SimplCont
k
pushSimplifiedArgs StaticEnv
env (ArgSpec
arg : [ArgSpec]
args) SimplCont
k
= case ArgSpec
arg of
TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
arg_ty, as_hole_ty :: ArgSpec -> OutType
as_hole_ty = OutType
hole_ty }
-> ApplyToTy :: OutType -> OutType -> SimplCont -> SimplCont
ApplyToTy { sc_arg_ty :: OutType
sc_arg_ty = OutType
arg_ty, sc_hole_ty :: OutType
sc_hole_ty = OutType
hole_ty, sc_cont :: SimplCont
sc_cont = SimplCont
rest }
ValArg { as_arg :: ArgSpec -> InExpr
as_arg = InExpr
arg, as_hole_ty :: ArgSpec -> OutType
as_hole_ty = OutType
hole_ty }
-> ApplyToVal :: DupFlag -> OutType -> InExpr -> StaticEnv -> SimplCont -> SimplCont
ApplyToVal { sc_arg :: InExpr
sc_arg = InExpr
arg, sc_env :: StaticEnv
sc_env = StaticEnv
env, sc_dup :: DupFlag
sc_dup = DupFlag
Simplified
, sc_hole_ty :: OutType
sc_hole_ty = OutType
hole_ty, sc_cont :: SimplCont
sc_cont = SimplCont
rest }
CastBy OutCoercion
c -> OutCoercion -> SimplCont -> SimplCont
CastIt OutCoercion
c SimplCont
rest
where
rest :: SimplCont
rest = StaticEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs StaticEnv
env [ArgSpec]
args SimplCont
k
argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
argInfoExpr :: InId -> [ArgSpec] -> InExpr
argInfoExpr InId
fun [ArgSpec]
rev_args
= [ArgSpec] -> InExpr
go [ArgSpec]
rev_args
where
go :: [ArgSpec] -> InExpr
go [] = InId -> InExpr
forall b. InId -> Expr b
Var InId
fun
go (ValArg { as_arg :: ArgSpec -> InExpr
as_arg = InExpr
arg } : [ArgSpec]
as) = [ArgSpec] -> InExpr
go [ArgSpec]
as InExpr -> InExpr -> InExpr
forall b. Expr b -> Expr b -> Expr b
`App` InExpr
arg
go (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty } : [ArgSpec]
as) = [ArgSpec] -> InExpr
go [ArgSpec]
as InExpr -> InExpr -> InExpr
forall b. Expr b -> Expr b -> Expr b
`App` OutType -> InExpr
forall b. OutType -> Expr b
Type OutType
ty
go (CastBy OutCoercion
co : [ArgSpec]
as) = InExpr -> OutCoercion -> InExpr
mkCast ([ArgSpec] -> InExpr
go [ArgSpec]
as) OutCoercion
co
type FunRules = Maybe (Int, [CoreRule])
decRules :: FunRules -> FunRules
decRules :: FunRules -> FunRules
decRules (Just (Int
n, [CoreRule]
rules)) = (Int, [CoreRule]) -> FunRules
forall a. a -> Maybe a
Just (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, [CoreRule]
rules)
decRules FunRules
Nothing = FunRules
forall a. Maybe a
Nothing
mkFunRules :: [CoreRule] -> FunRules
mkFunRules :: [CoreRule] -> FunRules
mkFunRules [] = FunRules
forall a. Maybe a
Nothing
mkFunRules [CoreRule]
rs = (Int, [CoreRule]) -> FunRules
forall a. a -> Maybe a
Just (Int
n_required, [CoreRule]
rs)
where
n_required :: Int
n_required = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((CoreRule -> Int) -> [CoreRule] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> Int
ruleArity [CoreRule]
rs)
mkBoringStop :: OutType -> SimplCont
mkBoringStop :: OutType -> SimplCont
mkBoringStop OutType
ty = OutType -> CallCtxt -> SimplCont
Stop OutType
ty CallCtxt
BoringCtxt
mkRhsStop :: OutType -> SimplCont
mkRhsStop :: OutType -> SimplCont
mkRhsStop OutType
ty = OutType -> CallCtxt -> SimplCont
Stop OutType
ty CallCtxt
RhsCtxt
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop OutType
ty CallCtxt
cci = OutType -> CallCtxt -> SimplCont
Stop OutType
ty CallCtxt
cci
contIsRhsOrArg :: SimplCont -> Bool
contIsRhsOrArg :: SimplCont -> Bool
contIsRhsOrArg (Stop {}) = Bool
True
contIsRhsOrArg (StrictBind {}) = Bool
True
contIsRhsOrArg (StrictArg {}) = Bool
True
contIsRhsOrArg SimplCont
_ = Bool
False
contIsRhs :: SimplCont -> Bool
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop OutType
_ CallCtxt
RhsCtxt) = Bool
True
contIsRhs SimplCont
_ = Bool
False
contIsStop :: SimplCont -> Bool
contIsStop :: SimplCont -> Bool
contIsStop (Stop {}) = Bool
True
contIsStop SimplCont
_ = Bool
False
contIsDupable :: SimplCont -> Bool
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop {}) = Bool
True
contIsDupable (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
contIsDupable SimplCont
k
contIsDupable (ApplyToVal { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
OkToDup }) = Bool
True
contIsDupable (Select { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
OkToDup }) = Bool
True
contIsDupable (StrictArg { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
OkToDup }) = Bool
True
contIsDupable (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> Bool
contIsDupable SimplCont
k
contIsDupable SimplCont
_ = Bool
False
contIsTrivial :: SimplCont -> Bool
contIsTrivial :: SimplCont -> Bool
contIsTrivial (Stop {}) = Bool
True
contIsTrivial (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
contIsTrivial SimplCont
k
contIsTrivial (ApplyToVal { sc_arg :: SimplCont -> InExpr
sc_arg = Coercion OutCoercion
_, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> Bool
contIsTrivial SimplCont
k
contIsTrivial (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> Bool
contIsTrivial SimplCont
k
contIsTrivial SimplCont
_ = Bool
False
contResultType :: SimplCont -> OutType
contResultType :: SimplCont -> OutType
contResultType (Stop OutType
ty CallCtxt
_) = OutType
ty
contResultType (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (StrictBind { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (StrictArg { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (Select { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contResultType SimplCont
k
contResultType (TickIt CoreTickish
_ SimplCont
k) = SimplCont -> OutType
contResultType SimplCont
k
contHoleType :: SimplCont -> OutType
contHoleType :: SimplCont -> OutType
contHoleType (Stop OutType
ty CallCtxt
_) = OutType
ty
contHoleType (TickIt CoreTickish
_ SimplCont
k) = SimplCont -> OutType
contHoleType SimplCont
k
contHoleType (CastIt OutCoercion
co SimplCont
_) = OutCoercion -> OutType
coercionLKind OutCoercion
co
contHoleType (StrictBind { sc_bndr :: SimplCont -> InId
sc_bndr = InId
b, sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se })
= DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
dup StaticEnv
se (InId -> OutType
idType InId
b)
contHoleType (StrictArg { sc_fun_ty :: SimplCont -> OutType
sc_fun_ty = OutType
ty }) = OutType -> OutType
funArgTy OutType
ty
contHoleType (ApplyToTy { sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
ty }) = OutType
ty
contHoleType (ApplyToVal { sc_hole_ty :: SimplCont -> OutType
sc_hole_ty = OutType
ty }) = OutType
ty
contHoleType (Select { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
d, sc_bndr :: SimplCont -> InId
sc_bndr = InId
b, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se })
= DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
d StaticEnv
se (InId -> OutType
idType InId
b)
contHoleScaling :: SimplCont -> Mult
contHoleScaling :: SimplCont -> OutType
contHoleScaling (Stop OutType
_ CallCtxt
_) = OutType
One
contHoleScaling (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> OutType
contHoleScaling SimplCont
k
contHoleScaling (StrictBind { sc_bndr :: SimplCont -> InId
sc_bndr = InId
id, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= InId -> OutType
idMult InId
id OutType -> OutType -> OutType
`mkMultMul` SimplCont -> OutType
contHoleScaling SimplCont
k
contHoleScaling (Select { sc_bndr :: SimplCont -> InId
sc_bndr = InId
id, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= InId -> OutType
idMult InId
id OutType -> OutType -> OutType
`mkMultMul` SimplCont -> OutType
contHoleScaling SimplCont
k
contHoleScaling (StrictArg { sc_fun_ty :: SimplCont -> OutType
sc_fun_ty = OutType
fun_ty, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= OutType
w OutType -> OutType -> OutType
`mkMultMul` SimplCont -> OutType
contHoleScaling SimplCont
k
where
(OutType
w, OutType
_, OutType
_) = OutType -> (OutType, OutType, OutType)
splitFunTy OutType
fun_ty
contHoleScaling (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contHoleScaling SimplCont
k
contHoleScaling (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> OutType
contHoleScaling SimplCont
k
contHoleScaling (TickIt CoreTickish
_ SimplCont
k) = SimplCont -> OutType
contHoleScaling SimplCont
k
countArgs :: SimplCont -> Int
countArgs :: SimplCont -> Int
countArgs (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SimplCont -> Int
countArgs SimplCont
cont
countArgs (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SimplCont -> Int
countArgs SimplCont
cont
countArgs SimplCont
_ = Int
0
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
contArgs SimplCont
cont
| SimplCont -> Bool
lone SimplCont
cont = (Bool
True, [], SimplCont
cont)
| Bool
otherwise = [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [] SimplCont
cont
where
lone :: SimplCont -> Bool
lone (ApplyToTy {}) = Bool
False
lone (ApplyToVal {}) = Bool
False
lone (CastIt {}) = Bool
False
lone SimplCont
_ = Bool
True
go :: [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [ArgSummary]
args (ApplyToVal { sc_arg :: SimplCont -> InExpr
sc_arg = InExpr
arg, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go (InExpr -> StaticEnv -> ArgSummary
is_interesting InExpr
arg StaticEnv
se ArgSummary -> [ArgSummary] -> [ArgSummary]
forall a. a -> [a] -> [a]
: [ArgSummary]
args) SimplCont
k
go [ArgSummary]
args (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [ArgSummary]
args SimplCont
k
go [ArgSummary]
args (CastIt OutCoercion
_ SimplCont
k) = [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go [ArgSummary]
args SimplCont
k
go [ArgSummary]
args SimplCont
k = (Bool
False, [ArgSummary] -> [ArgSummary]
forall a. [a] -> [a]
reverse [ArgSummary]
args, SimplCont
k)
is_interesting :: InExpr -> StaticEnv -> ArgSummary
is_interesting InExpr
arg StaticEnv
se = StaticEnv -> InExpr -> ArgSummary
interestingArg StaticEnv
se InExpr
arg
mkArgInfo :: SimplEnv
-> Id
-> [CoreRule]
-> Int
-> SimplCont
-> ArgInfo
mkArgInfo :: StaticEnv -> InId -> [CoreRule] -> Int -> SimplCont -> ArgInfo
mkArgInfo StaticEnv
env InId
fun [CoreRule]
rules Int
n_val_args SimplCont
call_cont
| Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< InId -> Int
idArity InId
fun
= ArgInfo :: InId
-> [ArgSpec] -> FunRules -> Bool -> [Demand] -> [Int] -> ArgInfo
ArgInfo { ai_fun :: InId
ai_fun = InId
fun, ai_args :: [ArgSpec]
ai_args = []
, ai_rules :: FunRules
ai_rules = FunRules
fun_rules
, ai_encl :: Bool
ai_encl = Bool
False
, ai_dmds :: [Demand]
ai_dmds = [Demand]
vanilla_dmds
, ai_discs :: [Int]
ai_discs = [Int]
vanilla_discounts }
| Bool
otherwise
= ArgInfo :: InId
-> [ArgSpec] -> FunRules -> Bool -> [Demand] -> [Int] -> ArgInfo
ArgInfo { ai_fun :: InId
ai_fun = InId
fun
, ai_args :: [ArgSpec]
ai_args = []
, ai_rules :: FunRules
ai_rules = FunRules
fun_rules
, ai_encl :: Bool
ai_encl = [CoreRule] -> SimplCont -> Bool
interestingArgContext [CoreRule]
rules SimplCont
call_cont
, ai_dmds :: [Demand]
ai_dmds = OutType -> [Demand] -> [Demand]
add_type_strictness (InId -> OutType
idType InId
fun) [Demand]
arg_dmds
, ai_discs :: [Int]
ai_discs = [Int]
arg_discounts }
where
fun_rules :: FunRules
fun_rules = [CoreRule] -> FunRules
mkFunRules [CoreRule]
rules
vanilla_discounts, arg_discounts :: [Int]
vanilla_discounts :: [Int]
vanilla_discounts = Int -> [Int]
forall a. a -> [a]
repeat Int
0
arg_discounts :: [Int]
arg_discounts = case InId -> Unfolding
idUnfolding InId
fun of
CoreUnfolding {uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfIfGoodArgs {ug_args :: UnfoldingGuidance -> [Int]
ug_args = [Int]
discounts}}
-> [Int]
discounts [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
vanilla_discounts
Unfolding
_ -> [Int]
vanilla_discounts
vanilla_dmds, arg_dmds :: [Demand]
vanilla_dmds :: [Demand]
vanilla_dmds = Demand -> [Demand]
forall a. a -> [a]
repeat Demand
topDmd
arg_dmds :: [Demand]
arg_dmds
| Bool -> Bool
not (SimplMode -> Bool
sm_inline (StaticEnv -> SimplMode
seMode StaticEnv
env))
= [Demand]
vanilla_dmds
| Bool
otherwise
=
case DmdSig -> ([Demand], Divergence)
splitDmdSig (InId -> DmdSig
idDmdSig InId
fun) of
([Demand]
demands, Divergence
result_info)
| Bool -> Bool
not ([Demand]
demands [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
n_val_args)
->
if Divergence -> Bool
isDeadEndDiv Divergence
result_info then
[Demand]
demands
else
[Demand]
demands [Demand] -> [Demand] -> [Demand]
forall a. [a] -> [a] -> [a]
++ [Demand]
vanilla_dmds
| Bool
otherwise
-> Bool -> SDoc -> [Demand] -> [Demand]
forall a. HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace Bool
True (String -> SDoc
text String
"More demands than arity" SDoc -> SDoc -> SDoc
<+> InId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InId
fun SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InId -> Int
idArity InId
fun)
SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_val_args SDoc -> SDoc -> SDoc
<+> [Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
demands) ([Demand] -> [Demand]) -> [Demand] -> [Demand]
forall a b. (a -> b) -> a -> b
$
[Demand]
vanilla_dmds
add_type_strictness :: Type -> [Demand] -> [Demand]
add_type_strictness :: OutType -> [Demand] -> [Demand]
add_type_strictness OutType
fun_ty [Demand]
dmds
| [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
dmds = []
| Just (InId
_, OutType
fun_ty') <- OutType -> Maybe (InId, OutType)
splitForAllTyCoVar_maybe OutType
fun_ty
= OutType -> [Demand] -> [Demand]
add_type_strictness OutType
fun_ty' [Demand]
dmds
| Just (OutType
_, OutType
arg_ty, OutType
fun_ty') <- OutType -> Maybe (OutType, OutType, OutType)
splitFunTy_maybe OutType
fun_ty
, Demand
dmd : [Demand]
rest_dmds <- [Demand]
dmds
, let dmd' :: Demand
dmd' = case HasDebugCallStack => OutType -> Maybe Bool
OutType -> Maybe Bool
isLiftedType_maybe OutType
arg_ty of
Just Bool
False -> Demand -> Demand
strictifyDmd Demand
dmd
Maybe Bool
_ -> Demand
dmd
= Demand
dmd' Demand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
: OutType -> [Demand] -> [Demand]
add_type_strictness OutType
fun_ty' [Demand]
rest_dmds
| Bool
otherwise
= [Demand]
dmds
lazyArgContext :: ArgInfo -> CallCtxt
lazyArgContext :: ArgInfo -> CallCtxt
lazyArgContext (ArgInfo { ai_encl :: ArgInfo -> Bool
ai_encl = Bool
encl_rules, ai_discs :: ArgInfo -> [Int]
ai_discs = [Int]
discs })
| Bool
encl_rules = CallCtxt
RuleArgCtxt
| Int
disc:[Int]
_ <- [Int]
discs, Int
disc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = CallCtxt
DiscArgCtxt
| Bool
otherwise = CallCtxt
BoringCtxt
strictArgContext :: ArgInfo -> CallCtxt
strictArgContext :: ArgInfo -> CallCtxt
strictArgContext (ArgInfo { ai_encl :: ArgInfo -> Bool
ai_encl = Bool
encl_rules, ai_discs :: ArgInfo -> [Int]
ai_discs = [Int]
discs })
| Bool
encl_rules = CallCtxt
RuleArgCtxt
| Int
disc:[Int]
_ <- [Int]
discs, Int
disc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = CallCtxt
DiscArgCtxt
| Bool
otherwise = CallCtxt
RhsCtxt
interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
interestingCallContext :: StaticEnv -> SimplCont -> CallCtxt
interestingCallContext StaticEnv
env SimplCont
cont
= SimplCont -> CallCtxt
interesting SimplCont
cont
where
interesting :: SimplCont -> CallCtxt
interesting (Select {})
| SimplMode -> Bool
sm_case_case (StaticEnv -> SimplMode
getMode StaticEnv
env) = CallCtxt
CaseCtxt
| Bool
otherwise = CallCtxt
BoringCtxt
interesting (ApplyToVal {}) = CallCtxt
ValAppCtxt
interesting (StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
fun }) = ArgInfo -> CallCtxt
strictArgContext ArgInfo
fun
interesting (StrictBind {}) = CallCtxt
BoringCtxt
interesting (Stop OutType
_ CallCtxt
cci) = CallCtxt
cci
interesting (TickIt CoreTickish
_ SimplCont
k) = SimplCont -> CallCtxt
interesting SimplCont
k
interesting (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k }) = SimplCont -> CallCtxt
interesting SimplCont
k
interesting (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> CallCtxt
interesting SimplCont
k
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
interestingArgContext [CoreRule]
rules SimplCont
call_cont
= [CoreRule] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [CoreRule]
rules Bool -> Bool -> Bool
|| Bool
enclosing_fn_has_rules
where
enclosing_fn_has_rules :: Bool
enclosing_fn_has_rules = SimplCont -> Bool
go SimplCont
call_cont
go :: SimplCont -> Bool
go (Select {}) = Bool
False
go (ApplyToVal {}) = Bool
False
go (ApplyToTy {}) = Bool
False
go (StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
fun }) = ArgInfo -> Bool
ai_encl ArgInfo
fun
go (StrictBind {}) = Bool
False
go (CastIt OutCoercion
_ SimplCont
c) = SimplCont -> Bool
go SimplCont
c
go (Stop OutType
_ CallCtxt
RuleArgCtxt) = Bool
True
go (Stop OutType
_ CallCtxt
_) = Bool
False
go (TickIt CoreTickish
_ SimplCont
c) = SimplCont -> Bool
go SimplCont
c
interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
interestingArg :: StaticEnv -> InExpr -> ArgSummary
interestingArg StaticEnv
env InExpr
e = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
0 InExpr
e
where
go :: StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n (Var InId
v)
= case StaticEnv -> InId -> SimplSR
substId StaticEnv
env InId
v of
DoneId InId
v' -> Int -> InId -> ArgSummary
go_var Int
n InId
v'
DoneEx InExpr
e Maybe Int
_ -> StaticEnv -> Int -> InExpr -> ArgSummary
go (StaticEnv -> StaticEnv
zapSubstEnv StaticEnv
env) Int
n InExpr
e
ContEx TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids InExpr
e -> StaticEnv -> Int -> InExpr -> ArgSummary
go (StaticEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> StaticEnv
setSubstEnv StaticEnv
env TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids) Int
n InExpr
e
go StaticEnv
_ Int
_ (Lit {}) = ArgSummary
ValueArg
go StaticEnv
_ Int
_ (Type OutType
_) = ArgSummary
TrivArg
go StaticEnv
_ Int
_ (Coercion OutCoercion
_) = ArgSummary
TrivArg
go StaticEnv
env Int
n (App InExpr
fn (Type OutType
_)) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
fn
go StaticEnv
env Int
n (App InExpr
fn InExpr
_) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) InExpr
fn
go StaticEnv
env Int
n (Tick CoreTickish
_ InExpr
a) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
a
go StaticEnv
env Int
n (Cast InExpr
e OutCoercion
_) = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
e
go StaticEnv
env Int
n (Lam InId
v InExpr
e)
| InId -> Bool
isTyVar InId
v = StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env Int
n InExpr
e
| Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 = ArgSummary
NonTrivArg
| Bool
otherwise = ArgSummary
ValueArg
go StaticEnv
_ Int
_ (Case {}) = ArgSummary
NonTrivArg
go StaticEnv
env Int
n (Let Bind InId
b InExpr
e) = case StaticEnv -> Int -> InExpr -> ArgSummary
go StaticEnv
env' Int
n InExpr
e of
ArgSummary
ValueArg -> ArgSummary
ValueArg
ArgSummary
_ -> ArgSummary
NonTrivArg
where
env' :: StaticEnv
env' = StaticEnv
env StaticEnv -> [InId] -> StaticEnv
`addNewInScopeIds` Bind InId -> [InId]
forall b. Bind b -> [b]
bindersOf Bind InId
b
go_var :: Int -> InId -> ArgSummary
go_var Int
n InId
v
| InId -> Bool
isConLikeId InId
v = ArgSummary
ValueArg
| InId -> Int
idArity InId
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = ArgSummary
ValueArg
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = ArgSummary
NonTrivArg
| Bool
conlike_unfolding = ArgSummary
ValueArg
| Bool
otherwise = ArgSummary
TrivArg
where
conlike_unfolding :: Bool
conlike_unfolding = Unfolding -> Bool
isConLikeUnfolding (InId -> Unfolding
idUnfolding InId
v)
simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv
simplEnvForGHCi :: Logger -> DynFlags -> StaticEnv
simplEnvForGHCi Logger
logger DynFlags
dflags
= SimplMode -> StaticEnv
mkSimplEnv (SimplMode -> StaticEnv) -> SimplMode -> StaticEnv
forall a b. (a -> b) -> a -> b
$ SimplMode :: [String]
-> CompilerPhase
-> UnfoldingOpts
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Logger
-> DynFlags
-> SimplMode
SimplMode { sm_names :: [String]
sm_names = [String
"GHCi"]
, sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
, sm_logger :: Logger
sm_logger = Logger
logger
, sm_dflags :: DynFlags
sm_dflags = DynFlags
dflags
, sm_uf_opts :: UnfoldingOpts
sm_uf_opts = UnfoldingOpts
uf_opts
, sm_rules :: Bool
sm_rules = Bool
rules_on
, sm_inline :: Bool
sm_inline = Bool
False
, sm_eta_expand :: Bool
sm_eta_expand = Bool
eta_expand_on
, sm_case_case :: Bool
sm_case_case = Bool
True
, sm_pre_inline :: Bool
sm_pre_inline = Bool
pre_inline_on
}
where
rules_on :: Bool
rules_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags
eta_expand_on :: Bool
eta_expand_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion DynFlags
dflags
pre_inline_on :: Bool
pre_inline_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining DynFlags
dflags
uf_opts :: UnfoldingOpts
uf_opts = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings Activation
unf_act SimplMode
current_mode
= SimplMode
current_mode { sm_phase :: CompilerPhase
sm_phase = Activation -> CompilerPhase
phaseFromActivation Activation
unf_act
, sm_inline :: Bool
sm_inline = Bool
True
, sm_eta_expand :: Bool
sm_eta_expand = Bool
False }
where
phaseFromActivation :: Activation -> CompilerPhase
phaseFromActivation (ActiveAfter SourceText
_ Int
n) = Int -> CompilerPhase
Phase Int
n
phaseFromActivation Activation
_ = CompilerPhase
InitialPhase
updModeForRules :: SimplMode -> SimplMode
updModeForRules :: SimplMode -> SimplMode
updModeForRules SimplMode
current_mode
= SimplMode
current_mode { sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
, sm_inline :: Bool
sm_inline = Bool
False
, sm_rules :: Bool
sm_rules = Bool
False
, sm_eta_expand :: Bool
sm_eta_expand = Bool
False }
activeUnfolding :: SimplMode -> Id -> Bool
activeUnfolding :: SimplMode -> InId -> Bool
activeUnfolding SimplMode
mode InId
id
| Unfolding -> Bool
isCompulsoryUnfolding (InId -> Unfolding
realIdUnfolding InId
id)
= Bool
True
| Bool
otherwise
= CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode) (InId -> Activation
idInlineActivation InId
id)
Bool -> Bool -> Bool
&& SimplMode -> Bool
sm_inline SimplMode
mode
getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
getUnfoldingInRuleMatch :: StaticEnv -> InScopeEnv
getUnfoldingInRuleMatch StaticEnv
env
= (InScopeSet
in_scope, InId -> Unfolding
id_unf)
where
in_scope :: InScopeSet
in_scope = StaticEnv -> InScopeSet
seInScope StaticEnv
env
mode :: SimplMode
mode = StaticEnv -> SimplMode
getMode StaticEnv
env
id_unf :: InId -> Unfolding
id_unf InId
id | InId -> Bool
unf_is_active InId
id = InId -> Unfolding
idUnfolding InId
id
| Bool
otherwise = Unfolding
NoUnfolding
unf_is_active :: InId -> Bool
unf_is_active InId
id
| Bool -> Bool
not (SimplMode -> Bool
sm_rules SimplMode
mode) =
Unfolding -> Bool
isStableUnfolding (InId -> Unfolding
realIdUnfolding InId
id)
| Bool
otherwise = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode) (InId -> Activation
idInlineActivation InId
id)
activeRule :: SimplMode -> Activation -> Bool
activeRule :: SimplMode -> Activation -> Bool
activeRule SimplMode
mode
| Bool -> Bool
not (SimplMode -> Bool
sm_rules SimplMode
mode) = \Activation
_ -> Bool
False
| Bool
otherwise = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode)
preInlineUnconditionally
:: SimplEnv -> TopLevelFlag -> InId
-> InExpr -> StaticEnv
-> Maybe SimplEnv
preInlineUnconditionally :: StaticEnv
-> TopLevelFlag -> InId -> InExpr -> StaticEnv -> Maybe StaticEnv
preInlineUnconditionally StaticEnv
env TopLevelFlag
top_lvl InId
bndr InExpr
rhs StaticEnv
rhs_env
| Bool -> Bool
not Bool
pre_inline_unconditionally = Maybe StaticEnv
forall a. Maybe a
Nothing
| Bool -> Bool
not Bool
active = Maybe StaticEnv
forall a. Maybe a
Nothing
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl Bool -> Bool -> Bool
&& InId -> Bool
isDeadEndId InId
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| InId -> Bool
isCoVar InId
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| InId -> Bool
isExitJoinId InId
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| Bool -> Bool
not (OccInfo -> Bool
one_occ (InId -> OccInfo
idOccInfo InId
bndr)) = Maybe StaticEnv
forall a. Maybe a
Nothing
| Bool -> Bool
not (Unfolding -> Bool
isStableUnfolding Unfolding
unf) = StaticEnv -> Maybe StaticEnv
forall a. a -> Maybe a
Just (StaticEnv -> Maybe StaticEnv) -> StaticEnv -> Maybe StaticEnv
forall a b. (a -> b) -> a -> b
$! (InExpr -> StaticEnv
extend_subst_with InExpr
rhs)
| Bool -> Bool
not (InlinePragma -> Bool
isInlinePragma InlinePragma
inline_prag)
, Just InExpr
inl <- Unfolding -> Maybe InExpr
maybeUnfoldingTemplate Unfolding
unf = StaticEnv -> Maybe StaticEnv
forall a. a -> Maybe a
Just (StaticEnv -> Maybe StaticEnv) -> StaticEnv -> Maybe StaticEnv
forall a b. (a -> b) -> a -> b
$! (InExpr -> StaticEnv
extend_subst_with InExpr
inl)
| Bool
otherwise = Maybe StaticEnv
forall a. Maybe a
Nothing
where
unf :: Unfolding
unf = InId -> Unfolding
idUnfolding InId
bndr
extend_subst_with :: InExpr -> StaticEnv
extend_subst_with InExpr
inl_rhs = StaticEnv -> InId -> SimplSR -> StaticEnv
extendIdSubst StaticEnv
env InId
bndr (SimplSR -> StaticEnv) -> SimplSR -> StaticEnv
forall a b. (a -> b) -> a -> b
$! (StaticEnv -> InExpr -> SimplSR
mkContEx StaticEnv
rhs_env InExpr
inl_rhs)
one_occ :: OccInfo -> Bool
one_occ OccInfo
IAmDead = Bool
True
one_occ OneOcc{ occ_n_br :: OccInfo -> Int
occ_n_br = Int
1
, occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
NotInsideLam } = TopLevelFlag -> Bool
isNotTopLevel TopLevelFlag
top_lvl Bool -> Bool -> Bool
|| Bool
early_phase
one_occ OneOcc{ occ_n_br :: OccInfo -> Int
occ_n_br = Int
1
, occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
IsInsideLam
, occ_int_cxt :: OccInfo -> InterestingCxt
occ_int_cxt = InterestingCxt
IsInteresting } = InExpr -> Bool
canInlineInLam InExpr
rhs
one_occ OccInfo
_ = Bool
False
pre_inline_unconditionally :: Bool
pre_inline_unconditionally = SimplMode -> Bool
sm_pre_inline SimplMode
mode
mode :: SimplMode
mode = StaticEnv -> SimplMode
getMode StaticEnv
env
active :: Bool
active = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode) (InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inline_prag)
inline_prag :: InlinePragma
inline_prag = InId -> InlinePragma
idInlinePragma InId
bndr
canInlineInLam :: InExpr -> Bool
canInlineInLam (Lit Literal
_) = Bool
True
canInlineInLam (Lam InId
b InExpr
e) = InId -> Bool
isRuntimeVar InId
b Bool -> Bool -> Bool
|| InExpr -> Bool
canInlineInLam InExpr
e
canInlineInLam (Tick CoreTickish
t InExpr
e) = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
&& InExpr -> Bool
canInlineInLam InExpr
e
canInlineInLam InExpr
_ = Bool
False
early_phase :: Bool
early_phase = SimplMode -> CompilerPhase
sm_phase SimplMode
mode CompilerPhase -> CompilerPhase -> Bool
forall a. Eq a => a -> a -> Bool
/= CompilerPhase
FinalPhase
postInlineUnconditionally
:: SimplEnv -> TopLevelFlag
-> OutId
-> OccInfo
-> OutExpr
-> Bool
postInlineUnconditionally :: StaticEnv -> TopLevelFlag -> InId -> OccInfo -> InExpr -> Bool
postInlineUnconditionally StaticEnv
env TopLevelFlag
top_lvl InId
bndr OccInfo
occ_info InExpr
rhs
| Bool -> Bool
not Bool
active = Bool
False
| OccInfo -> Bool
isWeakLoopBreaker OccInfo
occ_info = Bool
False
| Unfolding -> Bool
isStableUnfolding Unfolding
unfolding = Bool
False
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Bool
False
| InExpr -> Bool
exprIsTrivial InExpr
rhs = Bool
True
| Bool
otherwise
= case OccInfo
occ_info of
OneOcc { occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
in_lam, occ_int_cxt :: OccInfo -> InterestingCxt
occ_int_cxt = InterestingCxt
int_cxt, occ_n_br :: OccInfo -> Int
occ_n_br = Int
n_br }
-> Int
n_br Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100
Bool -> Bool -> Bool
&& UnfoldingOpts -> Unfolding -> Bool
smallEnoughToInline UnfoldingOpts
uf_opts Unfolding
unfolding
Bool -> Bool -> Bool
&& (InsideLam
in_lam InsideLam -> InsideLam -> Bool
forall a. Eq a => a -> a -> Bool
== InsideLam
NotInsideLam Bool -> Bool -> Bool
||
(Unfolding -> Bool
isCheapUnfolding Unfolding
unfolding Bool -> Bool -> Bool
&& InterestingCxt
int_cxt InterestingCxt -> InterestingCxt -> Bool
forall a. Eq a => a -> a -> Bool
== InterestingCxt
IsInteresting))
OccInfo
IAmDead -> Bool
True
OccInfo
_ -> Bool
False
where
unfolding :: Unfolding
unfolding = InId -> Unfolding
idUnfolding InId
bndr
uf_opts :: UnfoldingOpts
uf_opts = StaticEnv -> UnfoldingOpts
seUnfoldingOpts StaticEnv
env
active :: Bool
active = CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase (StaticEnv -> SimplMode
getMode StaticEnv
env)) (InId -> Activation
idInlineActivation InId
bndr)
mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
mkLam :: StaticEnv -> [InId] -> InExpr -> SimplCont -> SimplM InExpr
mkLam StaticEnv
_env [] InExpr
body SimplCont
_cont
= InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return InExpr
body
mkLam StaticEnv
env [InId]
bndrs InExpr
body SimplCont
cont
= do { DynFlags
dflags <- SimplM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
body }
where
mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
mkLam' :: DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs (Cast InExpr
body OutCoercion
co)
| Bool -> Bool
not ((InId -> Bool) -> [InId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InId -> Bool
bad [InId]
bndrs)
= do { InExpr
lam <- DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
body
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (InExpr -> OutCoercion -> InExpr
mkCast InExpr
lam (Role -> [InId] -> OutCoercion -> OutCoercion
mkPiCos Role
Representational [InId]
bndrs OutCoercion
co)) }
where
co_vars :: TyCoVarSet
co_vars = OutCoercion -> TyCoVarSet
tyCoVarsOfCo OutCoercion
co
bad :: InId -> Bool
bad InId
bndr = InId -> Bool
isCoVar InId
bndr Bool -> Bool -> Bool
&& InId
bndr InId -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
co_vars
mkLam' DynFlags
dflags [InId]
bndrs body :: InExpr
body@(Lam {})
= DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags ([InId]
bndrs [InId] -> [InId] -> [InId]
forall a. [a] -> [a] -> [a]
++ [InId]
bndrs1) InExpr
body1
where
([InId]
bndrs1, InExpr
body1) = InExpr -> ([InId], InExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders InExpr
body
mkLam' DynFlags
dflags [InId]
bndrs (Tick CoreTickish
t InExpr
expr)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
= CoreTickish -> InExpr -> InExpr
mkTick CoreTickish
t (InExpr -> InExpr) -> SimplM InExpr -> SimplM InExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> [InId] -> InExpr -> SimplM InExpr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
expr
mkLam' DynFlags
dflags [InId]
bndrs InExpr
body
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoEtaReduction DynFlags
dflags
, Just InExpr
etad_lam <- [InId] -> InExpr -> Maybe InExpr
tryEtaReduce [InId]
bndrs InExpr
body
= do { Tick -> SimplM ()
tick (InId -> Tick
EtaReduction ([InId] -> InId
forall a. [a] -> a
head [InId]
bndrs))
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return InExpr
etad_lam }
| Bool -> Bool
not (SimplCont -> Bool
contIsRhs SimplCont
cont)
, SimplMode -> Bool
sm_eta_expand (StaticEnv -> SimplMode
getMode StaticEnv
env)
, (InId -> Bool) -> [InId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InId -> Bool
isRuntimeVar [InId]
bndrs
, let body_arity :: ArityType
body_arity = DynFlags -> InExpr -> ArityType
exprEtaExpandArity DynFlags
dflags InExpr
body
, ArityType -> Bool
expandableArityType ArityType
body_arity
= do { Tick -> SimplM ()
tick (InId -> Tick
EtaExpansion ([InId] -> InId
forall a. [a] -> a
head [InId]
bndrs))
; let res :: InExpr
res = [InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
bndrs (ArityType -> InExpr -> InExpr
etaExpandAT ArityType
body_arity InExpr
body)
; String -> SDoc -> SimplM ()
traceSmpl String
"eta expand" ([SDoc] -> SDoc
vcat [String -> SDoc
text String
"before" SDoc -> SDoc -> SDoc
<+> InExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
bndrs InExpr
body)
, String -> SDoc
text String
"after" SDoc -> SDoc -> SDoc
<+> InExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InExpr
res])
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return InExpr
res }
| Bool
otherwise
= InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
bndrs InExpr
body)
tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
-> SimplM (ArityType, OutExpr)
tryEtaExpandRhs :: SimplMode -> InId -> InExpr -> SimplM (ArityType, InExpr)
tryEtaExpandRhs SimplMode
mode InId
bndr InExpr
rhs
| Just Int
join_arity <- InId -> Maybe Int
isJoinId_maybe InId
bndr
= do { let ([InId]
join_bndrs, InExpr
join_body) = Int -> InExpr -> ([InId], InExpr)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity InExpr
rhs
oss :: [OneShotInfo]
oss = [InId -> OneShotInfo
idOneShotInfo InId
id | InId
id <- [InId]
join_bndrs, InId -> Bool
isId InId
id]
arity_type :: ArityType
arity_type | InExpr -> Bool
exprIsDeadEnd InExpr
join_body = [OneShotInfo] -> ArityType
mkBotArityType [OneShotInfo]
oss
| Bool
otherwise = [OneShotInfo] -> ArityType
mkTopArityType [OneShotInfo]
oss
; (ArityType, InExpr) -> SimplM (ArityType, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArityType
arity_type, InExpr
rhs) }
| SimplMode -> Bool
sm_eta_expand SimplMode
mode
, Int
new_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
old_arity
, InExpr -> Bool
want_eta InExpr
rhs
= do { Tick -> SimplM ()
tick (InId -> Tick
EtaExpansion InId
bndr)
; (ArityType, InExpr) -> SimplM (ArityType, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArityType
arity_type, ArityType -> InExpr -> InExpr
etaExpandAT ArityType
arity_type InExpr
rhs) }
| Bool
otherwise
= (ArityType, InExpr) -> SimplM (ArityType, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArityType
arity_type, InExpr
rhs)
where
dflags :: DynFlags
dflags = SimplMode -> DynFlags
sm_dflags SimplMode
mode
old_arity :: Int
old_arity = InExpr -> Int
exprArity InExpr
rhs
arity_type :: ArityType
arity_type = DynFlags -> InId -> InExpr -> Int -> ArityType
findRhsArity DynFlags
dflags InId
bndr InExpr
rhs Int
old_arity
ArityType -> Int -> ArityType
`maxWithArity` InId -> Int
idCallArity InId
bndr
new_arity :: Int
new_arity = ArityType -> Int
arityTypeArity ArityType
arity_type
want_eta :: InExpr -> Bool
want_eta (Cast InExpr
e OutCoercion
_) = InExpr -> Bool
want_eta InExpr
e
want_eta (Tick CoreTickish
_ InExpr
e) = InExpr -> Bool
want_eta InExpr
e
want_eta (Lam InId
b InExpr
e) | InId -> Bool
isTyVar InId
b = InExpr -> Bool
want_eta InExpr
e
want_eta (App InExpr
e InExpr
a) | InExpr -> Bool
exprIsTrivial InExpr
a = InExpr -> Bool
want_eta InExpr
e
want_eta (Var {}) = Bool
False
want_eta (Lit {}) = Bool
False
want_eta InExpr
_ = Bool
True
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
-> OutExpr -> SimplM ([OutBind], OutExpr)
abstractFloats :: UnfoldingOpts
-> TopLevelFlag
-> [InId]
-> SimplFloats
-> InExpr
-> SimplM ([Bind InId], InExpr)
abstractFloats UnfoldingOpts
uf_opts TopLevelFlag
top_lvl [InId]
main_tvs SimplFloats
floats InExpr
body
= Bool
-> SimplM ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr)
forall a. HasCallStack => Bool -> a -> a
assert ([Bind InId] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Bind InId]
body_floats) (SimplM ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr))
-> SimplM ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr)
forall a b. (a -> b) -> a -> b
$
Bool
-> SimplM ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr)
forall a. HasCallStack => Bool -> a -> a
assert (OrdList (Bind InId) -> Bool
forall a. OrdList a -> Bool
isNilOL (SimplFloats -> OrdList (Bind InId)
sfJoinFloats SimplFloats
floats)) (SimplM ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr))
-> SimplM ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr)
forall a b. (a -> b) -> a -> b
$
do { (Subst
subst, [Bind InId]
float_binds) <- (Subst -> Bind InId -> SimplM (Subst, Bind InId))
-> Subst -> [Bind InId] -> SimplM (Subst, [Bind InId])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM Subst -> Bind InId -> SimplM (Subst, Bind InId)
abstract Subst
empty_subst [Bind InId]
body_floats
; ([Bind InId], InExpr) -> SimplM ([Bind InId], InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bind InId]
float_binds, HasDebugCallStack => Subst -> InExpr -> InExpr
Subst -> InExpr -> InExpr
GHC.Core.Subst.substExpr Subst
subst InExpr
body) }
where
is_top_lvl :: Bool
is_top_lvl = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
main_tv_set :: TyCoVarSet
main_tv_set = [InId] -> TyCoVarSet
mkVarSet [InId]
main_tvs
body_floats :: [Bind InId]
body_floats = LetFloats -> [Bind InId]
letFloatBinds (SimplFloats -> LetFloats
sfLetFloats SimplFloats
floats)
empty_subst :: Subst
empty_subst = InScopeSet -> Subst
GHC.Core.Subst.mkEmptySubst (SimplFloats -> InScopeSet
sfInScope SimplFloats
floats)
abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)
abstract :: Subst -> Bind InId -> SimplM (Subst, Bind InId)
abstract Subst
subst (NonRec InId
id InExpr
rhs)
= do { (InId
poly_id1, InExpr
poly_app) <- [InId] -> InId -> SimplM (InId, InExpr)
mk_poly1 [InId]
tvs_here InId
id
; let (InId
poly_id2, InExpr
poly_rhs) = InId -> [InId] -> InExpr -> (InId, InExpr)
mk_poly2 InId
poly_id1 [InId]
tvs_here InExpr
rhs'
!subst' :: Subst
subst' = Subst -> InId -> InExpr -> Subst
GHC.Core.Subst.extendIdSubst Subst
subst InId
id InExpr
poly_app
; (Subst, Bind InId) -> SimplM (Subst, Bind InId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst', InId -> InExpr -> Bind InId
forall b. b -> Expr b -> Bind b
NonRec InId
poly_id2 InExpr
poly_rhs) }
where
rhs' :: InExpr
rhs' = HasDebugCallStack => Subst -> InExpr -> InExpr
Subst -> InExpr -> InExpr
GHC.Core.Subst.substExpr Subst
subst InExpr
rhs
tvs_here :: [InId]
tvs_here = [InId] -> [InId]
scopedSort ([InId] -> [InId]) -> [InId] -> [InId]
forall a b. (a -> b) -> a -> b
$
(InId -> Bool) -> [InId] -> [InId]
forall a. (a -> Bool) -> [a] -> [a]
filter (InId -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
main_tv_set) ([InId] -> [InId]) -> [InId] -> [InId]
forall a b. (a -> b) -> a -> b
$
[InId] -> [InId]
closeOverKindsList ([InId] -> [InId]) -> [InId] -> [InId]
forall a b. (a -> b) -> a -> b
$
(InId -> Bool) -> InExpr -> [InId]
exprSomeFreeVarsList InId -> Bool
isTyVar InExpr
rhs'
abstract Subst
subst (Rec [(InId, InExpr)]
prs)
= do { ([InId]
poly_ids, [InExpr]
poly_apps) <- (InId -> SimplM (InId, InExpr))
-> [InId] -> SimplM ([InId], [InExpr])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([InId] -> InId -> SimplM (InId, InExpr)
mk_poly1 [InId]
tvs_here) [InId]
ids
; let subst' :: Subst
subst' = Subst -> [(InId, InExpr)] -> Subst
GHC.Core.Subst.extendSubstList Subst
subst ([InId]
ids [InId] -> [InExpr] -> [(InId, InExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [InExpr]
poly_apps)
poly_pairs :: [(InId, InExpr)]
poly_pairs = [ InId -> [InId] -> InExpr -> (InId, InExpr)
mk_poly2 InId
poly_id [InId]
tvs_here InExpr
rhs'
| (InId
poly_id, InExpr
rhs) <- [InId]
poly_ids [InId] -> [InExpr] -> [(InId, InExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [InExpr]
rhss
, let rhs' :: InExpr
rhs' = HasDebugCallStack => Subst -> InExpr -> InExpr
Subst -> InExpr -> InExpr
GHC.Core.Subst.substExpr Subst
subst' InExpr
rhs ]
; (Subst, Bind InId) -> SimplM (Subst, Bind InId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst', [(InId, InExpr)] -> Bind InId
forall b. [(b, Expr b)] -> Bind b
Rec [(InId, InExpr)]
poly_pairs) }
where
([InId]
ids,[InExpr]
rhss) = [(InId, InExpr)] -> ([InId], [InExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(InId, InExpr)]
prs
tvs_here :: [InId]
tvs_here = [InId] -> [InId]
scopedSort [InId]
main_tvs
mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
mk_poly1 :: [InId] -> InId -> SimplM (InId, InExpr)
mk_poly1 [InId]
tvs_here InId
var
= do { Unique
uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let poly_name :: Name
poly_name = Name -> Unique -> Name
setNameUnique (InId -> Name
idName InId
var) Unique
uniq
poly_ty :: OutType
poly_ty = [InId] -> OutType -> OutType
mkInfForAllTys [InId]
tvs_here (InId -> OutType
idType InId
var)
poly_id :: InId
poly_id = InId -> [InId] -> InId -> InId
transferPolyIdInfo InId
var [InId]
tvs_here (InId -> InId) -> InId -> InId
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Name -> OutType -> OutType -> InId
Name -> OutType -> OutType -> InId
mkLocalId Name
poly_name (InId -> OutType
idMult InId
var) OutType
poly_ty
; (InId, InExpr) -> SimplM (InId, InExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (InId
poly_id, InExpr -> [OutType] -> InExpr
forall b. Expr b -> [OutType] -> Expr b
mkTyApps (InId -> InExpr
forall b. InId -> Expr b
Var InId
poly_id) ([InId] -> [OutType]
mkTyVarTys [InId]
tvs_here)) }
mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)
mk_poly2 :: InId -> [InId] -> InExpr -> (InId, InExpr)
mk_poly2 InId
poly_id [InId]
tvs_here InExpr
rhs
= (InId
poly_id InId -> Unfolding -> InId
`setIdUnfolding` Unfolding
unf, InExpr
poly_rhs)
where
poly_rhs :: InExpr
poly_rhs = [InId] -> InExpr -> InExpr
forall b. [b] -> Expr b -> Expr b
mkLams [InId]
tvs_here InExpr
rhs
unf :: Unfolding
unf = UnfoldingOpts
-> UnfoldingSource -> Bool -> Bool -> InExpr -> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
InlineRhs Bool
is_top_lvl Bool
False InExpr
poly_rhs
prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts :: InExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts InExpr
scrut InId
case_bndr' [InAlt]
alts
| Just (TyCon
tc, [OutType]
tys) <- HasDebugCallStack => OutType -> Maybe (TyCon, [OutType])
OutType -> Maybe (TyCon, [OutType])
splitTyConApp_maybe (InId -> OutType
varType InId
case_bndr')
= do { [Unique]
us <- SimplM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let ([AltCon]
idcs1, [InAlt]
alts1) = TyCon -> [OutType] -> [AltCon] -> [InAlt] -> ([AltCon], [InAlt])
forall b.
TyCon -> [OutType] -> [AltCon] -> [Alt b] -> ([AltCon], [Alt b])
filterAlts TyCon
tc [OutType]
tys [AltCon]
imposs_cons [InAlt]
alts
(Bool
yes2, [InAlt]
alts2) = [Unique]
-> OutType
-> TyCon
-> [OutType]
-> [AltCon]
-> [InAlt]
-> (Bool, [InAlt])
refineDefaultAlt [Unique]
us (InId -> OutType
idMult InId
case_bndr') TyCon
tc [OutType]
tys [AltCon]
idcs1 [InAlt]
alts1
(Bool
yes3, [AltCon]
idcs3, [InAlt]
alts3) = [AltCon] -> [InAlt] -> (Bool, [AltCon], [InAlt])
combineIdenticalAlts [AltCon]
idcs1 [InAlt]
alts2
; Bool -> SimplM () -> SimplM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
yes2 (SimplM () -> SimplM ()) -> SimplM () -> SimplM ()
forall a b. (a -> b) -> a -> b
$ Tick -> SimplM ()
tick (InId -> Tick
FillInCaseDefault InId
case_bndr')
; Bool -> SimplM () -> SimplM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
yes3 (SimplM () -> SimplM ()) -> SimplM () -> SimplM ()
forall a b. (a -> b) -> a -> b
$ Tick -> SimplM ()
tick (InId -> Tick
AltMerge InId
case_bndr')
; ([AltCon], [InAlt]) -> SimplM ([AltCon], [InAlt])
forall (m :: * -> *) a. Monad m => a -> m a
return ([AltCon]
idcs3, [InAlt]
alts3) }
| Bool
otherwise
= ([AltCon], [InAlt]) -> SimplM ([AltCon], [InAlt])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [InAlt]
alts)
where
imposs_cons :: [AltCon]
imposs_cons = case InExpr
scrut of
Var InId
v -> Unfolding -> [AltCon]
otherCons (InId -> Unfolding
idUnfolding InId
v)
InExpr
_ -> []
mkCase, mkCase1, mkCase2, mkCase3
:: DynFlags
-> OutExpr -> OutId
-> OutType -> [OutAlt]
-> SimplM OutExpr
mkCase :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase DynFlags
dflags InExpr
scrut InId
outer_bndr OutType
alts_ty (Alt AltCon
DEFAULT [InId]
_ InExpr
deflt_rhs : [InAlt]
outer_alts)
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CaseMerge DynFlags
dflags
, ([CoreTickish]
ticks, Case (Var InId
inner_scrut_var) InId
inner_bndr OutType
_ [InAlt]
inner_alts)
<- (CoreTickish -> Bool) -> InExpr -> ([CoreTickish], InExpr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable InExpr
deflt_rhs
, InId
inner_scrut_var InId -> InId -> Bool
forall a. Eq a => a -> a -> Bool
== InId
outer_bndr
= do { Tick -> SimplM ()
tick (InId -> Tick
CaseMerge InId
outer_bndr)
; let wrap_alt :: InAlt -> InAlt
wrap_alt (Alt AltCon
con [InId]
args InExpr
rhs) = Bool -> InAlt -> InAlt
forall a. HasCallStack => Bool -> a -> a
assert (InId
outer_bndr InId -> [InId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [InId]
args)
(AltCon -> [InId] -> InExpr -> InAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [InId]
args (InExpr -> InExpr
wrap_rhs InExpr
rhs))
wrap_rhs :: InExpr -> InExpr
wrap_rhs InExpr
rhs = Bind InId -> InExpr -> InExpr
forall b. Bind b -> Expr b -> Expr b
Let (InId -> InExpr -> Bind InId
forall b. b -> Expr b -> Bind b
NonRec InId
inner_bndr (InId -> InExpr
forall b. InId -> Expr b
Var InId
outer_bndr)) InExpr
rhs
wrapped_alts :: [InAlt]
wrapped_alts | InId -> Bool
isDeadBinder InId
inner_bndr = [InAlt]
inner_alts
| Bool
otherwise = (InAlt -> InAlt) -> [InAlt] -> [InAlt]
forall a b. (a -> b) -> [a] -> [b]
map InAlt -> InAlt
wrap_alt [InAlt]
inner_alts
merged_alts :: [InAlt]
merged_alts = [InAlt] -> [InAlt] -> [InAlt]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [InAlt]
outer_alts [InAlt]
wrapped_alts
; (InExpr -> InExpr) -> SimplM InExpr -> SimplM InExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([CoreTickish] -> InExpr -> InExpr
mkTicks [CoreTickish]
ticks) (SimplM InExpr -> SimplM InExpr) -> SimplM InExpr -> SimplM InExpr
forall a b. (a -> b) -> a -> b
$
DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase1 DynFlags
dflags InExpr
scrut InId
outer_bndr OutType
alts_ty [InAlt]
merged_alts
}
mkCase DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts = DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase1 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
mkCase1 :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase1 DynFlags
_dflags InExpr
scrut InId
case_bndr OutType
_ alts :: [InAlt]
alts@(Alt AltCon
_ [InId]
_ InExpr
rhs1 : [InAlt]
_)
| (InAlt -> Bool) -> [InAlt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all InAlt -> Bool
identity_alt [InAlt]
alts
= do { Tick -> SimplM ()
tick (InId -> Tick
CaseIdentity InId
case_bndr)
; InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreTickish] -> InExpr -> InExpr
mkTicks [CoreTickish]
ticks (InExpr -> InExpr) -> InExpr -> InExpr
forall a b. (a -> b) -> a -> b
$ InExpr -> InExpr -> InExpr
forall b b. Expr b -> Expr b -> Expr b
re_cast InExpr
scrut InExpr
rhs1) }
where
ticks :: [CoreTickish]
ticks = (InAlt -> [CoreTickish]) -> [InAlt] -> [CoreTickish]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Alt AltCon
_ [InId]
_ InExpr
rhs) -> (CoreTickish -> Bool) -> InExpr -> [CoreTickish]
forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable InExpr
rhs) ([InAlt] -> [InAlt]
forall a. [a] -> [a]
tail [InAlt]
alts)
identity_alt :: InAlt -> Bool
identity_alt (Alt AltCon
con [InId]
args InExpr
rhs) = InExpr -> AltCon -> [InId] -> Bool
check_eq InExpr
rhs AltCon
con [InId]
args
check_eq :: InExpr -> AltCon -> [InId] -> Bool
check_eq (Cast InExpr
rhs OutCoercion
co) AltCon
con [InId]
args
= Bool -> Bool
not ((InId -> Bool) -> [InId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (InId -> TyCoVarSet -> Bool
`elemVarSet` OutCoercion -> TyCoVarSet
tyCoVarsOfCo OutCoercion
co) [InId]
args) Bool -> Bool -> Bool
&& InExpr -> AltCon -> [InId] -> Bool
check_eq InExpr
rhs AltCon
con [InId]
args
check_eq (Tick CoreTickish
t InExpr
e) AltCon
alt [InId]
args
= CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t Bool -> Bool -> Bool
&& InExpr -> AltCon -> [InId] -> Bool
check_eq InExpr
e AltCon
alt [InId]
args
check_eq (Lit Literal
lit) (LitAlt Literal
lit') [InId]
_ = Literal
lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit'
check_eq (Var InId
v) AltCon
_ [InId]
_ | InId
v InId -> InId -> Bool
forall a. Eq a => a -> a -> Bool
== InId
case_bndr = Bool
True
check_eq (Var InId
v) (DataAlt DataCon
con) [InId]
args
| [OutType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OutType]
arg_tys, [InId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InId]
args = InId
v InId -> InId -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> InId
dataConWorkId DataCon
con
check_eq InExpr
rhs (DataAlt DataCon
con) [InId]
args = (CoreTickish -> Bool) -> InExpr -> InExpr -> Bool
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable InExpr
rhs (InExpr -> Bool) -> InExpr -> Bool
forall a b. (a -> b) -> a -> b
$
DataCon -> [OutType] -> [InId] -> InExpr
forall b. DataCon -> [OutType] -> [InId] -> Expr b
mkConApp2 DataCon
con [OutType]
arg_tys [InId]
args
check_eq InExpr
_ AltCon
_ [InId]
_ = Bool
False
arg_tys :: [OutType]
arg_tys = OutType -> [OutType]
tyConAppArgs (InId -> OutType
idType InId
case_bndr)
re_cast :: Expr b -> Expr b -> Expr b
re_cast Expr b
scrut (Cast Expr b
rhs OutCoercion
co) = Expr b -> OutCoercion -> Expr b
forall b. Expr b -> OutCoercion -> Expr b
Cast (Expr b -> Expr b -> Expr b
re_cast Expr b
scrut Expr b
rhs) OutCoercion
co
re_cast Expr b
scrut Expr b
_ = Expr b
scrut
mkCase1 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts = DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase2 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
mkCase2 :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase2 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
|
case [InAlt]
alts of
[Alt AltCon
DEFAULT [InId]
_ InExpr
_] -> Bool
False
[InAlt]
_ -> Bool
True
, GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CaseFolding DynFlags
dflags
, Just (InExpr
scrut', AltCon -> Maybe AltCon
tx_con, InId -> InExpr
mk_orig) <- Platform
-> InExpr -> Maybe (InExpr, AltCon -> Maybe AltCon, InId -> InExpr)
caseRules (DynFlags -> Platform
targetPlatform DynFlags
dflags) InExpr
scrut
= do { InId
bndr' <- FastString -> OutType -> OutType -> SimplM InId
newId (String -> FastString
fsLit String
"lwild") OutType
Many (InExpr -> OutType
exprType InExpr
scrut')
; [InAlt]
alts' <- (InAlt -> SimplM (Maybe InAlt)) -> [InAlt] -> SimplM [InAlt]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM ((AltCon -> Maybe AltCon)
-> (InId -> InExpr) -> InId -> InAlt -> SimplM (Maybe InAlt)
tx_alt AltCon -> Maybe AltCon
tx_con InId -> InExpr
mk_orig InId
bndr') [InAlt]
alts
; DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase3 DynFlags
dflags InExpr
scrut' InId
bndr' OutType
alts_ty ([InAlt] -> SimplM InExpr) -> [InAlt] -> SimplM InExpr
forall a b. (a -> b) -> a -> b
$
[InAlt] -> [InAlt]
add_default ([InAlt] -> [InAlt]
re_sort [InAlt]
alts')
}
| Bool
otherwise
= DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase3 DynFlags
dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
where
tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id
-> CoreAlt -> SimplM (Maybe CoreAlt)
tx_alt :: (AltCon -> Maybe AltCon)
-> (InId -> InExpr) -> InId -> InAlt -> SimplM (Maybe InAlt)
tx_alt AltCon -> Maybe AltCon
tx_con InId -> InExpr
mk_orig InId
new_bndr (Alt AltCon
con [InId]
bs InExpr
rhs)
= case AltCon -> Maybe AltCon
tx_con AltCon
con of
Maybe AltCon
Nothing -> Maybe InAlt -> SimplM (Maybe InAlt)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe InAlt
forall a. Maybe a
Nothing
Just AltCon
con' -> do { [InId]
bs' <- InId -> AltCon -> SimplM [InId]
forall (m :: * -> *). MonadUnique m => InId -> AltCon -> m [InId]
mk_new_bndrs InId
new_bndr AltCon
con'
; Maybe InAlt -> SimplM (Maybe InAlt)
forall (m :: * -> *) a. Monad m => a -> m a
return (InAlt -> Maybe InAlt
forall a. a -> Maybe a
Just (AltCon -> [InId] -> InExpr -> InAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con' [InId]
bs' InExpr
rhs')) }
where
rhs' :: InExpr
rhs' | InId -> Bool
isDeadBinder InId
bndr = InExpr
rhs
| Bool
otherwise = InId -> InExpr -> InExpr -> InExpr
bindNonRec InId
bndr InExpr
orig_val InExpr
rhs
orig_val :: InExpr
orig_val = case AltCon
con of
AltCon
DEFAULT -> InId -> InExpr
mk_orig InId
new_bndr
LitAlt Literal
l -> Literal -> InExpr
forall b. Literal -> Expr b
Lit Literal
l
DataAlt DataCon
dc -> DataCon -> [OutType] -> [InId] -> InExpr
forall b. DataCon -> [OutType] -> [InId] -> Expr b
mkConApp2 DataCon
dc (OutType -> [OutType]
tyConAppArgs (InId -> OutType
idType InId
bndr)) [InId]
bs
mk_new_bndrs :: InId -> AltCon -> m [InId]
mk_new_bndrs InId
new_bndr (DataAlt DataCon
dc)
| Bool -> Bool
not (DataCon -> Bool
isNullaryRepDataCon DataCon
dc)
=
do { [Unique]
us <- m [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let ([InId]
ex_tvs, [InId]
arg_ids) = [Unique] -> OutType -> DataCon -> [OutType] -> ([InId], [InId])
dataConRepInstPat [Unique]
us (InId -> OutType
idMult InId
new_bndr) DataCon
dc
(OutType -> [OutType]
tyConAppArgs (InId -> OutType
idType InId
new_bndr))
; [InId] -> m [InId]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InId]
ex_tvs [InId] -> [InId] -> [InId]
forall a. [a] -> [a] -> [a]
++ [InId]
arg_ids) }
mk_new_bndrs InId
_ AltCon
_ = [InId] -> m [InId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
re_sort :: [CoreAlt] -> [CoreAlt]
re_sort :: [InAlt] -> [InAlt]
re_sort [InAlt]
alts = (InAlt -> InAlt -> Ordering) -> [InAlt] -> [InAlt]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy InAlt -> InAlt -> Ordering
forall a. Alt a -> Alt a -> Ordering
cmpAlt [InAlt]
alts
add_default :: [CoreAlt] -> [CoreAlt]
add_default :: [InAlt] -> [InAlt]
add_default (Alt (LitAlt {}) [InId]
bs InExpr
rhs : [InAlt]
alts) = AltCon -> [InId] -> InExpr -> InAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [InId]
bs InExpr
rhs InAlt -> [InAlt] -> [InAlt]
forall a. a -> [a] -> [a]
: [InAlt]
alts
add_default [InAlt]
alts = [InAlt]
alts
mkCase3 :: DynFlags -> InExpr -> InId -> OutType -> [InAlt] -> SimplM InExpr
mkCase3 DynFlags
_dflags InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts
= InExpr -> SimplM InExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (InExpr -> InId -> OutType -> [InAlt] -> InExpr
forall b. Expr b -> b -> OutType -> [Alt b] -> Expr b
Case InExpr
scrut InId
bndr OutType
alts_ty [InAlt]
alts)
isExitJoinId :: Var -> Bool
isExitJoinId :: InId -> Bool
isExitJoinId InId
id
= InId -> Bool
isJoinId InId
id
Bool -> Bool -> Bool
&& OccInfo -> Bool
isOneOcc (InId -> OccInfo
idOccInfo InId
id)
Bool -> Bool -> Bool
&& OccInfo -> InsideLam
occ_in_lam (InId -> OccInfo
idOccInfo InId
id) InsideLam -> InsideLam -> Bool
forall a. Eq a => a -> a -> Bool
== InsideLam
IsInsideLam