module GHC.Core.SimpleOpt (
SimpleOpts (..), defaultSimpleOpts,
simpleOptPgm, simpleOptExpr, simpleOptExprWith,
joinPointBinding_maybe, joinPointBindings_maybe,
exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
) where
import GHC.Prelude
import GHC.Core
import GHC.Core.Opt.Arity
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Make ( FloatBind(..) )
import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs )
import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
import GHC.Types.Var ( isNonCoVarId )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Core.DataCon
import GHC.Types.Demand( etaConvertDmdSig )
import GHC.Types.Tickish
import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )
import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Unit.Module ( Module )
import GHC.Utils.Encoding
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe ( orElse )
import GHC.Data.Graph.UnVar
import Data.List (mapAccumL)
import qualified Data.ByteString as BS
data SimpleOpts = SimpleOpts
{ SimpleOpts -> UnfoldingOpts
so_uf_opts :: !UnfoldingOpts
, SimpleOpts -> OptCoercionOpts
so_co_opts :: !OptCoercionOpts
}
defaultSimpleOpts :: SimpleOpts
defaultSimpleOpts :: SimpleOpts
defaultSimpleOpts = SimpleOpts
{ so_uf_opts :: UnfoldingOpts
so_uf_opts = UnfoldingOpts
defaultUnfoldingOpts
, so_co_opts :: OptCoercionOpts
so_co_opts = OptCoercionOpts
{ optCoercionEnabled :: Bool
optCoercionEnabled = Bool
False }
}
simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr :: (() :: Constraint) => SimpleOpts -> OutExpr -> OutExpr
simpleOptExpr SimpleOpts
opts OutExpr
expr
=
(() :: Constraint) => SimpleOpts -> Subst -> OutExpr -> OutExpr
SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
opts Subst
init_subst OutExpr
expr
where
init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet (OutExpr -> VarSet
exprFreeVars OutExpr
expr))
simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
simpleOptExprWith :: (() :: Constraint) => SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
opts Subst
subst OutExpr
expr
= HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
init_env (OutExpr -> OutExpr
occurAnalyseExpr OutExpr
expr)
where
init_env :: SimpleOptEnv
init_env = (SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts) { soe_subst :: Subst
soe_subst = Subst
subst }
simpleOptPgm :: SimpleOpts
-> Module
-> CoreProgram
-> [CoreRule]
-> (CoreProgram, [CoreRule], CoreProgram)
simpleOptPgm :: SimpleOpts
-> Module
-> CoreProgram
-> [CoreRule]
-> (CoreProgram, [CoreRule], CoreProgram)
simpleOptPgm SimpleOpts
opts Module
this_mod CoreProgram
binds [CoreRule]
rules =
(CoreProgram -> CoreProgram
forall a. [a] -> [a]
reverse CoreProgram
binds', [CoreRule]
rules', CoreProgram
occ_anald_binds)
where
occ_anald_binds :: CoreProgram
occ_anald_binds = Module
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod
(\Id
_ -> Bool
True)
(\Activation
_ -> Bool
False)
[CoreRule]
rules CoreProgram
binds
(SimpleOptEnv
final_env, CoreProgram
binds') = ((SimpleOptEnv, CoreProgram)
-> InBind -> (SimpleOptEnv, CoreProgram))
-> (SimpleOptEnv, CoreProgram)
-> CoreProgram
-> (SimpleOptEnv, CoreProgram)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, CoreProgram)
-> InBind -> (SimpleOptEnv, CoreProgram)
do_one (SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts, []) CoreProgram
occ_anald_binds
final_subst :: Subst
final_subst = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
final_env
rules' :: [CoreRule]
rules' = Subst -> [CoreRule] -> [CoreRule]
substRulesForImportedIds Subst
final_subst [CoreRule]
rules
do_one :: (SimpleOptEnv, CoreProgram)
-> InBind -> (SimpleOptEnv, CoreProgram)
do_one (SimpleOptEnv
env, CoreProgram
binds') InBind
bind
= case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
TopLevel of
(SimpleOptEnv
env', Maybe InBind
Nothing) -> (SimpleOptEnv
env', CoreProgram
binds')
(SimpleOptEnv
env', Just InBind
bind') -> (SimpleOptEnv
env', InBind
bind'InBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
:CoreProgram
binds')
type SimpleClo = (SimpleOptEnv, InExpr)
data SimpleOptEnv
= SOE { SimpleOptEnv -> OptCoercionOpts
soe_co_opt_opts :: !OptCoercionOpts
, SimpleOptEnv -> UnfoldingOpts
soe_uf_opts :: !UnfoldingOpts
, SimpleOptEnv -> IdEnv SimpleClo
soe_inl :: IdEnv SimpleClo
, SimpleOptEnv -> Subst
soe_subst :: Subst
, SimpleOptEnv -> UnVarSet
soe_rec_ids :: !UnVarSet
}
instance Outputable SimpleOptEnv where
ppr :: SimpleOptEnv -> SDoc
ppr (SOE { soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl, soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
= String -> SDoc
text String
"SOE {" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"soe_inl =" SDoc -> SDoc -> SDoc
<+> IdEnv SimpleClo -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdEnv SimpleClo
inl
, String -> SDoc
text String
"soe_subst =" SDoc -> SDoc -> SDoc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst ]
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"}"
emptyEnv :: SimpleOpts -> SimpleOptEnv
emptyEnv :: SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts = SOE
{ soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv
, soe_subst :: Subst
soe_subst = Subst
emptySubst
, soe_rec_ids :: UnVarSet
soe_rec_ids = UnVarSet
emptyUnVarSet
, soe_co_opt_opts :: OptCoercionOpts
soe_co_opt_opts = SimpleOpts -> OptCoercionOpts
so_co_opts SimpleOpts
opts
, soe_uf_opts :: UnfoldingOpts
soe_uf_opts = SimpleOpts -> UnfoldingOpts
so_uf_opts SimpleOpts
opts
}
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
= SimpleOptEnv
env { soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv, soe_subst :: Subst
soe_subst = Subst -> Subst
zapSubstEnv Subst
subst }
soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope (SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst1 })
env2 :: SimpleOptEnv
env2@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst2 })
= SimpleOptEnv
env2 { soe_subst :: Subst
soe_subst = Subst -> InScopeSet -> Subst
setInScope Subst
subst2 (Subst -> InScopeSet
substInScope Subst
subst1) }
enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r))
-> (SimpleOptEnv, r)
enterRecGroupRHSs :: forall r.
SimpleOptEnv
-> [Id] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r)
enterRecGroupRHSs SimpleOptEnv
env [Id]
bndrs SimpleOptEnv -> (SimpleOptEnv, r)
k
= (SimpleOptEnv
env'{soe_rec_ids :: UnVarSet
soe_rec_ids = SimpleOptEnv -> UnVarSet
soe_rec_ids SimpleOptEnv
env}, r
r)
where
(SimpleOptEnv
env', r
r) = SimpleOptEnv -> (SimpleOptEnv, r)
k SimpleOptEnv
env{soe_rec_ids :: UnVarSet
soe_rec_ids = [Id] -> UnVarSet -> UnVarSet
extendUnVarSetList [Id]
bndrs (SimpleOptEnv -> UnVarSet
soe_rec_ids SimpleOptEnv
env)}
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo SimpleOptEnv
env (SimpleOptEnv
e_env, OutExpr
e)
= HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
e_env) OutExpr
e
simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr :: HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
expr
= OutExpr -> OutExpr
go OutExpr
expr
where
rec_ids :: UnVarSet
rec_ids = SimpleOptEnv -> UnVarSet
soe_rec_ids SimpleOptEnv
env
subst :: Subst
subst = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
substInScope Subst
subst
in_scope_env :: (InScopeSet, IdUnfoldingFun)
in_scope_env = (InScopeSet
in_scope, IdUnfoldingFun
simpleUnfoldingFun)
go :: OutExpr -> OutExpr
go (Var Id
v)
| Just SimpleClo
clo <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
= SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
| Bool
otherwise
= (() :: Constraint) => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
go (App OutExpr
e1 OutExpr
e2) = (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e1 [(SimpleOptEnv
env,OutExpr
e2)]
go (Type Type
ty) = Type -> OutExpr
forall b. Type -> Expr b
Type (Subst -> Type -> Type
substTy Subst
subst Type
ty)
go (Coercion Coercion
co) = Coercion -> OutExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> Coercion
go_co Coercion
co)
go (Lit Literal
lit) = Literal -> OutExpr
forall b. Literal -> Expr b
Lit Literal
lit
go (Tick CoreTickish
tickish OutExpr
e) = CoreTickish -> OutExpr -> OutExpr
mkTick (Subst -> CoreTickish -> CoreTickish
substTickish Subst
subst CoreTickish
tickish) (OutExpr -> OutExpr
go OutExpr
e)
go (Cast OutExpr
e Coercion
co) = OutExpr -> Coercion -> OutExpr
mk_cast (OutExpr -> OutExpr
go OutExpr
e) (Coercion -> Coercion
go_co Coercion
co)
go (Let InBind
bind OutExpr
body) = case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
NotTopLevel of
(SimpleOptEnv
env', Maybe InBind
Nothing) -> HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body
(SimpleOptEnv
env', Just InBind
bind) -> InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body)
go lam :: OutExpr
lam@(Lam {}) = SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env [] OutExpr
lam
go (Case OutExpr
e Id
b Type
ty [Alt Id]
as)
| Id -> Bool
isDeadBinder Id
b
, Just (InScopeSet
_, [], DataCon
con, [Type]
_tys, [OutExpr]
es) <- (InScopeSet, IdUnfoldingFun)
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
exprIsConApp_maybe (InScopeSet, IdUnfoldingFun)
in_scope_env OutExpr
e'
, Just (Alt AltCon
altcon [Id]
bs OutExpr
rhs) <- AltCon -> [Alt Id] -> Maybe (Alt Id)
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt (DataCon -> AltCon
DataAlt DataCon
con) [Alt Id]
as
= case AltCon
altcon of
AltCon
DEFAULT -> OutExpr -> OutExpr
go OutExpr
rhs
AltCon
_ -> (Maybe (Id, OutExpr) -> OutExpr -> OutExpr)
-> OutExpr -> [Maybe (Id, OutExpr)] -> OutExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
rhs) [Maybe (Id, OutExpr)]
mb_prs
where
(SimpleOptEnv
env', [Maybe (Id, OutExpr)]
mb_prs) = (SimpleOptEnv
-> (Id, OutExpr) -> (SimpleOptEnv, Maybe (Id, OutExpr)))
-> SimpleOptEnv
-> [(Id, OutExpr)]
-> (SimpleOptEnv, [Maybe (Id, OutExpr)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (TopLevelFlag
-> SimpleOptEnv
-> (Id, OutExpr)
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind TopLevelFlag
NotTopLevel) SimpleOptEnv
env ([(Id, OutExpr)] -> (SimpleOptEnv, [Maybe (Id, OutExpr)]))
-> [(Id, OutExpr)] -> (SimpleOptEnv, [Maybe (Id, OutExpr)])
forall a b. (a -> b) -> a -> b
$
String -> [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"simpleOptExpr" [Id]
bs [OutExpr]
es
| Id -> Bool
isDeadBinder Id
b
, [Alt AltCon
DEFAULT [Id]
_ OutExpr
rhs] <- [Alt Id]
as
, Type -> Bool
isCoVarType (Id -> Type
varType Id
b)
, (Var Id
fun, [OutExpr]
_args) <- OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
e
, Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleSCSelIdKey
= OutExpr -> OutExpr
go OutExpr
rhs
| Bool
otherwise
= OutExpr -> Id -> Type -> [Alt Id] -> OutExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case OutExpr
e' Id
b' (Subst -> Type -> Type
substTy Subst
subst Type
ty)
((Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map (SimpleOptEnv -> Alt Id -> Alt Id
go_alt SimpleOptEnv
env') [Alt Id]
as)
where
e' :: OutExpr
e' = OutExpr -> OutExpr
go OutExpr
e
(SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
go_co :: Coercion -> Coercion
go_co Coercion
co = OptCoercionOpts -> TCvSubst -> Coercion -> Coercion
optCoercion (SimpleOptEnv -> OptCoercionOpts
soe_co_opt_opts SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst Subst
subst) Coercion
co
go_alt :: SimpleOptEnv -> Alt Id -> Alt Id
go_alt SimpleOptEnv
env (Alt AltCon
con [Id]
bndrs OutExpr
rhs)
= AltCon -> [Id] -> OutExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndrs' (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
rhs)
where
(SimpleOptEnv
env', [Id]
bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs
go_lam :: SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env [Id]
bs' (Lam Id
b OutExpr
e)
= SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env' (Id
b'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs') OutExpr
e
where
(SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
go_lam SimpleOptEnv
env [Id]
bs' OutExpr
e
| Just OutExpr
etad_e <- UnVarSet -> [Id] -> OutExpr -> Maybe OutExpr
tryEtaReduce UnVarSet
rec_ids [Id]
bs OutExpr
e' = OutExpr
etad_e
| Bool
otherwise = [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bs OutExpr
e'
where
bs :: [Id]
bs = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs'
e' :: OutExpr
e' = HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
e
mk_cast :: CoreExpr -> CoercionR -> CoreExpr
mk_cast :: OutExpr -> Coercion -> OutExpr
mk_cast (Cast OutExpr
e Coercion
co1) Coercion
co2 = OutExpr -> Coercion -> OutExpr
mk_cast OutExpr
e (Coercion
co1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2)
mk_cast (Tick CoreTickish
t OutExpr
e) Coercion
co = CoreTickish -> OutExpr -> OutExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (OutExpr -> Coercion -> OutExpr
mk_cast OutExpr
e Coercion
co)
mk_cast OutExpr
e Coercion
co | Coercion -> Bool
isReflexiveCo Coercion
co = OutExpr
e
| Bool
otherwise = OutExpr -> Coercion -> OutExpr
forall b. Expr b -> Coercion -> Expr b
Cast OutExpr
e Coercion
co
simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
simple_app :: (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env (Var Id
v) [SimpleClo]
as
| Just (SimpleOptEnv
env', OutExpr
e) <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
= (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
env') OutExpr
e [SimpleClo]
as
| let unf :: Unfolding
unf = IdUnfoldingFun
idUnfolding Id
v
, Unfolding -> Bool
isCompulsoryUnfolding (IdUnfoldingFun
idUnfolding Id
v)
, Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
v)
= (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app (SimpleOptEnv -> SimpleOptEnv
soeZapSubst SimpleOptEnv
env) (Unfolding -> OutExpr
unfoldingTemplate Unfolding
unf) [SimpleClo]
as
| Bool
otherwise
, let out_fn :: OutExpr
out_fn = (() :: Constraint) => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
= SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env OutExpr
out_fn [SimpleClo]
as
simple_app SimpleOptEnv
env (App OutExpr
e1 OutExpr
e2) [SimpleClo]
as
= (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e1 ((SimpleOptEnv
env, OutExpr
e2) SimpleClo -> [SimpleClo] -> [SimpleClo]
forall a. a -> [a] -> [a]
: [SimpleClo]
as)
simple_app SimpleOptEnv
env e :: OutExpr
e@(Lam {}) as :: [SimpleClo]
as@(SimpleClo
_:[SimpleClo]
_)
= SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env (OutExpr -> BranchCount -> OutExpr
zapLambdaBndrs OutExpr
e BranchCount
n_args) [SimpleClo]
as
where
n_args :: BranchCount
n_args = [SimpleClo] -> BranchCount
forall a. [a] -> BranchCount
forall (t :: * -> *) a. Foldable t => t a -> BranchCount
length [SimpleClo]
as
do_beta :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env (Lam Id
b OutExpr
body) (SimpleClo
a:[SimpleClo]
as)
| (SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) <- SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b Maybe Id
forall a. Maybe a
Nothing SimpleClo
a TopLevelFlag
NotTopLevel
= Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet Maybe (Id, OutExpr)
mb_pr (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env' OutExpr
body [SimpleClo]
as
do_beta SimpleOptEnv
env OutExpr
body [SimpleClo]
as
= (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
body [SimpleClo]
as
simple_app SimpleOptEnv
env (Tick CoreTickish
t OutExpr
e) [SimpleClo]
as
| CoreTickish
t CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= CoreTickish -> OutExpr -> OutExpr
mkTick CoreTickish
t (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e [SimpleClo]
as
simple_app SimpleOptEnv
env (Let InBind
bind OutExpr
body) [SimpleClo]
args
= case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
NotTopLevel of
(SimpleOptEnv
env', Maybe InBind
Nothing) -> (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env' OutExpr
body [SimpleClo]
args
(SimpleOptEnv
env', Just InBind
bind')
| InBind -> Bool
isJoinBind InBind
bind' -> SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env OutExpr
expr' [SimpleClo]
args
| Bool
otherwise -> InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' ((() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env' OutExpr
body [SimpleClo]
args)
where
expr' :: OutExpr
expr' = InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body)
simple_app SimpleOptEnv
env OutExpr
e [SimpleClo]
as
= SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
e) [SimpleClo]
as
finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
_ OutExpr
fun []
= OutExpr
fun
finish_app SimpleOptEnv
env OutExpr
fun (SimpleClo
arg:[SimpleClo]
args)
= SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env (OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
App OutExpr
fun (SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
arg)) [SimpleClo]
args
simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag
-> (SimpleOptEnv, Maybe OutBind)
simple_opt_bind :: SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env (NonRec Id
b OutExpr
r) TopLevelFlag
top_level
= (SimpleOptEnv
env', case Maybe (Id, OutExpr)
mb_pr of
Maybe (Id, OutExpr)
Nothing -> Maybe InBind
forall a. Maybe a
Nothing
Just (Id
b,OutExpr
r) -> InBind -> Maybe InBind
forall a. a -> Maybe a
Just (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r))
where
(Id
b', OutExpr
r') = Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe Id
b OutExpr
r Maybe (Id, OutExpr) -> (Id, OutExpr) -> (Id, OutExpr)
forall a. Maybe a -> a -> a
`orElse` (Id
b, OutExpr
r)
(SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b' Maybe Id
forall a. Maybe a
Nothing (SimpleOptEnv
env,OutExpr
r') TopLevelFlag
top_level
simple_opt_bind SimpleOptEnv
env (Rec [(Id, OutExpr)]
prs) TopLevelFlag
top_level
= (SimpleOptEnv
env2, Maybe InBind
res_bind)
where
res_bind :: Maybe InBind
res_bind = InBind -> Maybe InBind
forall a. a -> Maybe a
Just ([(Id, OutExpr)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. [a] -> [a]
reverse [(Id, OutExpr)]
rev_prs'))
prs' :: [(Id, OutExpr)]
prs' = [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
joinPointBindings_maybe [(Id, OutExpr)]
prs Maybe [(Id, OutExpr)] -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. Maybe a -> a -> a
`orElse` [(Id, OutExpr)]
prs
(SimpleOptEnv
env1, [Id]
bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env (((Id, OutExpr) -> Id) -> [(Id, OutExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, OutExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, OutExpr)]
prs')
(SimpleOptEnv
env2, [(Id, OutExpr)]
rev_prs') = SimpleOptEnv
-> [Id]
-> (SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
forall r.
SimpleOptEnv
-> [Id] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r)
enterRecGroupRHSs SimpleOptEnv
env1 [Id]
bndrs' ((SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
forall a b. (a -> b) -> a -> b
$ \SimpleOptEnv
env ->
((SimpleOptEnv, [(Id, OutExpr)])
-> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
-> [((Id, OutExpr), Id)]
-> (SimpleOptEnv, [(Id, OutExpr)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, [(Id, OutExpr)])
-> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)])
do_pr (SimpleOptEnv
env, []) ([(Id, OutExpr)]
prs' [(Id, OutExpr)] -> [Id] -> [((Id, OutExpr), Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs')
do_pr :: (SimpleOptEnv, [(Id, OutExpr)])
-> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)])
do_pr (SimpleOptEnv
env, [(Id, OutExpr)]
prs) ((Id
b,OutExpr
r), Id
b')
= (SimpleOptEnv
env', case Maybe (Id, OutExpr)
mb_pr of
Just (Id, OutExpr)
pr -> (Id, OutExpr)
pr (Id, OutExpr) -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. a -> [a] -> [a]
: [(Id, OutExpr)]
prs
Maybe (Id, OutExpr)
Nothing -> [(Id, OutExpr)]
prs)
where
(SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
b') (SimpleOptEnv
env,OutExpr
r) TopLevelFlag
top_level
simple_bind_pair :: SimpleOptEnv
-> InVar -> Maybe OutVar
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_bind_pair :: SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair env :: SimpleOptEnv
env@(SOE { soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl_env, soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
Id
in_bndr Maybe Id
mb_out_bndr clo :: SimpleClo
clo@(SimpleOptEnv
rhs_env, OutExpr
in_rhs)
TopLevelFlag
top_level
| Type Type
ty <- OutExpr
in_rhs
, let out_ty :: Type
out_ty = Subst -> Type -> Type
substTy (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env) Type
ty
= Bool
-> SDoc
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isTyVar Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr SDoc -> SDoc -> SDoc
$$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
in_rhs) ((SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr)))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a b. (a -> b) -> a -> b
$
(SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Type -> Subst
extendTvSubst Subst
subst Id
in_bndr Type
out_ty }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
| Coercion Coercion
co <- OutExpr
in_rhs
, let out_co :: Coercion
out_co = OptCoercionOpts -> TCvSubst -> Coercion -> Coercion
optCoercion (SimpleOptEnv -> OptCoercionOpts
soe_co_opt_opts SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env)) Coercion
co
= Bool
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isCoVar Id
in_bndr)
(SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Coercion -> Subst
extendCvSubst Subst
subst Id
in_bndr Coercion
out_co }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
| Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isNonCoVarId Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr)
Bool
pre_inline_unconditionally
= (SimpleOptEnv
env { soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo -> Id -> SimpleClo -> IdEnv SimpleClo
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv SimpleClo
inl_env Id
in_bndr SimpleClo
clo }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
| Bool
otherwise
= SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr OutExpr
out_rhs
OccInfo
occ Bool
active Bool
stable_unf TopLevelFlag
top_level
where
stable_unf :: Bool
stable_unf = Unfolding -> Bool
isStableUnfolding (IdUnfoldingFun
idUnfolding Id
in_bndr)
active :: Bool
active = Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
in_bndr)
occ :: OccInfo
occ = Id -> OccInfo
idOccInfo Id
in_bndr
out_rhs :: OutExpr
out_rhs | Just BranchCount
join_arity <- Id -> Maybe BranchCount
isJoinId_maybe Id
in_bndr
= BranchCount -> OutExpr
simple_join_rhs BranchCount
join_arity
| Bool
otherwise
= SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
simple_join_rhs :: BranchCount -> OutExpr
simple_join_rhs BranchCount
join_arity
= [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
join_bndrs' (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env_body OutExpr
join_body)
where
env0 :: SimpleOptEnv
env0 = SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
rhs_env
([Id]
join_bndrs, OutExpr
join_body) = BranchCount -> OutExpr -> ([Id], OutExpr)
forall b. BranchCount -> Expr b -> ([b], Expr b)
collectNBinders BranchCount
join_arity OutExpr
in_rhs
(SimpleOptEnv
env_body, [Id]
join_bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env0 [Id]
join_bndrs
pre_inline_unconditionally :: Bool
pre_inline_unconditionally :: Bool
pre_inline_unconditionally
| Id -> Bool
isExportedId Id
in_bndr = Bool
False
| Bool
stable_unf = Bool
False
| Bool -> Bool
not Bool
active = Bool
False
| Bool -> Bool
not (OccInfo -> Bool
safe_to_inline OccInfo
occ) = Bool
False
| Bool
otherwise = Bool
True
safe_to_inline :: OccInfo -> Bool
safe_to_inline :: OccInfo -> Bool
safe_to_inline IAmALoopBreaker{} = Bool
False
safe_to_inline OccInfo
IAmDead = Bool
True
safe_to_inline OneOcc{ occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
NotInsideLam
, occ_n_br :: OccInfo -> BranchCount
occ_n_br = BranchCount
1 } = Bool
True
safe_to_inline OneOcc{} = Bool
False
safe_to_inline ManyOccs{} = Bool
False
simple_out_bind :: TopLevelFlag
-> SimpleOptEnv
-> (InVar, OutExpr)
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind :: TopLevelFlag
-> SimpleOptEnv
-> (Id, OutExpr)
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind TopLevelFlag
top_level env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) (Id
in_bndr, OutExpr
out_rhs)
| Type Type
out_ty <- OutExpr
out_rhs
= Bool
-> SDoc
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isTyVar Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
out_ty SDoc -> SDoc -> SDoc
$$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
out_rhs)
(SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Type -> Subst
extendTvSubst Subst
subst Id
in_bndr Type
out_ty }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
| Coercion Coercion
out_co <- OutExpr
out_rhs
= Bool
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isCoVar Id
in_bndr)
(SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Coercion -> Subst
extendCvSubst Subst
subst Id
in_bndr Coercion
out_co }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
| Bool
otherwise
= SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
forall a. Maybe a
Nothing OutExpr
out_rhs
(Id -> OccInfo
idOccInfo Id
in_bndr) Bool
True Bool
False TopLevelFlag
top_level
simple_out_bind_pair :: SimpleOptEnv
-> InId -> Maybe OutId -> OutExpr
-> OccInfo -> Bool -> Bool -> TopLevelFlag
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind_pair :: SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr OutExpr
out_rhs
OccInfo
occ_info Bool
active Bool
stable_unf TopLevelFlag
top_level
| Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isNonCoVarId Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr)
Bool
post_inline_unconditionally
= ( SimpleOptEnv
env' { soe_subst :: Subst
soe_subst = Subst -> Id -> OutExpr -> Subst
extendIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
in_bndr OutExpr
out_rhs }
, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
| Bool
otherwise
= ( SimpleOptEnv
env', (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
out_bndr, OutExpr
out_rhs) )
where
(SimpleOptEnv
env', Id
bndr1) = case Maybe Id
mb_out_bndr of
Just Id
out_bndr -> (SimpleOptEnv
env, Id
out_bndr)
Maybe Id
Nothing -> SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
in_bndr
out_bndr :: Id
out_bndr = SimpleOptEnv -> Id -> TopLevelFlag -> OutExpr -> Id -> Id
add_info SimpleOptEnv
env' Id
in_bndr TopLevelFlag
top_level OutExpr
out_rhs Id
bndr1
post_inline_unconditionally :: Bool
post_inline_unconditionally :: Bool
post_inline_unconditionally
| Id -> Bool
isExportedId Id
in_bndr = Bool
False
| Bool
stable_unf = Bool
False
| Bool -> Bool
not Bool
active = Bool
False
| Bool
is_loop_breaker = Bool
False
| OutExpr -> Bool
exprIsTrivial OutExpr
out_rhs = Bool
True
| Bool
coercible_hack = Bool
True
| Bool
otherwise = Bool
False
is_loop_breaker :: Bool
is_loop_breaker = OccInfo -> Bool
isWeakLoopBreaker OccInfo
occ_info
coercible_hack :: Bool
coercible_hack | (Var Id
fun, [OutExpr]
args) <- OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
out_rhs
, Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
, DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqDataConKey Bool -> Bool -> Bool
|| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleDataConKey
= (OutExpr -> Bool) -> [OutExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all OutExpr -> Bool
exprIsTrivial [OutExpr]
args
| Bool
otherwise
= Bool
False
subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
subst_opt_bndrs :: SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs = (SimpleOptEnv -> Id -> (SimpleOptEnv, Id))
-> SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env [Id]
bndrs
subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
subst_opt_bndr :: SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
bndr
| Id -> Bool
isTyVar Id
bndr = (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst
subst_tv }, Id
tv')
| Id -> Bool
isCoVar Id
bndr = (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst
subst_cv }, Id
cv')
| Bool
otherwise = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_id_bndr SimpleOptEnv
env Id
bndr
where
subst :: Subst
subst = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
(Subst
subst_tv, Id
tv') = Subst -> Id -> (Subst, Id)
substTyVarBndr Subst
subst Id
bndr
(Subst
subst_cv, Id
cv') = Subst -> Id -> (Subst, Id)
substCoVarBndr Subst
subst Id
bndr
subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
subst_opt_id_bndr :: SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_id_bndr env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst, soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl }) Id
old_id
= (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst
new_subst, soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
new_inl }, Id
new_id)
where
Subst InScopeSet
in_scope IdSubstEnv
id_subst TvSubstEnv
tv_subst CvSubstEnv
cv_subst = Subst
subst
id1 :: Id
id1 = InScopeSet -> Id -> Id
uniqAway InScopeSet
in_scope Id
old_id
id2 :: Id
id2 = (Type -> Type) -> Id -> Id
updateIdTypeAndMult (Subst -> Type -> Type
substTy Subst
subst) Id
id1
new_id :: Id
new_id = Id -> Id
zapFragileIdInfo Id
id2
new_in_scope :: InScopeSet
new_in_scope = InScopeSet
in_scope InScopeSet -> Id -> InScopeSet
`extendInScopeSet` Id
new_id
no_change :: Bool
no_change = Id
new_id Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
old_id
new_id_subst :: IdSubstEnv
new_id_subst
| Bool
no_change = IdSubstEnv -> Id -> IdSubstEnv
forall a. VarEnv a -> Id -> VarEnv a
delVarEnv IdSubstEnv
id_subst Id
old_id
| Bool
otherwise = IdSubstEnv -> Id -> OutExpr -> IdSubstEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdSubstEnv
id_subst Id
old_id (Id -> OutExpr
forall b. Id -> Expr b
Var Id
new_id)
new_subst :: Subst
new_subst = InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst
Subst InScopeSet
new_in_scope IdSubstEnv
new_id_subst TvSubstEnv
tv_subst CvSubstEnv
cv_subst
new_inl :: IdEnv SimpleClo
new_inl = IdEnv SimpleClo -> Id -> IdEnv SimpleClo
forall a. VarEnv a -> Id -> VarEnv a
delVarEnv IdEnv SimpleClo
inl Id
old_id
add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar
add_info :: SimpleOptEnv -> Id -> TopLevelFlag -> OutExpr -> Id -> Id
add_info SimpleOptEnv
env Id
old_bndr TopLevelFlag
top_level OutExpr
new_rhs Id
new_bndr
| Id -> Bool
isTyVar Id
old_bndr = Id
new_bndr
| Bool
otherwise = Id -> IdInfo -> Id
lazySetIdInfo Id
new_bndr IdInfo
new_info
where
subst :: Subst
subst = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
uf_opts :: UnfoldingOpts
uf_opts = SimpleOptEnv -> UnfoldingOpts
soe_uf_opts SimpleOptEnv
env
old_info :: IdInfo
old_info = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
old_bndr
new_info :: IdInfo
new_info = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
new_bndr IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` RuleInfo
new_rules
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unfolding
old_rules :: RuleInfo
old_rules = IdInfo -> RuleInfo
ruleInfo IdInfo
old_info
new_rules :: RuleInfo
new_rules = Subst -> Id -> RuleInfo -> RuleInfo
substRuleInfo Subst
subst Id
new_bndr RuleInfo
old_rules
old_unfolding :: Unfolding
old_unfolding = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
old_info
new_unfolding :: Unfolding
new_unfolding | Unfolding -> Bool
isStableUnfolding Unfolding
old_unfolding
= Subst -> Unfolding -> Unfolding
substUnfolding Subst
subst Unfolding
old_unfolding
| Bool
otherwise
= Unfolding
unfolding_from_rhs
unfolding_from_rhs :: Unfolding
unfolding_from_rhs = UnfoldingOpts
-> UnfoldingSource
-> Bool
-> Bool
-> OutExpr
-> Maybe UnfoldingCache
-> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
InlineRhs
(TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_level)
Bool
False
OutExpr
new_rhs Maybe UnfoldingCache
forall a. Maybe a
Nothing
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun Id
id
| Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
id) = IdUnfoldingFun
idUnfolding Id
id
| Bool
otherwise = Unfolding
noUnfolding
wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet :: Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet Maybe (Id, OutExpr)
Nothing OutExpr
body = OutExpr
body
wrapLet (Just (Id
b,OutExpr
r)) OutExpr
body = InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r) OutExpr
body
joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
joinPointBinding_maybe :: Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe Id
bndr OutExpr
rhs
| Bool -> Bool
not (Id -> Bool
isId Id
bndr)
= Maybe (Id, OutExpr)
forall a. Maybe a
Nothing
| Id -> Bool
isJoinId Id
bndr
= (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
bndr, OutExpr
rhs)
| AlwaysTailCalled BranchCount
join_arity <- OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)
, ([Id]
bndrs, OutExpr
body) <- BranchCount -> OutExpr -> ([Id], OutExpr)
etaExpandToJoinPoint BranchCount
join_arity OutExpr
rhs
, let str_sig :: DmdSig
str_sig = Id -> DmdSig
idDmdSig Id
bndr
str_arity :: BranchCount
str_arity = (Id -> Bool) -> [Id] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count Id -> Bool
isId [Id]
bndrs
join_bndr :: Id
join_bndr = Id
bndr Id -> BranchCount -> Id
`asJoinId` BranchCount
join_arity
Id -> DmdSig -> Id
`setIdDmdSig` BranchCount -> DmdSig -> DmdSig
etaConvertDmdSig BranchCount
str_arity DmdSig
str_sig
= (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
join_bndr, [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs OutExpr
body)
| Bool
otherwise
= Maybe (Id, OutExpr)
forall a. Maybe a
Nothing
joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
joinPointBindings_maybe :: [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
joinPointBindings_maybe [(Id, OutExpr)]
bndrs
= ((Id, OutExpr) -> Maybe (Id, OutExpr))
-> [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Id -> OutExpr -> Maybe (Id, OutExpr))
-> (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe) [(Id, OutExpr)]
bndrs
data ConCont = CC [CoreExpr] Coercion
exprIsConApp_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe :: (() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
exprIsConApp_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) OutExpr
expr
= Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [] OutExpr
expr ([OutExpr] -> Coercion -> ConCont
CC [] (Type -> Coercion
mkRepReflCo ((() :: Constraint) => OutExpr -> Type
OutExpr -> Type
exprType OutExpr
expr)))
where
go :: Either InScopeSet Subst
-> [FloatBind] -> CoreExpr -> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go :: Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats (Tick CoreTickish
t OutExpr
expr) ConCont
cont
| Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ConCont
cont
go Either InScopeSet Subst
subst [FloatBind]
floats (Cast OutExpr
expr Coercion
co1) (CC [OutExpr]
args Coercion
co2)
| Just ([OutExpr]
args', MCoercion
m_co1') <- Coercion -> [OutExpr] -> Maybe ([OutExpr], MCoercion)
pushCoArgs (Either InScopeSet Subst -> Coercion -> Coercion
forall {a}. Either a Subst -> Coercion -> Coercion
subst_co Either InScopeSet Subst
subst Coercion
co1) [OutExpr]
args
= case MCoercion
m_co1' of
MCo Coercion
co1' -> Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args' (Coercion
co1' Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2))
MCoercion
MRefl -> Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args' Coercion
co2)
go Either InScopeSet Subst
subst [FloatBind]
floats (App OutExpr
fun OutExpr
arg) (CC [OutExpr]
args Coercion
co)
= Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
fun ([OutExpr] -> Coercion -> ConCont
CC (Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
arg OutExpr -> [OutExpr] -> [OutExpr]
forall a. a -> [a] -> [a]
: [OutExpr]
args) Coercion
co)
go Either InScopeSet Subst
subst [FloatBind]
floats (Lam Id
bndr OutExpr
body) (CC (OutExpr
arg:[OutExpr]
args) Coercion
co)
| OutExpr -> Bool
exprIsTrivial OutExpr
arg
= Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (Either InScopeSet Subst -> Id -> OutExpr -> Either InScopeSet Subst
forall {a}.
Either InScopeSet Subst -> Id -> OutExpr -> Either a Subst
extend Either InScopeSet Subst
subst Id
bndr OutExpr
arg) [FloatBind]
floats OutExpr
body ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args Coercion
co)
| Bool
otherwise
= let (Either InScopeSet Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
bndr
float :: FloatBind
float = InBind -> FloatBind
FloatLet (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' OutExpr
arg)
in Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
body ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args Coercion
co)
go Either InScopeSet Subst
subst [FloatBind]
floats (Let (NonRec Id
bndr OutExpr
rhs) OutExpr
expr) ConCont
cont
| Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)
= let rhs' :: OutExpr
rhs' = Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
rhs
(Either InScopeSet Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
bndr
float :: FloatBind
float = InBind -> FloatBind
FloatLet (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' OutExpr
rhs')
in Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
expr ConCont
cont
go Either InScopeSet Subst
subst [FloatBind]
floats (Case OutExpr
scrut Id
b Type
_ [Alt AltCon
con [Id]
vars OutExpr
expr]) ConCont
cont
= let
scrut' :: OutExpr
scrut' = Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
scrut
(Either InScopeSet Subst
subst', Id
b') = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
b
(Either InScopeSet Subst
subst'', [Id]
vars') = Either InScopeSet Subst -> [Id] -> (Either InScopeSet Subst, [Id])
forall {t :: * -> *}.
Traversable t =>
Either InScopeSet Subst -> t Id -> (Either InScopeSet Subst, t Id)
subst_bndrs Either InScopeSet Subst
subst' [Id]
vars
float :: FloatBind
float = OutExpr -> Id -> AltCon -> [Id] -> FloatBind
FloatCase OutExpr
scrut' Id
b' AltCon
con [Id]
vars'
in
Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst'' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
expr ConCont
cont
go (Right Subst
sub) [FloatBind]
floats (Var Id
v) ConCont
cont
= Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left (Subst -> InScopeSet
substInScope Subst
sub))
[FloatBind]
floats
((() :: Constraint) => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst Subst
sub Id
v)
ConCont
cont
go (Left InScopeSet
in_scope) [FloatBind]
floats (Var Id
fun) cont :: ConCont
cont@(CC [OutExpr]
args Coercion
co)
| Just DataCon
con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
, (OutExpr -> Bool) -> [OutExpr] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count OutExpr -> Bool
forall b. Expr b -> Bool
isValArg [OutExpr]
args BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> BranchCount
idArity Id
fun
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
con [OutExpr]
args Coercion
co
| Id -> Bool
isDataConWrapId Id
fun
, let rhs :: OutExpr
rhs = Unfolding -> OutExpr
uf_tmpl (IdUnfoldingFun
realIdUnfolding Id
fun)
= Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [FloatBind]
floats OutExpr
rhs ConCont
cont
| DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [OutExpr]
df_args = [OutExpr]
dfun_args } <- Unfolding
unfolding
, [Id]
bndrs [Id] -> [OutExpr] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [OutExpr]
args
, let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope ([OutExpr] -> VarSet
exprsFreeVars [OutExpr]
dfun_args)
subst :: Subst
subst = InScopeSet -> [(Id, OutExpr)] -> Subst
mkOpenSubst InScopeSet
in_scope' ([Id]
bndrs [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [OutExpr]
args)
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
con ((OutExpr -> OutExpr) -> [OutExpr] -> [OutExpr]
forall a b. (a -> b) -> [a] -> [b]
map ((() :: Constraint) => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
substExpr Subst
subst) [OutExpr]
dfun_args) Coercion
co
| Id -> BranchCount
idArity Id
fun BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== BranchCount
0
, Just OutExpr
rhs <- Unfolding -> Maybe OutExpr
expandUnfolding_maybe Unfolding
unfolding
, let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope (OutExpr -> VarSet
exprFreeVars OutExpr
rhs)
= Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope') [FloatBind]
floats OutExpr
rhs ConCont
cont
| (Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey) Bool -> Bool -> Bool
||
(Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringUtf8IdKey)
, [OutExpr
arg] <- [OutExpr]
args
, Just (LitString ByteString
str) <- (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) OutExpr
arg
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
dealWithStringLiteral Id
fun ByteString
str Coercion
co
where
unfolding :: Unfolding
unfolding = IdUnfoldingFun
id_unf Id
fun
extend_in_scope :: VarSet -> InScopeSet
extend_in_scope VarSet
unf_fvs
| Id -> Bool
isLocalId Id
fun = InScopeSet
in_scope InScopeSet -> VarSet -> InScopeSet
`extendInScopeSetSet` VarSet
unf_fvs
| Bool
otherwise = InScopeSet
in_scope
go Either InScopeSet Subst
_ [FloatBind]
_ OutExpr
_ ConCont
_ = Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a. Maybe a
Nothing
succeedWith :: InScopeSet -> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith :: InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
rev_floats Maybe (DataCon, [Type], [OutExpr])
x
= do { (DataCon
con, [Type]
tys, [OutExpr]
args) <- Maybe (DataCon, [Type], [OutExpr])
x
; let floats :: [FloatBind]
floats = [FloatBind] -> [FloatBind]
forall a. [a] -> [a]
reverse [FloatBind]
rev_floats
; (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (InScopeSet
in_scope, [FloatBind]
floats, DataCon
con, [Type]
tys, [OutExpr]
args) }
subst_co :: Either a Subst -> Coercion -> Coercion
subst_co (Left {}) Coercion
co = Coercion
co
subst_co (Right Subst
s) Coercion
co = HasCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
GHC.Core.Subst.substCo Subst
s Coercion
co
subst_expr :: Either a Subst -> OutExpr -> OutExpr
subst_expr (Left {}) OutExpr
e = OutExpr
e
subst_expr (Right Subst
s) OutExpr
e = (() :: Constraint) => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
substExpr Subst
s OutExpr
e
subst_bndr :: Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
msubst Id
bndr
= (Subst -> Either a Subst
forall a b. b -> Either a b
Right Subst
subst', Id
bndr')
where
(Subst
subst', Id
bndr') = Subst -> Id -> (Subst, Id)
substBndr Subst
subst Id
bndr
subst :: Subst
subst = case Either InScopeSet Subst
msubst of
Left InScopeSet
in_scope -> InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
Right Subst
subst -> Subst
subst
subst_bndrs :: Either InScopeSet Subst -> t Id -> (Either InScopeSet Subst, t Id)
subst_bndrs Either InScopeSet Subst
subst t Id
bs = (Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id))
-> Either InScopeSet Subst
-> t Id
-> (Either InScopeSet Subst, t Id)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst t Id
bs
extend :: Either InScopeSet Subst -> Id -> OutExpr -> Either a Subst
extend (Left InScopeSet
in_scope) Id
v OutExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> OutExpr -> Subst
extendSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) Id
v OutExpr
e)
extend (Right Subst
s) Id
v OutExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> OutExpr -> Subst
extendSubst Subst
s Id
v OutExpr
e)
dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
-> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral :: Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
dealWithStringLiteral Id
fun ByteString
str Coercion
co =
case ByteString -> Maybe (Char, ByteString)
utf8UnconsByteString ByteString
str of
Maybe (Char, ByteString)
Nothing -> DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
nilDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy] Coercion
co
Just (Char
char, ByteString
charTail) ->
let char_expr :: OutExpr
char_expr = DataCon -> [OutExpr] -> OutExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
charDataCon [Char -> OutExpr
forall b. Char -> Expr b
mkCharLit Char
char]
rest :: OutExpr
rest = if ByteString -> Bool
BS.null ByteString
charTail
then DataCon -> [OutExpr] -> OutExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
nilDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy]
else OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> OutExpr
forall b. Id -> Expr b
Var Id
fun)
(Literal -> OutExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
charTail))
in DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
consDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy, OutExpr
char_expr, OutExpr
rest] Coercion
co
exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe :: (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe env :: (InScopeSet, IdUnfoldingFun)
env@(InScopeSet
_, IdUnfoldingFun
id_unf) OutExpr
e
= case OutExpr
e of
Lit Literal
l -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
Tick CoreTickish
_ OutExpr
e' -> (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env OutExpr
e'
Var Id
v -> Unfolding -> Maybe OutExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
v)
Maybe OutExpr -> (OutExpr -> Maybe Literal) -> Maybe Literal
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env
OutExpr
_ -> Maybe Literal
forall a. Maybe a
Nothing
exprIsLambda_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (Var, CoreExpr,[CoreTickish])
exprIsLambda_maybe :: (() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ (Lam Id
x OutExpr
e)
= (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, OutExpr
e, [])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Tick CoreTickish
t OutExpr
e)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
, Just (Id
x, OutExpr
e, [CoreTickish]
ts) <- (InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
e
= (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, OutExpr
e, CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts)
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Cast OutExpr
casted_e Coercion
co)
| Just (Id
x, OutExpr
e,[CoreTickish]
ts) <- (InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
casted_e
, Bool -> Bool
not (Id -> Bool
isTyVar Id
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isCoVar Id
x)
, Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id
x Id -> VarSet -> Bool
`elemVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co) Bool
True
, Just (Id
x',OutExpr
e') <- (() :: Constraint) =>
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
pushCoercionIntoLambda InScopeSet
in_scope_set Id
x OutExpr
e Coercion
co
, let res :: Maybe (Id, OutExpr, [CoreTickish])
res = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x',OutExpr
e',[CoreTickish]
ts)
=
Maybe (Id, OutExpr, [CoreTickish])
res
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
e
| (Var Id
f, [OutExpr]
as, [CoreTickish]
ts) <- (CoreTickish -> Bool)
-> OutExpr -> (OutExpr, [OutExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable OutExpr
e
, Id -> BranchCount
idArity Id
f BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
> (OutExpr -> Bool) -> [OutExpr] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count OutExpr -> Bool
forall b. Expr b -> Bool
isValArg [OutExpr]
as
, Just OutExpr
rhs <- Unfolding -> Maybe OutExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
f)
, let e' :: OutExpr
e' = (() :: Constraint) => SimpleOpts -> Subst -> OutExpr -> OutExpr
SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
defaultSimpleOpts (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope_set) (OutExpr
rhs OutExpr -> [OutExpr] -> OutExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [OutExpr]
as)
, Just (Id
x', OutExpr
e'', [CoreTickish]
ts') <- (InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
e'
, let res :: Maybe (Id, OutExpr, [CoreTickish])
res = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x', OutExpr
e'', [CoreTickish]
ts[CoreTickish] -> [CoreTickish] -> [CoreTickish]
forall a. [a] -> [a] -> [a]
++[CoreTickish]
ts')
=
Maybe (Id, OutExpr, [CoreTickish])
res
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ OutExpr
_e
=
Maybe (Id, OutExpr, [CoreTickish])
forall a. Maybe a
Nothing