module GHC.Core.Opt.Simplify.Utils (
rebuildLam, mkCase, prepareAlts,
tryEtaExpandRhs, wantEtaExpansion,
preInlineUnconditionally, postInlineUnconditionally,
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 qualified GHC.Prelude as Partial (head)
import GHC.Core
import GHC.Types.Literal ( isLitRubbish )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline )
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 Control.Monad ( when )
import Data.List ( sortBy )
import GHC.Types.Name.Env
import Data.Graph
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
{ SimplCont -> OutCoercion
sc_co :: OutCoercion
, SimplCont -> Bool
sc_opt :: Bool
, SimplCont -> SimplCont
sc_cont :: SimplCont }
| ApplyToVal
{ SimplCont -> DupFlag
sc_dup :: DupFlag
, SimplCont -> OutType
sc_hole_ty :: OutType
, SimplCont -> OutExpr
sc_arg :: InExpr
, SimplCont -> StaticEnv
sc_env :: StaticEnv
, 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
, SimplCont -> FromWhat
sc_from :: FromWhat
, sc_bndr :: InId
, 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 Levity
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 = HasDebugCallStack => 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 { sc_co :: SimplCont -> OutCoercion
sc_co = OutCoercion
co, sc_cont :: SimplCont -> SimplCont
sc_cont = 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_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
$ [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
= CastIt { sc_co :: OutCoercion
sc_co = OutCoercion
c, sc_cont :: SimplCont
sc_cont = SimplCont
cont, sc_opt :: Bool
sc_opt = Bool
True }
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) = HasDebugCallStack => 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_co :: SimplCont -> OutCoercion
sc_co = OutCoercion
co }) = HasDebugCallStack => OutCoercion -> OutType
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 }) = HasDebugCallStack => OutType -> OutType
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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 })
= HasDebugCallStack => Id -> OutType
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 })
= HasDebugCallStack => Id -> OutType
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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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'
| OutType -> Bool
definitelyUnliftedType 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) = RecFlag -> CallCtxt
RhsCtxt RecFlag
NonRecursive
| 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 { sc_cont :: SimplCont -> SimplCont
sc_cont = 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 JoinPointHood
_ -> 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
otherwise
= case IdUnfoldingFun
idUnfolding Id
v of
OtherCon [] -> ArgSummary
NonTrivArg
OtherCon [AltCon]
_ -> ArgSummary
ValueArg
DFunUnfolding {} -> ArgSummary
ValueArg
CoreUnfolding{ uf_cache :: Unfolding -> UnfoldingCache
uf_cache = UnfoldingCache
cache }
| UnfoldingCache -> Bool
uf_is_conlike UnfoldingCache
cache -> ArgSummary
ValueArg
| UnfoldingCache -> Bool
uf_is_value UnfoldingCache
cache -> ArgSummary
NonTrivArg
| Bool
otherwise -> ArgSummary
TrivArg
Unfolding
BootUnfolding -> ArgSummary
TrivArg
Unfolding
NoUnfolding -> ArgSummary
TrivArg
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 }
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
-> InId -> OutId
-> OutExpr
-> Bool
postInlineUnconditionally :: StaticEnv -> BindContext -> Id -> Id -> OutExpr -> Bool
postInlineUnconditionally StaticEnv
env BindContext
bind_cxt Id
old_bndr Id
bndr 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
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
False
| BranchCount
n_br BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== BranchCount
1, InsideLam
NotInsideLam <- InsideLam
in_lam
-> Bool
True
| Bool
is_demanded
-> Bool
False
| Bool
otherwise
-> InsideLam -> InterestingCxt -> Bool
work_ok InsideLam
in_lam InterestingCxt
int_cxt Bool -> Bool -> Bool
&& UnfoldingOpts -> Unfolding -> Bool
smallEnoughToInline UnfoldingOpts
uf_opts Unfolding
unfolding
OccInfo
IAmDead -> Bool
True
OccInfo
_ -> Bool
False
where
work_ok :: InsideLam -> InterestingCxt -> Bool
work_ok InsideLam
NotInsideLam InterestingCxt
_ = Bool
True
work_ok InsideLam
IsInsideLam InterestingCxt
IsInteresting = Unfolding -> Bool
isCheapUnfolding Unfolding
unfolding
work_ok InsideLam
IsInsideLam InterestingCxt
NotInteresting = Bool
False
is_demanded :: Bool
is_demanded = Demand -> Bool
isStrUsedDmd (Id -> Demand
idDemandInfo Id
bndr)
occ_info :: OccInfo
occ_info = Id -> OccInfo
idOccInfo Id
old_bndr
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 <- HasDebugCallStack => ArityOpts -> OutExpr -> Maybe SafeArityType
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)
= HasDebugCallStack => 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
| StaticEnv -> Bool
seEtaExpand StaticEnv
env
, OutExpr -> Bool
wantEtaExpansion OutExpr
rhs
, Bool
do_eta_expand
=
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 { let sccs :: [SCC (Id, OutExpr, TyCoVarSet)]
sccs = (Bind Id -> [SCC (Id, OutExpr, TyCoVarSet)])
-> [Bind Id] -> [SCC (Id, OutExpr, TyCoVarSet)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [SCC (Id, OutExpr, TyCoVarSet)]
to_sccs [Bind Id]
body_floats
; (subst, float_binds) <- (Subst -> SCC (Id, OutExpr, TyCoVarSet) -> SimplM (Subst, Bind Id))
-> Subst
-> [SCC (Id, OutExpr, TyCoVarSet)]
-> 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 -> SCC (Id, OutExpr, TyCoVarSet) -> SimplM (Subst, Bind Id)
abstract Subst
empty_subst [SCC (Id, OutExpr, TyCoVarSet)]
sccs
; return (float_binds, GHC.Core.Subst.substExpr subst 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)
to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]
to_sccs :: Bind Id -> [SCC (Id, OutExpr, TyCoVarSet)]
to_sccs (NonRec Id
id OutExpr
e) = [(Id, OutExpr, TyCoVarSet) -> SCC (Id, OutExpr, TyCoVarSet)
forall vertex. vertex -> SCC vertex
AcyclicSCC (Id
id, OutExpr
e, TyCoVarSet
emptyVarSet)]
to_sccs (Rec [(Id, OutExpr)]
prs) = [SCC (Id, OutExpr, TyCoVarSet)]
sccs
where
([Id]
ids,[OutExpr]
rhss) = [(Id, OutExpr)] -> ([Id], [OutExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, OutExpr)]
prs
sccs :: [SCC (Id, OutExpr, TyCoVarSet)]
sccs = ((Id, OutExpr, TyCoVarSet) -> [Name])
-> ((Id, OutExpr, TyCoVarSet) -> [Name])
-> [(Id, OutExpr, TyCoVarSet)]
-> [SCC (Id, OutExpr, TyCoVarSet)]
forall node.
(node -> [Name]) -> (node -> [Name]) -> [node] -> [SCC node]
depAnal (\(Id
id,OutExpr
_rhs,TyCoVarSet
_fvs) -> [Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id])
(\(Id
_id,OutExpr
_rhs,TyCoVarSet
fvs) -> (Id -> [Name] -> [Name]) -> [Name] -> TyCoVarSet -> [Name]
forall a. (Id -> a -> a) -> a -> TyCoVarSet -> a
nonDetStrictFoldVarSet ((:) (Name -> [Name] -> [Name])
-> (Id -> Name) -> Id -> [Name] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
forall a. NamedThing a => a -> Name
getName) [] TyCoVarSet
fvs)
([Id] -> [OutExpr] -> [TyCoVarSet] -> [(Id, OutExpr, TyCoVarSet)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
ids [OutExpr]
rhss ((OutExpr -> TyCoVarSet) -> [OutExpr] -> [TyCoVarSet]
forall a b. (a -> b) -> [a] -> [b]
map OutExpr -> TyCoVarSet
exprFreeVars [OutExpr]
rhss))
abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)
abstract :: Subst -> SCC (Id, OutExpr, TyCoVarSet) -> SimplM (Subst, Bind Id)
abstract Subst
subst (AcyclicSCC (Id
id, OutExpr
rhs, TyCoVarSet
_empty_var_set))
= do { (poly_id1, poly_app) <- [Id] -> Id -> SimplM (Id, OutExpr)
mk_poly1 [Id]
tvs_here Id
id
; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
!subst' = Subst -> Id -> OutExpr -> Subst
GHC.Core.Subst.extendIdSubst Subst
subst Id
id OutExpr
poly_app
; return (subst', NonRec poly_id2 poly_rhs) }
where
rhs' :: OutExpr
rhs' = HasDebugCallStack => 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 (CyclicSCC [(Id, OutExpr, TyCoVarSet)]
trpls)
= do { (poly_ids, 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 -> [(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 -> [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' = HasDebugCallStack => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
GHC.Core.Subst.substExpr Subst
subst' OutExpr
rhs ]
; return (subst', Rec poly_pairs) }
where
([Id]
ids,[OutExpr]
rhss,[TyCoVarSet]
_fvss) = [(Id, OutExpr, TyCoVarSet)] -> ([Id], [OutExpr], [TyCoVarSet])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Id, OutExpr, TyCoVarSet)]
trpls
tvs_here :: [Id]
tvs_here = TyCoVarSet -> [Id]
choose_tvs (((Id, OutExpr, TyCoVarSet) -> TyCoVarSet)
-> [(Id, OutExpr, TyCoVarSet)] -> TyCoVarSet
forall a. (a -> TyCoVarSet) -> [a] -> TyCoVarSet
mapUnionVarSet (Id, OutExpr, TyCoVarSet) -> TyCoVarSet
forall {b}. (Id, b, TyCoVarSet) -> TyCoVarSet
get_bind_fvs [(Id, OutExpr, TyCoVarSet)]
trpls)
get_bind_fvs :: (Id, b, TyCoVarSet) -> TyCoVarSet
get_bind_fvs (Id
id,b
_rhs,TyCoVarSet
rhs_fvs) = OutType -> TyCoVarSet
tyCoVarsOfType (Id -> OutType
idType Id
id) TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TyCoVarSet -> TyCoVarSet
get_rec_rhs_tvs TyCoVarSet
rhs_fvs
get_rec_rhs_tvs :: TyCoVarSet -> TyCoVarSet
get_rec_rhs_tvs TyCoVarSet
rhs_fvs = (Id -> TyCoVarSet -> TyCoVarSet)
-> TyCoVarSet -> TyCoVarSet -> TyCoVarSet
forall a. (Id -> a -> a) -> a -> TyCoVarSet -> a
nonDetStrictFoldVarSet Id -> TyCoVarSet -> TyCoVarSet
get_tvs TyCoVarSet
emptyVarSet TyCoVarSet
rhs_fvs
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
| Id -> Bool
isCoVar Id
var
= TyCoVarSet
free_tvs
| Just OutExpr
poly_app <- HasDebugCallStack => 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 { uniq <- SimplM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let poly_name = Name -> Unique -> Name
setNameUnique (Id -> Name
idName Id
var) Unique
uniq
poly_ty = [Id] -> OutType -> OutType
mkInfForAllTys [Id]
tvs_here (Id -> OutType
idType Id
var)
poly_id = Id -> [Id] -> Id -> Id
transferPolyIdInfo Id
var [Id]
tvs_here (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Name -> OutType -> OutType -> Id
Name -> OutType -> OutType -> Id
mkLocalId Name
poly_name (HasDebugCallStack => Id -> OutType
Id -> OutType
idMult Id
var) OutType
poly_ty
; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys 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
-> Bool
-> OutExpr
-> Maybe UnfoldingCache
-> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
VanillaSrc Bool
is_top_lvl Bool
False 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) <- HasDebugCallStack => OutType -> Maybe (TyCon, [OutType])
OutType -> Maybe (TyCon, [OutType])
splitTyConApp_maybe (Id -> OutType
idType Id
case_bndr)
= do { us <- SimplM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts
(yes2, alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1
(yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2
; when yes2 $ tick (FillInCaseDefault case_bndr)
; when yes3 $ tick (AltMerge case_bndr)
; return (idcs3, 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 [InAlt]
alts
| SimplMode -> Bool
sm_case_merge SimplMode
mode
, Just ([Bind Id]
joins, [InAlt]
alts') <- Id -> [InAlt] -> Maybe ([Bind Id], [InAlt])
mergeCaseAlts Id
outer_bndr [InAlt]
alts
= do { Tick -> SimplM ()
tick (Id -> Tick
CaseMerge Id
outer_bndr)
; case_expr <- SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase1 SimplMode
mode OutExpr
scrut Id
outer_bndr OutType
alts_ty [InAlt]
alts'
; return (mkLets joins case_expr) }
| Bool
otherwise
= SimplMode -> OutExpr -> Id -> OutType -> [InAlt] -> SimplM OutExpr
mkCase1 SimplMode
mode OutExpr
scrut Id
outer_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 = HasDebugCallStack => 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 { bndr' <- FastString -> OutType -> OutType -> SimplM Id
newId (String -> FastString
fsLit String
"lwild") OutType
ManyTy (HasDebugCallStack => OutExpr -> OutType
OutExpr -> OutType
exprType OutExpr
scrut')
; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts
; mkCase3 mode scrut' bndr' alts_ty $
add_default (re_sort 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 { bs' <- Id -> AltCon -> SimplM [Id]
forall {m :: * -> *}. MonadUnique m => Id -> AltCon -> m [Id]
mk_new_bndrs Id
new_bndr AltCon
con'
; return (Just (Alt con' bs' rhs')) }
where
rhs' :: OutExpr
rhs' | Id -> Bool
isDeadBinder Id
bndr = OutExpr
rhs
| Bool
otherwise = HasDebugCallStack => 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 (HasDebugCallStack => 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 { us <- m [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc
(tyConAppArgs (idType new_bndr))
; return (ex_tvs ++ 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
&& case Id -> OccInfo
idOccInfo Id
id of
OneOcc { occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
IsInsideLam } -> Bool
True
OccInfo
_ -> Bool
False