module GHC.Core.Opt.Simplify.Utils (
rebuildLam, mkCase, prepareAlts,
tryEtaExpandRhs, wantEtaExpansion,
preInlineUnconditionally, postInlineUnconditionally,
activeUnfolding, activeRule,
getUnfoldingInRuleMatch,
updModeForStableUnfoldings, updModeForRules,
BindContext(..), bindContextLevel,
SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,
isSimplified, contIsStop,
contIsDupable, contResultType, contHoleType, contHoleScaling,
contIsTrivial, contArgs, contIsRhs,
countArgs,
mkBoringStop, mkRhsStop, mkLazyArgStop,
interestingCallContext,
ArgInfo(..), ArgSpec(..), RewriteCall(..), mkArgInfo,
addValArgTo, addCastTo, addTyArgTo,
argInfoExpr, argInfoAppArgs,
pushSimplifiedArgs, pushSimplifiedRevArgs,
isStrictArgInfo, lazyArgContext,
abstractFloats,
isExitJoinId
) where
import GHC.Prelude hiding (head, init, last, tail)
import GHC.Core
import GHC.Types.Literal ( isLitRubbish )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Stats ( Tick(..) )
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.Rules( RuleEnv, getRules )
import GHC.Core.Opt.Arity
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
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.Core.Opt.ConstantFold
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Tickish
import GHC.Types.Demand
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Data.OrdList ( isNilOL )
import GHC.Data.FastString ( fsLit )
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad ( when )
import Data.List ( sortBy )
import qualified Data.List as Partial ( head )
data BindContext
= BC_Let
TopLevelFlag RecFlag
| BC_Join
RecFlag
SimplCont
bindContextLevel :: BindContext -> TopLevelFlag
bindContextLevel :: BindContext -> TopLevelFlag
bindContextLevel (BC_Let TopLevelFlag
top_lvl RecFlag
_) = TopLevelFlag
top_lvl
bindContextLevel (BC_Join {}) = TopLevelFlag
NotTopLevel
bindContextRec :: BindContext -> RecFlag
bindContextRec :: BindContext -> RecFlag
bindContextRec (BC_Let TopLevelFlag
_ RecFlag
rec_flag) = RecFlag
rec_flag
bindContextRec (BC_Join RecFlag
rec_flag SimplCont
_) = RecFlag
rec_flag
isJoinBC :: BindContext -> Bool
isJoinBC :: BindContext -> Bool
isJoinBC (BC_Let {}) = Bool
False
isJoinBC (BC_Join {}) = Bool
True
data SimplCont
= Stop
OutType
CallCtxt
SubDemand
| CastIt
OutCoercion
SimplCont
| ApplyToVal
{ SimplCont -> DupFlag
sc_dup :: DupFlag
, SimplCont -> OutType
sc_hole_ty :: OutType
, SimplCont -> OutExpr
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 -> Id
sc_bndr :: InId
, SimplCont -> [InAlt]
sc_alts :: [InAlt]
, sc_env :: StaticEnv
, sc_cont :: SimplCont }
| StrictBind
{ sc_dup :: DupFlag
, sc_bndr :: InId
, SimplCont -> FromWhat
sc_from :: FromWhat
, SimplCont -> OutExpr
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 FromWhat = FromLet | FromBeta OutType
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 = (() :: Constraint) => StaticEnv -> OutType -> OutType
StaticEnv -> OutType -> OutType
substTy StaticEnv
env OutType
ty
instance Outputable DupFlag where
ppr :: DupFlag -> SDoc
ppr DupFlag
OkToDup = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ok"
ppr DupFlag
NoDup = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"nodup"
ppr DupFlag
Simplified = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"simpl"
instance Outputable SimplCont where
ppr :: SimplCont -> SDoc
ppr (Stop OutType
ty CallCtxt
interesting SubDemand
eval_sd)
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Stop" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
pps) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
ty
where
pps :: [SDoc]
pps = [CallCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallCtxt
interesting] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
eval_sd | SubDemand
eval_sd SubDemand -> SubDemand -> Bool
forall a. Eq a => a -> a -> Bool
/= SubDemand
topSubDmd]
ppr (CastIt OutCoercion
co SimplCont
cont ) = (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CastIt" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutCoercion -> SDoc
pprOptCo OutCoercion
co) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (TickIt CoreTickish
t SimplCont
cont) = (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TickIt" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
t) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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
forall doc. IsLine doc => String -> doc
text String
"ApplyToTy" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutType -> SDoc
pprParendType OutType
ty) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (ApplyToVal { sc_arg :: SimplCont -> OutExpr
sc_arg = OutExpr
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 -> BranchCount -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ApplyToVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DupFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr DupFlag
dup SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hole" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
hole_ty)
BranchCount
2 (OutExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr OutExpr
arg))
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (StrictBind { sc_bndr :: SimplCont -> Id
sc_bndr = Id
b, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont })
= (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StrictBind" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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
forall doc. IsLine doc => String -> doc
text String
"StrictArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ArgInfo -> Id
ai_fun ArgInfo
ai)) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
ppr (Select { sc_dup :: SimplCont -> DupFlag
sc_dup = DupFlag
dup, sc_bndr :: SimplCont -> Id
sc_bndr = Id
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
forall doc. IsLine doc => String -> doc
text String
"Select" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DupFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr DupFlag
dup SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (BranchCount -> SDoc -> SDoc
nest BranchCount
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsDoc doc => doc -> doc -> doc
$$ SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
cont
data ArgInfo
= ArgInfo {
ArgInfo -> Id
ai_fun :: OutId,
ArgInfo -> [ArgSpec]
ai_args :: [ArgSpec],
ArgInfo -> RewriteCall
ai_rewrite :: RewriteCall,
ArgInfo -> Bool
ai_encl :: Bool,
ArgInfo -> [Demand]
ai_dmds :: [Demand],
ArgInfo -> [BranchCount]
ai_discs :: [Int]
}
data RewriteCall
= TryRules FullArgCount [CoreRule]
| TryInlining
| TryNothing
data ArgSpec
= ValArg { ArgSpec -> Demand
as_dmd :: Demand
, ArgSpec -> OutExpr
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 -> Id
ai_fun = Id
fun, ai_args :: ArgInfo -> [ArgSpec]
ai_args = [ArgSpec]
args, ai_dmds :: ArgInfo -> [Demand]
ai_dmds = [Demand]
dmds })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ArgInfo" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fun =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dmds(first 10) =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (BranchCount -> [Demand] -> [Demand]
forall a. BranchCount -> [a] -> [a]
take BranchCount
10 [Demand]
dmds)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ArgSpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ArgSpec]
args ])
instance Outputable ArgSpec where
ppr :: ArgSpec -> SDoc
ppr (ValArg { as_arg :: ArgSpec -> OutExpr
as_arg = OutExpr
arg }) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
arg
ppr (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty }) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TyArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutType -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutType
ty
ppr (CastBy OutCoercion
c) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CastBy" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutCoercion
c
addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
addValArgTo ArgInfo
ai OutExpr
arg OutType
hole_ty
| ArgInfo { ai_dmds :: ArgInfo -> [Demand]
ai_dmds = Demand
dmd:[Demand]
dmds, ai_discs :: ArgInfo -> [BranchCount]
ai_discs = BranchCount
_:[BranchCount]
discs, ai_rewrite :: ArgInfo -> RewriteCall
ai_rewrite = RewriteCall
rew } <- ArgInfo
ai
, let arg_spec :: ArgSpec
arg_spec = ValArg { as_arg :: OutExpr
as_arg = OutExpr
arg, as_hole_ty :: OutType
as_hole_ty = OutType
hole_ty, as_dmd :: Demand
as_dmd = Demand
dmd }
= ArgInfo
ai { ai_args = arg_spec : ai_args ai
, ai_dmds = dmds
, ai_discs = discs
, ai_rewrite = decArgCount rew }
| 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
arg)
addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo
addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo
addTyArgTo ArgInfo
ai OutType
arg_ty OutType
hole_ty = ArgInfo
ai { ai_args = arg_spec : ai_args ai
, ai_rewrite = decArgCount (ai_rewrite ai) }
where
arg_spec :: ArgSpec
arg_spec = 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 = CastBy co : ai_args 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] -> [OutExpr]
argInfoAppArgs [] = []
argInfoAppArgs (CastBy {} : [ArgSpec]
_) = []
argInfoAppArgs (ValArg { as_arg :: ArgSpec -> OutExpr
as_arg = OutExpr
arg } : [ArgSpec]
as) = OutExpr
arg OutExpr -> [OutExpr] -> [OutExpr]
forall a. a -> [a] -> [a]
: [ArgSpec] -> [OutExpr]
argInfoAppArgs [ArgSpec]
as
argInfoAppArgs (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty } : [ArgSpec]
as) = OutType -> OutExpr
forall b. OutType -> Expr b
Type OutType
ty OutExpr -> [OutExpr] -> [OutExpr]
forall a. a -> [a] -> [a]
: [ArgSpec] -> [OutExpr]
argInfoAppArgs [ArgSpec]
as
pushSimplifiedArgs, pushSimplifiedRevArgs
:: SimplEnv
-> [ArgSpec]
-> SimplCont -> SimplCont
pushSimplifiedArgs :: StaticEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs StaticEnv
env [ArgSpec]
args SimplCont
cont = (ArgSpec -> SimplCont -> SimplCont)
-> SimplCont -> [ArgSpec] -> SimplCont
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (StaticEnv -> ArgSpec -> SimplCont -> SimplCont
pushSimplifiedArg StaticEnv
env) SimplCont
cont [ArgSpec]
args
pushSimplifiedRevArgs :: StaticEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedRevArgs StaticEnv
env [ArgSpec]
args SimplCont
cont = (SimplCont -> ArgSpec -> SimplCont)
-> SimplCont -> [ArgSpec] -> SimplCont
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\SimplCont
k ArgSpec
a -> StaticEnv -> ArgSpec -> SimplCont -> SimplCont
pushSimplifiedArg StaticEnv
env ArgSpec
a SimplCont
k) SimplCont
cont [ArgSpec]
args
pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont
pushSimplifiedArg :: StaticEnv -> ArgSpec -> SimplCont -> SimplCont
pushSimplifiedArg StaticEnv
_env (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
arg_ty, as_hole_ty :: ArgSpec -> OutType
as_hole_ty = OutType
hole_ty }) SimplCont
cont
= 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
cont }
pushSimplifiedArg StaticEnv
env (ValArg { as_arg :: ArgSpec -> OutExpr
as_arg = OutExpr
arg, as_hole_ty :: ArgSpec -> OutType
as_hole_ty = OutType
hole_ty }) SimplCont
cont
= ApplyToVal { sc_arg :: OutExpr
sc_arg = OutExpr
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
cont }
pushSimplifiedArg StaticEnv
_ (CastBy OutCoercion
c) SimplCont
cont = OutCoercion -> SimplCont -> SimplCont
CastIt OutCoercion
c SimplCont
cont
argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
argInfoExpr :: Id -> [ArgSpec] -> OutExpr
argInfoExpr Id
fun [ArgSpec]
rev_args
= [ArgSpec] -> OutExpr
go [ArgSpec]
rev_args
where
go :: [ArgSpec] -> OutExpr
go [] = Id -> OutExpr
forall b. Id -> Expr b
Var Id
fun
go (ValArg { as_arg :: ArgSpec -> OutExpr
as_arg = OutExpr
arg } : [ArgSpec]
as) = [ArgSpec] -> OutExpr
go [ArgSpec]
as OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
`App` OutExpr
arg
go (TyArg { as_arg_ty :: ArgSpec -> OutType
as_arg_ty = OutType
ty } : [ArgSpec]
as) = [ArgSpec] -> OutExpr
go [ArgSpec]
as OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
`App` OutType -> OutExpr
forall b. OutType -> Expr b
Type OutType
ty
go (CastBy OutCoercion
co : [ArgSpec]
as) = (() :: Constraint) => OutExpr -> OutCoercion -> OutExpr
OutExpr -> OutCoercion -> OutExpr
mkCast ([ArgSpec] -> OutExpr
go [ArgSpec]
as) OutCoercion
co
decArgCount :: RewriteCall -> RewriteCall
decArgCount :: RewriteCall -> RewriteCall
decArgCount (TryRules BranchCount
n [CoreRule]
rules) = BranchCount -> [CoreRule] -> RewriteCall
TryRules (BranchCount
nBranchCount -> BranchCount -> BranchCount
forall a. Num a => a -> a -> a
-BranchCount
1) [CoreRule]
rules
decArgCount RewriteCall
rew = RewriteCall
rew
mkRewriteCall :: Id -> RuleEnv -> RewriteCall
mkRewriteCall :: Id -> RuleEnv -> RewriteCall
mkRewriteCall Id
fun RuleEnv
rule_env
| Bool -> Bool
not ([CoreRule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules) = BranchCount -> [CoreRule] -> RewriteCall
TryRules BranchCount
n_required [CoreRule]
rules
| Unfolding -> Bool
canUnfold Unfolding
unf = RewriteCall
TryInlining
| Bool
otherwise = RewriteCall
TryNothing
where
n_required :: BranchCount
n_required = [BranchCount] -> BranchCount
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((CoreRule -> BranchCount) -> [CoreRule] -> [BranchCount]
forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> BranchCount
ruleArity [CoreRule]
rules)
rules :: [CoreRule]
rules = RuleEnv -> Id -> [CoreRule]
getRules RuleEnv
rule_env Id
fun
unf :: Unfolding
unf = IdUnfoldingFun
idUnfolding Id
fun
mkBoringStop :: OutType -> SimplCont
mkBoringStop :: OutType -> SimplCont
mkBoringStop OutType
ty = OutType -> CallCtxt -> SubDemand -> SimplCont
Stop OutType
ty CallCtxt
BoringCtxt SubDemand
topSubDmd
mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont
mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont
mkRhsStop OutType
ty RecFlag
is_rec Demand
bndr_dmd = OutType -> CallCtxt -> SubDemand -> SimplCont
Stop OutType
ty (RecFlag -> CallCtxt
RhsCtxt RecFlag
is_rec) (Demand -> SubDemand
subDemandIfEvaluated Demand
bndr_dmd)
mkLazyArgStop :: OutType -> ArgInfo -> SimplCont
mkLazyArgStop :: OutType -> ArgInfo -> SimplCont
mkLazyArgStop OutType
ty ArgInfo
fun_info = OutType -> CallCtxt -> SubDemand -> SimplCont
Stop OutType
ty (ArgInfo -> CallCtxt
lazyArgContext ArgInfo
fun_info) SubDemand
arg_sd
where
arg_sd :: SubDemand
arg_sd = Demand -> SubDemand
subDemandIfEvaluated ([Demand] -> Demand
forall a. HasCallStack => [a] -> a
Partial.head (ArgInfo -> [Demand]
ai_dmds ArgInfo
fun_info))
contIsRhs :: SimplCont -> Maybe RecFlag
contIsRhs :: SimplCont -> Maybe RecFlag
contIsRhs (Stop OutType
_ (RhsCtxt RecFlag
is_rec) SubDemand
_) = RecFlag -> Maybe RecFlag
forall a. a -> Maybe a
Just RecFlag
is_rec
contIsRhs (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> Maybe RecFlag
contIsRhs SimplCont
k
contIsRhs SimplCont
_ = Maybe RecFlag
forall a. Maybe a
Nothing
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 (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> Bool
contIsTrivial SimplCont
k
contIsTrivial SimplCont
_ = Bool
False
contResultType :: SimplCont -> OutType
contResultType :: SimplCont -> OutType
contResultType (Stop OutType
ty CallCtxt
_ SubDemand
_) = 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
_ SubDemand
_) = 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 -> Id
sc_bndr = Id
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 (Id -> OutType
idType Id
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 -> Id
sc_bndr = Id
b, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se })
= DupFlag -> StaticEnv -> OutType -> OutType
perhapsSubstTy DupFlag
d StaticEnv
se (Id -> OutType
idType Id
b)
contHoleScaling :: SimplCont -> Mult
contHoleScaling :: SimplCont -> OutType
contHoleScaling (Stop OutType
_ CallCtxt
_ SubDemand
_) = OutType
OneTy
contHoleScaling (CastIt OutCoercion
_ SimplCont
k) = SimplCont -> OutType
contHoleScaling SimplCont
k
contHoleScaling (StrictBind { sc_bndr :: SimplCont -> Id
sc_bndr = Id
id, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= Id -> OutType
idMult Id
id OutType -> OutType -> OutType
`mkMultMul` SimplCont -> OutType
contHoleScaling SimplCont
k
contHoleScaling (Select { sc_bndr :: SimplCont -> Id
sc_bndr = Id
id, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= Id -> OutType
idMult Id
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 -> BranchCount
countArgs (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = BranchCount
1 BranchCount -> BranchCount -> BranchCount
forall a. Num a => a -> a -> a
+ SimplCont -> BranchCount
countArgs SimplCont
cont
countArgs (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = BranchCount
1 BranchCount -> BranchCount -> BranchCount
forall a. Num a => a -> a -> a
+ SimplCont -> BranchCount
countArgs SimplCont
cont
countArgs (CastIt OutCoercion
_ SimplCont
cont) = SimplCont -> BranchCount
countArgs SimplCont
cont
countArgs SimplCont
_ = BranchCount
0
countValArgs :: SimplCont -> Int
countValArgs :: SimplCont -> BranchCount
countValArgs (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = SimplCont -> BranchCount
countValArgs SimplCont
cont
countValArgs (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = BranchCount
1 BranchCount -> BranchCount -> BranchCount
forall a. Num a => a -> a -> a
+ SimplCont -> BranchCount
countValArgs SimplCont
cont
countValArgs (CastIt OutCoercion
_ SimplCont
cont) = SimplCont -> BranchCount
countValArgs SimplCont
cont
countValArgs SimplCont
_ = BranchCount
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 -> OutExpr
sc_arg = OutExpr
arg, sc_env :: SimplCont -> StaticEnv
sc_env = StaticEnv
se, sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
k })
= [ArgSummary] -> SimplCont -> (Bool, [ArgSummary], SimplCont)
go (OutExpr -> StaticEnv -> ArgSummary
is_interesting OutExpr
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 :: OutExpr -> StaticEnv -> ArgSummary
is_interesting OutExpr
arg StaticEnv
se = StaticEnv -> OutExpr -> ArgSummary
interestingArg StaticEnv
se OutExpr
arg
contEvalContext :: SimplCont -> SubDemand
contEvalContext :: SimplCont -> SubDemand
contEvalContext SimplCont
k = case SimplCont
k of
(Stop OutType
_ CallCtxt
_ SubDemand
sd) -> SubDemand
sd
(TickIt CoreTickish
_ SimplCont
k) -> SimplCont -> SubDemand
contEvalContext SimplCont
k
(CastIt OutCoercion
_ SimplCont
k) -> SimplCont -> SubDemand
contEvalContext SimplCont
k
ApplyToTy{sc_cont :: SimplCont -> SimplCont
sc_cont=SimplCont
k} -> SimplCont -> SubDemand
contEvalContext SimplCont
k
ApplyToVal{} -> String -> SDoc -> SubDemand
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"contEvalContext" (SimplCont -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplCont
k)
StrictArg{sc_fun :: SimplCont -> ArgInfo
sc_fun=ArgInfo
fun_info} -> Demand -> SubDemand
subDemandIfEvaluated ([Demand] -> Demand
forall a. HasCallStack => [a] -> a
Partial.head (ArgInfo -> [Demand]
ai_dmds ArgInfo
fun_info))
StrictBind{sc_bndr :: SimplCont -> Id
sc_bndr=Id
bndr} -> Demand -> SubDemand
subDemandIfEvaluated (Id -> Demand
idDemandInfo Id
bndr)
Select{} -> SubDemand
topSubDmd
mkArgInfo :: SimplEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo
mkArgInfo :: StaticEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo
mkArgInfo StaticEnv
env RuleEnv
rule_base Id
fun SimplCont
cont
| BranchCount
n_val_args BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> BranchCount
idArity Id
fun
= ArgInfo { ai_fun :: Id
ai_fun = Id
fun, ai_args :: [ArgSpec]
ai_args = []
, ai_rewrite :: RewriteCall
ai_rewrite = RewriteCall
fun_rewrite
, ai_encl :: Bool
ai_encl = Bool
False
, ai_dmds :: [Demand]
ai_dmds = [Demand]
vanilla_dmds
, ai_discs :: [BranchCount]
ai_discs = [BranchCount]
vanilla_discounts }
| Bool
otherwise
= ArgInfo { ai_fun :: Id
ai_fun = Id
fun
, ai_args :: [ArgSpec]
ai_args = []
, ai_rewrite :: RewriteCall
ai_rewrite = RewriteCall
fun_rewrite
, ai_encl :: Bool
ai_encl = Bool
fun_has_rules Bool -> Bool -> Bool
|| SimplCont -> Bool
contHasRules SimplCont
cont
, ai_dmds :: [Demand]
ai_dmds = OutType -> [Demand] -> [Demand]
add_type_strictness (Id -> OutType
idType Id
fun) [Demand]
arg_dmds
, ai_discs :: [BranchCount]
ai_discs = [BranchCount]
arg_discounts }
where
n_val_args :: BranchCount
n_val_args = SimplCont -> BranchCount
countValArgs SimplCont
cont
fun_rewrite :: RewriteCall
fun_rewrite = Id -> RuleEnv -> RewriteCall
mkRewriteCall Id
fun RuleEnv
rule_base
fun_has_rules :: Bool
fun_has_rules = case RewriteCall
fun_rewrite of
TryRules {} -> Bool
True
RewriteCall
_ -> Bool
False
vanilla_discounts, arg_discounts :: [Int]
vanilla_discounts :: [BranchCount]
vanilla_discounts = BranchCount -> [BranchCount]
forall a. a -> [a]
repeat BranchCount
0
arg_discounts :: [BranchCount]
arg_discounts = case IdUnfoldingFun
idUnfolding Id
fun of
CoreUnfolding {uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfIfGoodArgs {ug_args :: UnfoldingGuidance -> [BranchCount]
ug_args = [BranchCount]
discounts}}
-> [BranchCount]
discounts [BranchCount] -> [BranchCount] -> [BranchCount]
forall a. [a] -> [a] -> [a]
++ [BranchCount]
vanilla_discounts
Unfolding
_ -> [BranchCount]
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 (StaticEnv -> Bool
seInline StaticEnv
env)
= [Demand]
vanilla_dmds
| Bool
otherwise
=
case DmdSig -> ([Demand], Divergence)
splitDmdSig (Id -> DmdSig
idDmdSig Id
fun) of
([Demand]
demands, Divergence
result_info)
| Bool -> Bool
not ([Demand]
demands [Demand] -> BranchCount -> Bool
forall a. [a] -> BranchCount -> Bool
`lengthExceeds` BranchCount
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 -> String -> SDoc -> [Demand] -> [Demand]
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"More demands than arity" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BranchCount -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> BranchCount
idArity Id
fun)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BranchCount -> SDoc
forall a. Outputable a => a -> SDoc
ppr BranchCount
n_val_args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
dmds = []
| Just (Id
_, OutType
fun_ty') <- OutType -> Maybe (Id, OutType)
splitForAllTyCoVar_maybe OutType
fun_ty
= OutType -> [Demand] -> [Demand]
add_type_strictness OutType
fun_ty' [Demand]
dmds
| Just (FunTyFlag
_, OutType
_, OutType
arg_ty, OutType
fun_ty') <- OutType -> Maybe (FunTyFlag, OutType, OutType, OutType)
splitFunTy_maybe OutType
fun_ty
, Demand
dmd : [Demand]
rest_dmds <- [Demand]
dmds
, let dmd' :: Demand
dmd'
| Just Levity
Unlifted <- (() :: Constraint) => OutType -> Maybe Levity
OutType -> Maybe Levity
typeLevity_maybe OutType
arg_ty
= Demand -> Demand
strictifyDmd Demand
dmd
| Bool
otherwise
= 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 -> [BranchCount]
ai_discs = [BranchCount]
discs })
| Bool
encl_rules = CallCtxt
RuleArgCtxt
| BranchCount
disc:[BranchCount]
_ <- [BranchCount]
discs, BranchCount
disc BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
> BranchCount
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 -> [BranchCount]
ai_discs = [BranchCount]
discs })
| Bool
encl_rules = CallCtxt
RuleArgCtxt
| BranchCount
disc:[BranchCount]
_ <- [BranchCount]
discs, BranchCount
disc BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
> BranchCount
0 = CallCtxt
DiscArgCtxt
| Bool
otherwise = RecFlag -> CallCtxt
RhsCtxt RecFlag
NonRecursive
interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
interestingCallContext :: StaticEnv -> SimplCont -> CallCtxt
interestingCallContext StaticEnv
env SimplCont
cont
= SimplCont -> CallCtxt
interesting SimplCont
cont
where
interesting :: SimplCont -> CallCtxt
interesting (Select {sc_alts :: SimplCont -> [InAlt]
sc_alts=[InAlt]
alts, sc_bndr :: SimplCont -> Id
sc_bndr=Id
case_bndr})
| Bool -> Bool
not (StaticEnv -> Bool
seCaseCase StaticEnv
env) = CallCtxt
BoringCtxt
| [Alt AltCon
_ [Id]
bs OutExpr
_] <- [InAlt]
alts
, (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder [Id]
bs
, Bool -> Bool
not (Id -> Bool
isDeadBinder Id
case_bndr) = CallCtxt
BoringCtxt
| Bool
otherwise = CallCtxt
CaseCtxt
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 SubDemand
_) = 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
contHasRules :: SimplCont -> Bool
contHasRules :: SimplCont -> Bool
contHasRules SimplCont
cont
= SimplCont -> Bool
go SimplCont
cont
where
go :: SimplCont -> Bool
go (ApplyToVal { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = SimplCont -> Bool
go SimplCont
cont
go (ApplyToTy { sc_cont :: SimplCont -> SimplCont
sc_cont = SimplCont
cont }) = SimplCont -> Bool
go SimplCont
cont
go (CastIt OutCoercion
_ SimplCont
cont) = SimplCont -> Bool
go SimplCont
cont
go (StrictArg { sc_fun :: SimplCont -> ArgInfo
sc_fun = ArgInfo
fun }) = ArgInfo -> Bool
ai_encl ArgInfo
fun
go (Stop OutType
_ CallCtxt
RuleArgCtxt SubDemand
_) = Bool
True
go (TickIt CoreTickish
_ SimplCont
c) = SimplCont -> Bool
go SimplCont
c
go (Select {}) = Bool
False
go (StrictBind {}) = Bool
False
go (Stop OutType
_ CallCtxt
_ SubDemand
_) = Bool
False
interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
interestingArg :: StaticEnv -> OutExpr -> ArgSummary
interestingArg StaticEnv
env OutExpr
e = StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env BranchCount
0 OutExpr
e
where
go :: StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env BranchCount
n (Var Id
v)
= case StaticEnv -> Id -> SimplSR
substId StaticEnv
env Id
v of
DoneId Id
v' -> BranchCount -> Id -> ArgSummary
go_var BranchCount
n Id
v'
DoneEx OutExpr
e Maybe BranchCount
_ -> StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go (StaticEnv -> StaticEnv
zapSubstEnv StaticEnv
env) BranchCount
n OutExpr
e
ContEx TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids OutExpr
e -> StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go (StaticEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> StaticEnv
setSubstEnv StaticEnv
env TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids) BranchCount
n OutExpr
e
go StaticEnv
_ BranchCount
_ (Lit Literal
l)
| Literal -> Bool
isLitRubbish Literal
l = ArgSummary
TrivArg
| Bool
otherwise = ArgSummary
ValueArg
go StaticEnv
_ BranchCount
_ (Type OutType
_) = ArgSummary
TrivArg
go StaticEnv
_ BranchCount
_ (Coercion OutCoercion
_) = ArgSummary
TrivArg
go StaticEnv
env BranchCount
n (App OutExpr
fn (Type OutType
_)) = StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env BranchCount
n OutExpr
fn
go StaticEnv
env BranchCount
n (App OutExpr
fn OutExpr
_) = StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env (BranchCount
nBranchCount -> BranchCount -> BranchCount
forall a. Num a => a -> a -> a
+BranchCount
1) OutExpr
fn
go StaticEnv
env BranchCount
n (Tick CoreTickish
_ OutExpr
a) = StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env BranchCount
n OutExpr
a
go StaticEnv
env BranchCount
n (Cast OutExpr
e OutCoercion
_) = StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env BranchCount
n OutExpr
e
go StaticEnv
env BranchCount
n (Lam Id
v OutExpr
e)
| Id -> Bool
isTyVar Id
v = StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env BranchCount
n OutExpr
e
| BranchCount
nBranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
>BranchCount
0 = ArgSummary
NonTrivArg
| Bool
otherwise = ArgSummary
ValueArg
go StaticEnv
_ BranchCount
_ (Case {}) = ArgSummary
NonTrivArg
go StaticEnv
env BranchCount
n (Let Bind Id
b OutExpr
e) = case StaticEnv -> BranchCount -> OutExpr -> ArgSummary
go StaticEnv
env' BranchCount
n OutExpr
e of
ArgSummary
ValueArg -> ArgSummary
ValueArg
ArgSummary
_ -> ArgSummary
NonTrivArg
where
env' :: StaticEnv
env' = StaticEnv
env StaticEnv -> [Id] -> StaticEnv
`addNewInScopeIds` Bind Id -> [Id]
forall b. Bind b -> [b]
bindersOf Bind Id
b
go_var :: BranchCount -> Id -> ArgSummary
go_var BranchCount
n Id
v
| Id -> Bool
isConLikeId Id
v = ArgSummary
ValueArg
| Id -> BranchCount
idArity Id
v BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
> BranchCount
n = ArgSummary
ValueArg
| BranchCount
n BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
> BranchCount
0 = ArgSummary
NonTrivArg
| Bool
conlike_unfolding = ArgSummary
ValueArg
| Bool
otherwise = ArgSummary
TrivArg
where
conlike_unfolding :: Bool
conlike_unfolding = Unfolding -> Bool
isConLikeUnfolding (IdUnfoldingFun
idUnfolding Id
v)
updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
updModeForStableUnfoldings Activation
unf_act SimplMode
current_mode
= SimplMode
current_mode { sm_phase = phaseFromActivation unf_act
, sm_eta_expand = False
, sm_inline = True }
where
phaseFromActivation :: Activation -> CompilerPhase
phaseFromActivation (ActiveAfter SourceText
_ BranchCount
n) = BranchCount -> CompilerPhase
Phase BranchCount
n
phaseFromActivation Activation
_ = CompilerPhase
InitialPhase
updModeForRules :: SimplMode -> SimplMode
updModeForRules :: SimplMode -> SimplMode
updModeForRules SimplMode
current_mode
= SimplMode
current_mode { sm_phase = InitialPhase
, sm_inline = False
, sm_rules = False
, sm_cast_swizzle = False
, sm_eta_expand = False }
activeUnfolding :: SimplMode -> Id -> Bool
activeUnfolding :: SimplMode -> Id -> Bool
activeUnfolding SimplMode
mode Id
id
| Unfolding -> Bool
isCompulsoryUnfolding (IdUnfoldingFun
realIdUnfolding Id
id)
= Bool
True
| Bool
otherwise
= CompilerPhase -> Activation -> Bool
isActive (SimplMode -> CompilerPhase
sm_phase SimplMode
mode) (Id -> Activation
idInlineActivation Id
id)
Bool -> Bool -> Bool
&& SimplMode -> Bool
sm_inline SimplMode
mode
getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
getUnfoldingInRuleMatch :: StaticEnv -> InScopeEnv
getUnfoldingInRuleMatch StaticEnv
env
= InScopeSet -> IdUnfoldingFun -> InScopeEnv
ISE InScopeSet
in_scope IdUnfoldingFun
id_unf
where
in_scope :: InScopeSet
in_scope = StaticEnv -> InScopeSet
seInScope StaticEnv
env
phase :: CompilerPhase
phase = StaticEnv -> CompilerPhase
sePhase StaticEnv
env
id_unf :: IdUnfoldingFun
id_unf = (Activation -> Bool) -> IdUnfoldingFun
whenActiveUnfoldingFun (CompilerPhase -> Activation -> Bool
isActive CompilerPhase
phase)
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 -> Id -> OutExpr -> StaticEnv -> Maybe StaticEnv
preInlineUnconditionally StaticEnv
env TopLevelFlag
top_lvl Id
bndr OutExpr
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
&& Id -> Bool
isDeadEndId Id
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| Id -> Bool
isCoVar Id
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| Id -> Bool
isExitJoinId Id
bndr = Maybe StaticEnv
forall a. Maybe a
Nothing
| Bool -> Bool
not (OccInfo -> Bool
one_occ (Id -> OccInfo
idOccInfo Id
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
$! (OutExpr -> StaticEnv
extend_subst_with OutExpr
rhs)
| Bool -> Bool
not (InlinePragma -> Bool
isInlinePragma InlinePragma
inline_prag)
, Just OutExpr
inl <- Unfolding -> Maybe OutExpr
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
$! (OutExpr -> StaticEnv
extend_subst_with OutExpr
inl)
| Bool
otherwise = Maybe StaticEnv
forall a. Maybe a
Nothing
where
unf :: Unfolding
unf = IdUnfoldingFun
idUnfolding Id
bndr
extend_subst_with :: OutExpr -> StaticEnv
extend_subst_with OutExpr
inl_rhs = StaticEnv -> Id -> SimplSR -> StaticEnv
extendIdSubst StaticEnv
env Id
bndr (SimplSR -> StaticEnv) -> SimplSR -> StaticEnv
forall a b. (a -> b) -> a -> b
$! (StaticEnv -> OutExpr -> SimplSR
mkContEx StaticEnv
rhs_env OutExpr
inl_rhs)
one_occ :: OccInfo -> Bool
one_occ OccInfo
IAmDead = Bool
True
one_occ OneOcc{ occ_n_br :: OccInfo -> BranchCount
occ_n_br = BranchCount
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 -> BranchCount
occ_n_br = BranchCount
1
, occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
IsInsideLam
, occ_int_cxt :: OccInfo -> InterestingCxt
occ_int_cxt = InterestingCxt
IsInteresting } = OutExpr -> Bool
canInlineInLam OutExpr
rhs
one_occ OccInfo
_ = Bool
False
pre_inline_unconditionally :: Bool
pre_inline_unconditionally = StaticEnv -> Bool
sePreInline StaticEnv
env
active :: Bool
active = CompilerPhase -> Activation -> Bool
isActive (StaticEnv -> CompilerPhase
sePhase StaticEnv
env) (InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inline_prag)
inline_prag :: InlinePragma
inline_prag = Id -> InlinePragma
idInlinePragma Id
bndr
canInlineInLam :: OutExpr -> Bool
canInlineInLam (Lit Literal
_) = Bool
True
canInlineInLam (Lam Id
b OutExpr
e) = Id -> Bool
isRuntimeVar Id
b Bool -> Bool -> Bool
|| OutExpr -> Bool
canInlineInLam OutExpr
e
canInlineInLam (Tick CoreTickish
t OutExpr
e) = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
&& OutExpr -> Bool
canInlineInLam OutExpr
e
canInlineInLam OutExpr
_ = Bool
False
early_phase :: Bool
early_phase = StaticEnv -> CompilerPhase
sePhase StaticEnv
env CompilerPhase -> CompilerPhase -> Bool
forall a. Eq a => a -> a -> Bool
/= CompilerPhase
FinalPhase
postInlineUnconditionally
:: SimplEnv -> BindContext
-> OutId
-> OccInfo
-> OutExpr
-> Bool
postInlineUnconditionally :: StaticEnv -> BindContext -> Id -> OccInfo -> OutExpr -> Bool
postInlineUnconditionally StaticEnv
env BindContext
bind_cxt Id
bndr OccInfo
occ_info OutExpr
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 (BindContext -> TopLevelFlag
bindContextLevel BindContext
bind_cxt)
= Bool
False
| OutExpr -> Bool
exprIsTrivial OutExpr
rhs = Bool
True
| BC_Join {} <- BindContext
bind_cxt
, Bool -> Bool
not (CompilerPhase
phase CompilerPhase -> CompilerPhase -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerPhase
FinalPhase) = Bool
False
| 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 -> BranchCount
occ_n_br = BranchCount
n_br }
-> BranchCount
n_br BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
< BranchCount
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 = IdUnfoldingFun
idUnfolding Id
bndr
uf_opts :: UnfoldingOpts
uf_opts = StaticEnv -> UnfoldingOpts
seUnfoldingOpts StaticEnv
env
phase :: CompilerPhase
phase = StaticEnv -> CompilerPhase
sePhase StaticEnv
env
active :: Bool
active = CompilerPhase -> Activation -> Bool
isActive CompilerPhase
phase (Id -> Activation
idInlineActivation Id
bndr)
rebuildLam :: SimplEnv
-> [OutBndr] -> OutExpr
-> SimplCont
-> SimplM OutExpr
rebuildLam :: StaticEnv -> [Id] -> OutExpr -> SimplCont -> SimplM OutExpr
rebuildLam StaticEnv
_env [] OutExpr
body SimplCont
_cont
= OutExpr -> SimplM OutExpr
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return OutExpr
body
rebuildLam StaticEnv
env bndrs :: [Id]
bndrs@(Id
bndr:[Id]
_) OutExpr
body SimplCont
cont
= {-# SCC "rebuildLam" #-} [Id] -> OutExpr -> SimplM OutExpr
try_eta [Id]
bndrs OutExpr
body
where
rec_ids :: UnVarSet
rec_ids = StaticEnv -> UnVarSet
seRecIds StaticEnv
env
in_scope :: InScopeSet
in_scope = StaticEnv -> InScopeSet
getInScope StaticEnv
env
mb_rhs :: Maybe RecFlag
mb_rhs = SimplCont -> Maybe RecFlag
contIsRhs SimplCont
cont
eval_sd :: SubDemand
eval_sd = SimplCont -> SubDemand
contEvalContext SimplCont
cont
try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr
try_eta :: [Id] -> OutExpr -> SimplM OutExpr
try_eta [Id]
bndrs OutExpr
body
|
StaticEnv -> Bool
seDoEtaReduction StaticEnv
env
, Just OutExpr
etad_lam <- UnVarSet -> [Id] -> OutExpr -> SubDemand -> Maybe OutExpr
tryEtaReduce UnVarSet
rec_ids [Id]
bndrs OutExpr
body SubDemand
eval_sd
= do { Tick -> SimplM ()
tick (Id -> Tick
EtaReduction Id
bndr)
; OutExpr -> SimplM OutExpr
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return OutExpr
etad_lam }
|
Maybe RecFlag
Nothing <- Maybe RecFlag
mb_rhs
, StaticEnv -> Bool
seEtaExpand StaticEnv
env
, (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isRuntimeVar [Id]
bndrs
, Just SafeArityType
body_arity <- ArityOpts -> OutExpr -> Maybe SafeArityType
exprEtaExpandArity (StaticEnv -> ArityOpts
seArityOpts StaticEnv
env) OutExpr
body
= do { Tick -> SimplM ()
tick (Id -> Tick
EtaExpansion Id
bndr)
; let body' :: OutExpr
body' = InScopeSet -> SafeArityType -> OutExpr -> OutExpr
etaExpandAT InScopeSet
in_scope SafeArityType
body_arity OutExpr
body
; String -> SDoc -> SimplM ()
traceSmpl String
"eta expand" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"before" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
body
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"after" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
body'])
; OutExpr -> SimplM OutExpr
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> OutExpr -> OutExpr
mk_lams [Id]
bndrs OutExpr
body') }
| Bool
otherwise
= OutExpr -> SimplM OutExpr
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> OutExpr -> OutExpr
mk_lams [Id]
bndrs OutExpr
body)
mk_lams :: [OutBndr] -> OutExpr -> OutExpr
mk_lams :: [Id] -> OutExpr -> OutExpr
mk_lams [Id]
bndrs body :: OutExpr
body@(Lam {})
= [Id] -> OutExpr -> OutExpr
mk_lams ([Id]
bndrs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs1) OutExpr
body1
where
([Id]
bndrs1, OutExpr
body1) = OutExpr -> ([Id], OutExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders OutExpr
body
mk_lams [Id]
bndrs (Tick CoreTickish
t OutExpr
expr)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
= CoreTickish -> OutExpr -> OutExpr
mkTick CoreTickish
t ([Id] -> OutExpr -> OutExpr
mk_lams [Id]
bndrs OutExpr
expr)
mk_lams [Id]
bndrs (Cast OutExpr
body OutCoercion
co)
|
StaticEnv -> Bool
seCastSwizzle StaticEnv
env
, Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
bad [Id]
bndrs)
= (() :: Constraint) => OutExpr -> OutCoercion -> OutExpr
OutExpr -> OutCoercion -> OutExpr
mkCast ([Id] -> OutExpr -> OutExpr
mk_lams [Id]
bndrs OutExpr
body) (Role -> [Id] -> OutCoercion -> OutCoercion
mkPiCos Role
Representational [Id]
bndrs OutCoercion
co)
where
co_vars :: TyCoVarSet
co_vars = OutCoercion -> TyCoVarSet
tyCoVarsOfCo OutCoercion
co
bad :: Id -> Bool
bad Id
bndr = Id -> Bool
isCoVar Id
bndr Bool -> Bool -> Bool
&& Id
bndr Id -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
co_vars
mk_lams [Id]
bndrs OutExpr
body
= [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs OutExpr
body
tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
-> SimplM (ArityType, OutExpr)
tryEtaExpandRhs :: StaticEnv
-> BindContext -> Id -> OutExpr -> SimplM (SafeArityType, OutExpr)
tryEtaExpandRhs StaticEnv
env BindContext
bind_cxt Id
bndr OutExpr
rhs
| Bool
do_eta_expand
, StaticEnv -> Bool
seEtaExpand StaticEnv
env
, OutExpr -> Bool
wantEtaExpansion OutExpr
rhs
=
Bool
-> SDoc
-> SimplM (SafeArityType, OutExpr)
-> SimplM (SafeArityType, OutExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr( Bool -> Bool
not (BindContext -> Bool
isJoinBC BindContext
bind_cxt) ) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr) (SimplM (SafeArityType, OutExpr)
-> SimplM (SafeArityType, OutExpr))
-> SimplM (SafeArityType, OutExpr)
-> SimplM (SafeArityType, OutExpr)
forall a b. (a -> b) -> a -> b
$
do { Tick -> SimplM ()
tick (Id -> Tick
EtaExpansion Id
bndr)
; (SafeArityType, OutExpr) -> SimplM (SafeArityType, OutExpr)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeArityType
arity_type, InScopeSet -> SafeArityType -> OutExpr -> OutExpr
etaExpandAT InScopeSet
in_scope SafeArityType
arity_type OutExpr
rhs) }
| Bool
otherwise
= (SafeArityType, OutExpr) -> SimplM (SafeArityType, OutExpr)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeArityType
arity_type, OutExpr
rhs)
where
in_scope :: InScopeSet
in_scope = StaticEnv -> InScopeSet
getInScope StaticEnv
env
arity_opts :: ArityOpts
arity_opts = StaticEnv -> ArityOpts
seArityOpts StaticEnv
env
is_rec :: RecFlag
is_rec = BindContext -> RecFlag
bindContextRec BindContext
bind_cxt
(Bool
do_eta_expand, SafeArityType
arity_type) = ArityOpts -> RecFlag -> Id -> OutExpr -> (Bool, SafeArityType)
findRhsArity ArityOpts
arity_opts RecFlag
is_rec Id
bndr OutExpr
rhs
wantEtaExpansion :: CoreExpr -> Bool
wantEtaExpansion :: OutExpr -> Bool
wantEtaExpansion (Cast OutExpr
e OutCoercion
_) = OutExpr -> Bool
wantEtaExpansion OutExpr
e
wantEtaExpansion (Tick CoreTickish
_ OutExpr
e) = OutExpr -> Bool
wantEtaExpansion OutExpr
e
wantEtaExpansion (Lam Id
b OutExpr
e) | Id -> Bool
isTyVar Id
b = OutExpr -> Bool
wantEtaExpansion OutExpr
e
wantEtaExpansion (App OutExpr
e OutExpr
_) = OutExpr -> Bool
wantEtaExpansion OutExpr
e
wantEtaExpansion (Var {}) = Bool
False
wantEtaExpansion (Lit {}) = Bool
False
wantEtaExpansion OutExpr
_ = Bool
True
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
-> OutExpr -> SimplM ([OutBind], OutExpr)
abstractFloats :: UnfoldingOpts
-> TopLevelFlag
-> [Id]
-> SimplFloats
-> OutExpr
-> SimplM ([Bind Id], OutExpr)
abstractFloats UnfoldingOpts
uf_opts TopLevelFlag
top_lvl [Id]
main_tvs SimplFloats
floats OutExpr
body
= Bool -> SimplM ([Bind Id], OutExpr) -> SimplM ([Bind Id], OutExpr)
forall a. HasCallStack => Bool -> a -> a
assert ([Bind Id] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Bind Id]
body_floats) (SimplM ([Bind Id], OutExpr) -> SimplM ([Bind Id], OutExpr))
-> SimplM ([Bind Id], OutExpr) -> SimplM ([Bind Id], OutExpr)
forall a b. (a -> b) -> a -> b
$
Bool -> SimplM ([Bind Id], OutExpr) -> SimplM ([Bind Id], OutExpr)
forall a. HasCallStack => Bool -> a -> a
assert (OrdList (Bind Id) -> Bool
forall a. OrdList a -> Bool
isNilOL (SimplFloats -> OrdList (Bind Id)
sfJoinFloats SimplFloats
floats)) (SimplM ([Bind Id], OutExpr) -> SimplM ([Bind Id], OutExpr))
-> SimplM ([Bind Id], OutExpr) -> SimplM ([Bind Id], OutExpr)
forall a b. (a -> b) -> a -> b
$
do { (Subst
subst, [Bind Id]
float_binds) <- (Subst -> Bind Id -> SimplM (Subst, Bind Id))
-> Subst -> [Bind Id] -> SimplM (Subst, [Bind Id])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM Subst -> Bind Id -> SimplM (Subst, Bind Id)
abstract Subst
empty_subst [Bind Id]
body_floats
; ([Bind Id], OutExpr) -> SimplM ([Bind Id], OutExpr)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bind Id]
float_binds, (() :: Constraint) => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
GHC.Core.Subst.substExpr Subst
subst OutExpr
body) }
where
is_top_lvl :: Bool
is_top_lvl = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
body_floats :: [Bind Id]
body_floats = LetFloats -> [Bind Id]
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 Id -> SimplM (Subst, Bind Id)
abstract Subst
subst (NonRec Id
id OutExpr
rhs)
= do { (Id
poly_id1, OutExpr
poly_app) <- [Id] -> Id -> SimplM (Id, OutExpr)
mk_poly1 [Id]
tvs_here Id
id
; let (Id
poly_id2, OutExpr
poly_rhs) = Id -> [Id] -> OutExpr -> (Id, OutExpr)
mk_poly2 Id
poly_id1 [Id]
tvs_here OutExpr
rhs'
!subst' :: Subst
subst' = Subst -> Id -> OutExpr -> Subst
GHC.Core.Subst.extendIdSubst Subst
subst Id
id OutExpr
poly_app
; (Subst, Bind Id) -> SimplM (Subst, Bind Id)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst', Id -> OutExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
poly_id2 OutExpr
poly_rhs) }
where
rhs' :: OutExpr
rhs' = (() :: Constraint) => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
GHC.Core.Subst.substExpr Subst
subst OutExpr
rhs
tvs_here :: [Id]
tvs_here = TyCoVarSet -> [Id]
choose_tvs ((Id -> Bool) -> OutExpr -> TyCoVarSet
exprSomeFreeVars Id -> Bool
isTyVar OutExpr
rhs')
abstract Subst
subst (Rec [(Id, OutExpr)]
prs)
= do { ([Id]
poly_ids, [OutExpr]
poly_apps) <- (Id -> SimplM (Id, OutExpr)) -> [Id] -> SimplM ([Id], [OutExpr])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([Id] -> Id -> SimplM (Id, OutExpr)
mk_poly1 [Id]
tvs_here) [Id]
ids
; let subst' :: Subst
subst' = Subst -> [(Id, OutExpr)] -> Subst
GHC.Core.Subst.extendSubstList Subst
subst ([Id]
ids [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [OutExpr]
poly_apps)
poly_pairs :: [(Id, OutExpr)]
poly_pairs = [ Id -> [Id] -> OutExpr -> (Id, OutExpr)
mk_poly2 Id
poly_id [Id]
tvs_here OutExpr
rhs'
| (Id
poly_id, OutExpr
rhs) <- [Id]
poly_ids [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [OutExpr]
rhss
, let rhs' :: OutExpr
rhs' = (() :: Constraint) => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
GHC.Core.Subst.substExpr Subst
subst' OutExpr
rhs ]
; (Subst, Bind Id) -> SimplM (Subst, Bind Id)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst', [(Id, OutExpr)] -> Bind Id
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, OutExpr)]
poly_pairs) }
where
([Id]
ids,[OutExpr]
rhss) = [(Id, OutExpr)] -> ([Id], [OutExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, OutExpr)]
prs
tvs_here :: [Id]
tvs_here = TyCoVarSet -> [Id]
choose_tvs (((Id, OutExpr) -> TyCoVarSet) -> [(Id, OutExpr)] -> TyCoVarSet
forall a. (a -> TyCoVarSet) -> [a] -> TyCoVarSet
mapUnionVarSet (Id, OutExpr) -> TyCoVarSet
get_bind_fvs [(Id, OutExpr)]
prs)
get_bind_fvs :: (Id, OutExpr) -> TyCoVarSet
get_bind_fvs (Id
id,OutExpr
rhs) = OutType -> TyCoVarSet
tyCoVarsOfType (Id -> OutType
idType Id
id) TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` OutExpr -> TyCoVarSet
get_rec_rhs_tvs OutExpr
rhs
get_rec_rhs_tvs :: OutExpr -> TyCoVarSet
get_rec_rhs_tvs OutExpr
rhs = (Id -> TyCoVarSet -> TyCoVarSet)
-> TyCoVarSet -> TyCoVarSet -> TyCoVarSet
forall a. (Id -> a -> a) -> a -> TyCoVarSet -> a
nonDetStrictFoldVarSet Id -> TyCoVarSet -> TyCoVarSet
get_tvs TyCoVarSet
emptyVarSet (OutExpr -> TyCoVarSet
exprFreeVars OutExpr
rhs)
get_tvs :: Var -> VarSet -> VarSet
get_tvs :: Id -> TyCoVarSet -> TyCoVarSet
get_tvs Id
var TyCoVarSet
free_tvs
| Id -> Bool
isTyVar Id
var
= TyCoVarSet -> Id -> TyCoVarSet
extendVarSet TyCoVarSet
free_tvs Id
var
| Just OutExpr
poly_app <- (() :: Constraint) => Subst -> Id -> Maybe OutExpr
Subst -> Id -> Maybe OutExpr
GHC.Core.Subst.lookupIdSubst_maybe Subst
subst Id
var
=
(Id -> Bool) -> OutExpr -> TyCoVarSet
exprSomeFreeVars Id -> Bool
isTyVar OutExpr
poly_app TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TyCoVarSet
free_tvs
| Bool
otherwise
= TyCoVarSet
free_tvs
choose_tvs :: TyCoVarSet -> [Id]
choose_tvs TyCoVarSet
free_tvs
= (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
all_free_tvs) [Id]
main_tvs
where
all_free_tvs :: TyCoVarSet
all_free_tvs = TyCoVarSet -> TyCoVarSet
closeOverKinds TyCoVarSet
free_tvs
mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
mk_poly1 :: [Id] -> Id -> SimplM (Id, OutExpr)
mk_poly1 [Id]
tvs_here Id
var
= do { Unique
uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let poly_name :: Name
poly_name = Name -> Unique -> Name
setNameUnique (Id -> Name
idName Id
var) Unique
uniq
poly_ty :: OutType
poly_ty = [Id] -> OutType -> OutType
mkInfForAllTys [Id]
tvs_here (Id -> OutType
idType Id
var)
poly_id :: Id
poly_id = Id -> [Id] -> Id -> Id
transferPolyIdInfo Id
var [Id]
tvs_here (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
(() :: Constraint) => Name -> OutType -> OutType -> Id
Name -> OutType -> OutType -> Id
mkLocalId Name
poly_name (Id -> OutType
idMult Id
var) OutType
poly_ty
; (Id, OutExpr) -> SimplM (Id, OutExpr)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
poly_id, OutExpr -> [OutType] -> OutExpr
forall b. Expr b -> [OutType] -> Expr b
mkTyApps (Id -> OutExpr
forall b. Id -> Expr b
Var Id
poly_id) ([Id] -> [OutType]
mkTyVarTys [Id]
tvs_here)) }
mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)
mk_poly2 :: Id -> [Id] -> OutExpr -> (Id, OutExpr)
mk_poly2 Id
poly_id [Id]
tvs_here OutExpr
rhs
= (Id
poly_id Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
unf, OutExpr
poly_rhs)
where
poly_rhs :: OutExpr
poly_rhs = [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs_here OutExpr
rhs
unf :: Unfolding
unf = UnfoldingOpts
-> UnfoldingSource
-> Bool
-> Bool
-> OutExpr
-> Maybe UnfoldingCache
-> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
VanillaSrc Bool
is_top_lvl Bool
False OutExpr
poly_rhs Maybe UnfoldingCache
forall a. Maybe a
Nothing
prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts :: OutExpr -> Id -> [InAlt] -> SimplM ([AltCon], [InAlt])
prepareAlts OutExpr
scrut Id
case_bndr [InAlt]
alts
| Just (TyCon
tc, [OutType]
tys) <- (() :: Constraint) => OutType -> Maybe (TyCon, [OutType])
OutType -> Maybe (TyCon, [OutType])
splitTyConApp_maybe (Id -> OutType
idType Id
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 (Id -> OutType
idMult Id
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 (Id -> Tick
FillInCaseDefault Id
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 (Id -> Tick
AltMerge Id
case_bndr)
; ([AltCon], [InAlt]) -> SimplM ([AltCon], [InAlt])
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AltCon]
idcs3, [InAlt]
alts3) }
| Bool
otherwise
= ([AltCon], [InAlt]) -> SimplM ([AltCon], [InAlt])
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [InAlt]
alts)
where
imposs_cons :: [AltCon]
imposs_cons = case OutExpr
scrut of
Var Id
v -> Unfolding -> [AltCon]
otherCons (IdUnfoldingFun
idUnfolding Id
v)
OutExpr
_ -> []
mkCase, mkCase1, mkCase2, mkCase3
:: SimplMode
-> OutExpr -> OutId
-> OutType -> [OutAlt]
-> SimplM OutExpr
mkCase :: SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase SimplMode
mode OutExpr
scrut Id
outer_bndr OutType
alts_ty (Alt AltCon
DEFAULT [Id]
_ OutExpr
deflt_rhs : [InAlt]
outer_alts)
| SimplMode -> Bool
sm_case_merge SimplMode
mode
, ([CoreTickish]
ticks, Case (Var Id
inner_scrut_var) Id
inner_bndr OutType
_ [InAlt]
inner_alts)
<- (CoreTickish -> Bool) -> OutExpr -> ([CoreTickish], OutExpr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable OutExpr
deflt_rhs
, Id
inner_scrut_var Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
outer_bndr
= do { Tick -> SimplM ()
tick (Id -> Tick
CaseMerge Id
outer_bndr)
; let wrap_alt :: InAlt -> InAlt
wrap_alt (Alt AltCon
con [Id]
args OutExpr
rhs) = Bool -> InAlt -> InAlt
forall a. HasCallStack => Bool -> a -> a
assert (Id
outer_bndr Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Id]
args)
(AltCon -> [Id] -> OutExpr -> InAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args (OutExpr -> OutExpr
wrap_rhs OutExpr
rhs))
wrap_rhs :: OutExpr -> OutExpr
wrap_rhs OutExpr
rhs = Bind Id -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> OutExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
inner_bndr (Id -> OutExpr
forall b. Id -> Expr b
Var Id
outer_bndr)) OutExpr
rhs
wrapped_alts :: [InAlt]
wrapped_alts | Id -> Bool
isDeadBinder Id
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
; (OutExpr -> OutExpr) -> SimplM OutExpr -> SimplM OutExpr
forall a b. (a -> b) -> SimplM a -> SimplM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([CoreTickish] -> OutExpr -> OutExpr
mkTicks [CoreTickish]
ticks) (SimplM OutExpr -> SimplM OutExpr)
-> SimplM OutExpr -> SimplM OutExpr
forall a b. (a -> b) -> a -> b
$
SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase1 SimplMode
mode OutExpr
scrut Id
outer_bndr OutType
alts_ty [InAlt]
merged_alts
}
mkCase SimplMode
mode OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts = SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase1 SimplMode
mode OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts
mkCase1 :: SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase1 SimplMode
_mode OutExpr
scrut Id
case_bndr OutType
_ alts :: [InAlt]
alts@(Alt AltCon
_ [Id]
_ OutExpr
rhs1 : [InAlt]
alts')
| (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 (Id -> Tick
CaseIdentity Id
case_bndr)
; OutExpr -> SimplM OutExpr
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreTickish] -> OutExpr -> OutExpr
mkTicks [CoreTickish]
ticks (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ OutExpr -> OutExpr -> OutExpr
forall {b} {b}. Expr b -> Expr b -> Expr b
re_cast OutExpr
scrut OutExpr
rhs1) }
where
ticks :: [CoreTickish]
ticks = (InAlt -> [CoreTickish]) -> [InAlt] -> [CoreTickish]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Alt AltCon
_ [Id]
_ OutExpr
rhs) -> (CoreTickish -> Bool) -> OutExpr -> [CoreTickish]
forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable OutExpr
rhs) [InAlt]
alts'
identity_alt :: InAlt -> Bool
identity_alt (Alt AltCon
con [Id]
args OutExpr
rhs) = OutExpr -> AltCon -> [Id] -> Bool
check_eq OutExpr
rhs AltCon
con [Id]
args
check_eq :: OutExpr -> AltCon -> [Id] -> Bool
check_eq (Cast OutExpr
rhs OutCoercion
co) AltCon
con [Id]
args
= Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> TyCoVarSet -> Bool
`elemVarSet` OutCoercion -> TyCoVarSet
tyCoVarsOfCo OutCoercion
co) [Id]
args) Bool -> Bool -> Bool
&& OutExpr -> AltCon -> [Id] -> Bool
check_eq OutExpr
rhs AltCon
con [Id]
args
check_eq (Tick CoreTickish
t OutExpr
e) AltCon
alt [Id]
args
= CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t Bool -> Bool -> Bool
&& OutExpr -> AltCon -> [Id] -> Bool
check_eq OutExpr
e AltCon
alt [Id]
args
check_eq (Lit Literal
lit) (LitAlt Literal
lit') [Id]
_ = Literal
lit Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit'
check_eq (Var Id
v) AltCon
_ [Id]
_ | Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
case_bndr = Bool
True
check_eq (Var Id
v) (DataAlt DataCon
con) [Id]
args
| [OutType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OutType]
arg_tys, [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args = Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Id
dataConWorkId DataCon
con
check_eq OutExpr
rhs (DataAlt DataCon
con) [Id]
args = (CoreTickish -> Bool) -> OutExpr -> OutExpr -> Bool
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable OutExpr
rhs (OutExpr -> Bool) -> OutExpr -> Bool
forall a b. (a -> b) -> a -> b
$
DataCon -> [OutType] -> [Id] -> OutExpr
forall b. DataCon -> [OutType] -> [Id] -> Expr b
mkConApp2 DataCon
con [OutType]
arg_tys [Id]
args
check_eq OutExpr
_ AltCon
_ [Id]
_ = Bool
False
arg_tys :: [OutType]
arg_tys = HasCallStack => OutType -> [OutType]
OutType -> [OutType]
tyConAppArgs (Id -> OutType
idType Id
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 SimplMode
mode OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts = SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase2 SimplMode
mode OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts
mkCase2 :: SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase2 SimplMode
mode OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts
|
case [InAlt]
alts of
[Alt AltCon
DEFAULT [Id]
_ OutExpr
_] -> Id -> Bool
isDeadBinder Id
bndr
[InAlt]
_ -> Bool
True
, SimplMode -> Bool
sm_case_folding SimplMode
mode
, Just (OutExpr
scrut', AltCon -> Maybe AltCon
tx_con, Id -> OutExpr
mk_orig) <- Platform
-> OutExpr
-> Maybe (OutExpr, AltCon -> Maybe AltCon, Id -> OutExpr)
caseRules (SimplMode -> Platform
smPlatform SimplMode
mode) OutExpr
scrut
= do { Id
bndr' <- FastString -> OutType -> OutType -> SimplM Id
newId (String -> FastString
fsLit String
"lwild") OutType
ManyTy ((() :: Constraint) => OutExpr -> OutType
OutExpr -> OutType
exprType OutExpr
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)
-> (Id -> OutExpr) -> Id -> InAlt -> SimplM (Maybe InAlt)
tx_alt AltCon -> Maybe AltCon
tx_con Id -> OutExpr
mk_orig Id
bndr') [InAlt]
alts
; SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase3 SimplMode
mode OutExpr
scrut' Id
bndr' OutType
alts_ty ([InAlt] -> SimplM OutExpr) -> [InAlt] -> SimplM OutExpr
forall a b. (a -> b) -> a -> b
$
[InAlt] -> [InAlt]
add_default ([InAlt] -> [InAlt]
re_sort [InAlt]
alts')
}
| Bool
otherwise
= SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase3 SimplMode
mode OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts
where
tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id
-> CoreAlt -> SimplM (Maybe CoreAlt)
tx_alt :: (AltCon -> Maybe AltCon)
-> (Id -> OutExpr) -> Id -> InAlt -> SimplM (Maybe InAlt)
tx_alt AltCon -> Maybe AltCon
tx_con Id -> OutExpr
mk_orig Id
new_bndr (Alt AltCon
con [Id]
bs OutExpr
rhs)
= case AltCon -> Maybe AltCon
tx_con AltCon
con of
Maybe AltCon
Nothing -> Maybe InAlt -> SimplM (Maybe InAlt)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe InAlt
forall a. Maybe a
Nothing
Just AltCon
con' -> do { [Id]
bs' <- Id -> AltCon -> SimplM [Id]
forall {m :: * -> *}. MonadUnique m => Id -> AltCon -> m [Id]
mk_new_bndrs Id
new_bndr AltCon
con'
; Maybe InAlt -> SimplM (Maybe InAlt)
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (InAlt -> Maybe InAlt
forall a. a -> Maybe a
Just (AltCon -> [Id] -> OutExpr -> InAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con' [Id]
bs' OutExpr
rhs')) }
where
rhs' :: OutExpr
rhs' | Id -> Bool
isDeadBinder Id
bndr = OutExpr
rhs
| Bool
otherwise = (() :: Constraint) => Id -> OutExpr -> OutExpr -> OutExpr
Id -> OutExpr -> OutExpr -> OutExpr
bindNonRec Id
bndr OutExpr
orig_val OutExpr
rhs
orig_val :: OutExpr
orig_val = case AltCon
con of
AltCon
DEFAULT -> Id -> OutExpr
mk_orig Id
new_bndr
LitAlt Literal
l -> Literal -> OutExpr
forall b. Literal -> Expr b
Lit Literal
l
DataAlt DataCon
dc -> DataCon -> [OutType] -> [Id] -> OutExpr
forall b. DataCon -> [OutType] -> [Id] -> Expr b
mkConApp2 DataCon
dc (HasCallStack => OutType -> [OutType]
OutType -> [OutType]
tyConAppArgs (Id -> OutType
idType Id
bndr)) [Id]
bs
mk_new_bndrs :: Id -> AltCon -> m [Id]
mk_new_bndrs Id
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 ([Id]
ex_tvs, [Id]
arg_ids) = [Unique] -> OutType -> DataCon -> [OutType] -> ([Id], [Id])
dataConRepInstPat [Unique]
us (Id -> OutType
idMult Id
new_bndr) DataCon
dc
(HasCallStack => OutType -> [OutType]
OutType -> [OutType]
tyConAppArgs (Id -> OutType
idType Id
new_bndr))
; [Id] -> m [Id]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ex_tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids) }
mk_new_bndrs Id
_ AltCon
_ = [Id] -> m [Id]
forall a. a -> m a
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 {}) [Id]
bs OutExpr
rhs : [InAlt]
alts) = AltCon -> [Id] -> OutExpr -> InAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [Id]
bs OutExpr
rhs InAlt -> [InAlt] -> [InAlt]
forall a. a -> [a] -> [a]
: [InAlt]
alts
add_default [InAlt]
alts = [InAlt]
alts
mkCase3 :: SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase3 SimplMode
_mode OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts
= OutExpr -> SimplM OutExpr
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OutExpr -> Id -> OutType -> [InAlt] -> OutExpr
forall b. Expr b -> b -> OutType -> [Alt b] -> Expr b
Case OutExpr
scrut Id
bndr OutType
alts_ty [InAlt]
alts)
isExitJoinId :: Var -> Bool
isExitJoinId :: Id -> Bool
isExitJoinId Id
id
= Id -> Bool
isJoinId Id
id
Bool -> Bool -> Bool
&& OccInfo -> Bool
isOneOcc (Id -> OccInfo
idOccInfo Id
id)
Bool -> Bool -> Bool
&& OccInfo -> InsideLam
occ_in_lam (Id -> OccInfo
idOccInfo Id
id) InsideLam -> InsideLam -> Bool
forall a. Eq a => a -> a -> Bool
== InsideLam
IsInsideLam