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 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 :: UnfoldingOpts -> OptCoercionOpts -> SimpleOpts
SimpleOpts
{ so_uf_opts :: UnfoldingOpts
so_uf_opts = UnfoldingOpts
defaultUnfoldingOpts
, so_co_opts :: OptCoercionOpts
so_co_opts = OptCoercionOpts :: Bool -> OptCoercionOpts
OptCoercionOpts
{ optCoercionEnabled :: Bool
optCoercionEnabled = Bool
False }
}
simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr :: SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts CoreExpr
expr
=
HasDebugCallStack => SimpleOpts -> Subst -> CoreExpr -> CoreExpr
SimpleOpts -> Subst -> CoreExpr -> CoreExpr
simpleOptExprWith SimpleOpts
opts Subst
init_subst CoreExpr
expr
where
init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet (CoreExpr -> VarSet
exprFreeVars CoreExpr
expr))
simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
simpleOptExprWith :: SimpleOpts -> Subst -> CoreExpr -> CoreExpr
simpleOptExprWith SimpleOpts
opts Subst
subst CoreExpr
expr
= HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
init_env (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
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 (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
}
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 :: OptCoercionOpts
-> UnfoldingOpts -> IdEnv SimpleClo -> Subst -> SimpleOptEnv
SOE
{ soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv
, soe_subst :: Subst
soe_subst = Subst
emptySubst
, 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) }
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> CoreExpr
simple_opt_clo SimpleOptEnv
env (SimpleOptEnv
e_env, CoreExpr
e)
= HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
e_env) CoreExpr
e
simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr :: SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env CoreExpr
expr
= CoreExpr -> CoreExpr
go CoreExpr
expr
where
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 :: CoreExpr -> CoreExpr
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 -> CoreExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
| Bool
otherwise
= HasDebugCallStack => Subst -> Id -> CoreExpr
Subst -> Id -> CoreExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
go (App CoreExpr
e1 CoreExpr
e2) = HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env CoreExpr
e1 [(SimpleOptEnv
env,CoreExpr
e2)]
go (Type Type
ty) = Type -> CoreExpr
forall b. Type -> Expr b
Type (Subst -> Type -> Type
substTy Subst
subst Type
ty)
go (Coercion Coercion
co) = Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> Coercion
go_co Coercion
co)
go (Lit Literal
lit) = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit
go (Tick CoreTickish
tickish CoreExpr
e) = CoreTickish -> CoreExpr -> CoreExpr
mkTick (Subst -> CoreTickish -> CoreTickish
substTickish Subst
subst CoreTickish
tickish) (CoreExpr -> CoreExpr
go CoreExpr
e)
go (Cast CoreExpr
e Coercion
co) = CoreExpr -> Coercion -> CoreExpr
mk_cast (CoreExpr -> CoreExpr
go CoreExpr
e) (Coercion -> Coercion
go_co Coercion
co)
go (Let InBind
bind CoreExpr
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 -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
body
(SimpleOptEnv
env', Just InBind
bind) -> InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
body)
go lam :: CoreExpr
lam@(Lam {}) = SimpleOptEnv -> [Id] -> CoreExpr -> CoreExpr
go_lam SimpleOptEnv
env [] CoreExpr
lam
go (Case CoreExpr
e Id
b Type
ty [Alt Id]
as)
| Id -> Bool
isDeadBinder Id
b
, Just (InScopeSet
_, [], DataCon
con, [Type]
_tys, [CoreExpr]
es) <- (InScopeSet, IdUnfoldingFun)
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
HasDebugCallStack =>
(InScopeSet, IdUnfoldingFun)
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (InScopeSet, IdUnfoldingFun)
in_scope_env CoreExpr
e'
, Just (Alt AltCon
altcon [Id]
bs CoreExpr
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 -> CoreExpr -> CoreExpr
go CoreExpr
rhs
AltCon
_ -> (Maybe (Id, CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Maybe (Id, CoreExpr)] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe (Id, CoreExpr) -> CoreExpr -> CoreExpr
wrapLet (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
rhs) [Maybe (Id, CoreExpr)]
mb_prs
where
(SimpleOptEnv
env', [Maybe (Id, CoreExpr)]
mb_prs) = (SimpleOptEnv
-> (Id, CoreExpr) -> (SimpleOptEnv, Maybe (Id, CoreExpr)))
-> SimpleOptEnv
-> [(Id, CoreExpr)]
-> (SimpleOptEnv, [Maybe (Id, CoreExpr)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (TopLevelFlag
-> SimpleOptEnv
-> (Id, CoreExpr)
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind TopLevelFlag
NotTopLevel) SimpleOptEnv
env ([(Id, CoreExpr)] -> (SimpleOptEnv, [Maybe (Id, CoreExpr)]))
-> [(Id, CoreExpr)] -> (SimpleOptEnv, [Maybe (Id, CoreExpr)])
forall a b. (a -> b) -> a -> b
$
String -> [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"simpleOptExpr" [Id]
bs [CoreExpr]
es
| Id -> Bool
isDeadBinder Id
b
, [Alt AltCon
DEFAULT [Id]
_ CoreExpr
rhs] <- [Alt Id]
as
, Type -> Bool
isCoVarType (Id -> Type
varType Id
b)
, (Var Id
fun, [CoreExpr]
_args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e
, Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleSCSelIdKey
= CoreExpr -> CoreExpr
go CoreExpr
rhs
| Bool
otherwise
= CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
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' :: CoreExpr
e' = CoreExpr -> CoreExpr
go CoreExpr
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 CoreExpr
rhs)
= AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndrs' (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
rhs)
where
(SimpleOptEnv
env', [Id]
bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs
go_lam :: SimpleOptEnv -> [Id] -> CoreExpr -> CoreExpr
go_lam SimpleOptEnv
env [Id]
bs' (Lam Id
b CoreExpr
e)
= SimpleOptEnv -> [Id] -> CoreExpr -> CoreExpr
go_lam SimpleOptEnv
env' (Id
b'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs') CoreExpr
e
where
(SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
go_lam SimpleOptEnv
env [Id]
bs' CoreExpr
e
| Just CoreExpr
etad_e <- [Id] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce [Id]
bs CoreExpr
e' = CoreExpr
etad_e
| Bool
otherwise = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bs CoreExpr
e'
where
bs :: [Id]
bs = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs'
e' :: CoreExpr
e' = HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env CoreExpr
e
mk_cast :: CoreExpr -> CoercionR -> CoreExpr
mk_cast :: CoreExpr -> Coercion -> CoreExpr
mk_cast (Cast CoreExpr
e Coercion
co1) Coercion
co2 = CoreExpr -> Coercion -> CoreExpr
mk_cast CoreExpr
e (Coercion
co1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2)
mk_cast (Tick CoreTickish
t CoreExpr
e) Coercion
co = CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (CoreExpr -> Coercion -> CoreExpr
mk_cast CoreExpr
e Coercion
co)
mk_cast CoreExpr
e Coercion
co | Coercion -> Bool
isReflexiveCo Coercion
co = CoreExpr
e
| Bool
otherwise = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co
simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
simple_app :: SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env (Var Id
v) [SimpleClo]
as
| Just (SimpleOptEnv
env', CoreExpr
e) <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
= HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
env') CoreExpr
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)
= HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app (SimpleOptEnv -> SimpleOptEnv
soeZapSubst SimpleOptEnv
env) (Unfolding -> CoreExpr
unfoldingTemplate Unfolding
unf) [SimpleClo]
as
| Bool
otherwise
, let out_fn :: CoreExpr
out_fn = HasDebugCallStack => Subst -> Id -> CoreExpr
Subst -> Id -> CoreExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
= SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env CoreExpr
out_fn [SimpleClo]
as
simple_app SimpleOptEnv
env (App CoreExpr
e1 CoreExpr
e2) [SimpleClo]
as
= HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env CoreExpr
e1 ((SimpleOptEnv
env, CoreExpr
e2) SimpleClo -> [SimpleClo] -> [SimpleClo]
forall a. a -> [a] -> [a]
: [SimpleClo]
as)
simple_app SimpleOptEnv
env e :: CoreExpr
e@(Lam {}) as :: [SimpleClo]
as@(SimpleClo
_:[SimpleClo]
_)
= SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
do_beta SimpleOptEnv
env (CoreExpr -> FullArgCount -> CoreExpr
zapLambdaBndrs CoreExpr
e FullArgCount
n_args) [SimpleClo]
as
where
n_args :: FullArgCount
n_args = [SimpleClo] -> FullArgCount
forall (t :: * -> *) a. Foldable t => t a -> FullArgCount
length [SimpleClo]
as
do_beta :: SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
do_beta SimpleOptEnv
env (Lam Id
b CoreExpr
body) (SimpleClo
a:[SimpleClo]
as)
| (SimpleOptEnv
env', Maybe (Id, CoreExpr)
mb_pr) <- SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_bind_pair SimpleOptEnv
env Id
b Maybe Id
forall a. Maybe a
Nothing SimpleClo
a TopLevelFlag
NotTopLevel
= Maybe (Id, CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Maybe (Id, CoreExpr)
mb_pr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
do_beta SimpleOptEnv
env' CoreExpr
body [SimpleClo]
as
do_beta SimpleOptEnv
env CoreExpr
body [SimpleClo]
as
= HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env CoreExpr
body [SimpleClo]
as
simple_app SimpleOptEnv
env (Tick CoreTickish
t CoreExpr
e) [SimpleClo]
as
| CoreTickish
t CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env CoreExpr
e [SimpleClo]
as
simple_app SimpleOptEnv
env (Let InBind
bind CoreExpr
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) -> HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env' CoreExpr
body [SimpleClo]
args
(SimpleOptEnv
env', Just InBind
bind')
| InBind -> Bool
isJoinBind InBind
bind' -> SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env CoreExpr
expr' [SimpleClo]
args
| Bool
otherwise -> InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasDebugCallStack =>
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env' CoreExpr
body [SimpleClo]
args)
where
expr' :: CoreExpr
expr' = InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
body)
simple_app SimpleOptEnv
env CoreExpr
e [SimpleClo]
as
= SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env CoreExpr
e) [SimpleClo]
as
finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app :: SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
_ CoreExpr
fun []
= CoreExpr
fun
finish_app SimpleOptEnv
env CoreExpr
fun (SimpleClo
arg:[SimpleClo]
args)
= SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (SimpleOptEnv -> SimpleClo -> CoreExpr
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 CoreExpr
r) TopLevelFlag
top_level
= (SimpleOptEnv
env', case Maybe (Id, CoreExpr)
mb_pr of
Maybe (Id, CoreExpr)
Nothing -> Maybe InBind
forall a. Maybe a
Nothing
Just (Id
b,CoreExpr
r) -> InBind -> Maybe InBind
forall a. a -> Maybe a
Just (Id -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
r))
where
(Id
b', CoreExpr
r') = Id -> CoreExpr -> Maybe (Id, CoreExpr)
joinPointBinding_maybe Id
b CoreExpr
r Maybe (Id, CoreExpr) -> (Id, CoreExpr) -> (Id, CoreExpr)
forall a. Maybe a -> a -> a
`orElse` (Id
b, CoreExpr
r)
(SimpleOptEnv
env', Maybe (Id, CoreExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_bind_pair SimpleOptEnv
env Id
b' Maybe Id
forall a. Maybe a
Nothing (SimpleOptEnv
env,CoreExpr
r') TopLevelFlag
top_level
simple_opt_bind SimpleOptEnv
env (Rec [(Id, CoreExpr)]
prs) TopLevelFlag
top_level
= (SimpleOptEnv
env'', Maybe InBind
res_bind)
where
res_bind :: Maybe InBind
res_bind = InBind -> Maybe InBind
forall a. a -> Maybe a
Just ([(Id, CoreExpr)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a]
reverse [(Id, CoreExpr)]
rev_prs'))
prs' :: [(Id, CoreExpr)]
prs' = [(Id, CoreExpr)] -> Maybe [(Id, CoreExpr)]
joinPointBindings_maybe [(Id, CoreExpr)]
prs Maybe [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Maybe a -> a -> a
`orElse` [(Id, CoreExpr)]
prs
(SimpleOptEnv
env', [Id]
bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
prs')
(SimpleOptEnv
env'', [(Id, CoreExpr)]
rev_prs') = ((SimpleOptEnv, [(Id, CoreExpr)])
-> ((Id, CoreExpr), Id) -> (SimpleOptEnv, [(Id, CoreExpr)]))
-> (SimpleOptEnv, [(Id, CoreExpr)])
-> [((Id, CoreExpr), Id)]
-> (SimpleOptEnv, [(Id, CoreExpr)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, [(Id, CoreExpr)])
-> ((Id, CoreExpr), Id) -> (SimpleOptEnv, [(Id, CoreExpr)])
do_pr (SimpleOptEnv
env', []) ([(Id, CoreExpr)]
prs' [(Id, CoreExpr)] -> [Id] -> [((Id, CoreExpr), Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs')
do_pr :: (SimpleOptEnv, [(Id, CoreExpr)])
-> ((Id, CoreExpr), Id) -> (SimpleOptEnv, [(Id, CoreExpr)])
do_pr (SimpleOptEnv
env, [(Id, CoreExpr)]
prs) ((Id
b,CoreExpr
r), Id
b')
= (SimpleOptEnv
env', case Maybe (Id, CoreExpr)
mb_pr of
Just (Id, CoreExpr)
pr -> (Id, CoreExpr)
pr (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
prs
Maybe (Id, CoreExpr)
Nothing -> [(Id, CoreExpr)]
prs)
where
(SimpleOptEnv
env', Maybe (Id, CoreExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_bind_pair SimpleOptEnv
env Id
b (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
b') (SimpleOptEnv
env,CoreExpr
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, CoreExpr))
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, CoreExpr
in_rhs)
TopLevelFlag
top_level
| Type Type
ty <- CoreExpr
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, CoreExpr))
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
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
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
in_rhs) ((SimpleOptEnv, Maybe (Id, CoreExpr))
-> (SimpleOptEnv, Maybe (Id, CoreExpr)))
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
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, CoreExpr)
forall a. Maybe a
Nothing)
| Coercion Coercion
co <- CoreExpr
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, CoreExpr))
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
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, CoreExpr)
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, CoreExpr)
forall a. Maybe a
Nothing)
| Bool
otherwise
= SimpleOptEnv
-> Id
-> Maybe Id
-> CoreExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr CoreExpr
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 :: CoreExpr
out_rhs | Just FullArgCount
join_arity <- Id -> Maybe FullArgCount
isJoinId_maybe Id
in_bndr
= FullArgCount -> CoreExpr
simple_join_rhs FullArgCount
join_arity
| Bool
otherwise
= SimpleOptEnv -> SimpleClo -> CoreExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
simple_join_rhs :: FullArgCount -> CoreExpr
simple_join_rhs FullArgCount
join_arity
= [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
join_bndrs' (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env_body CoreExpr
join_body)
where
env0 :: SimpleOptEnv
env0 = SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
rhs_env
([Id]
join_bndrs, CoreExpr
join_body) = FullArgCount -> CoreExpr -> ([Id], CoreExpr)
forall b. FullArgCount -> Expr b -> ([b], Expr b)
collectNBinders FullArgCount
join_arity CoreExpr
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 -> FullArgCount
occ_n_br = FullArgCount
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, CoreExpr)
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind TopLevelFlag
top_level env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) (Id
in_bndr, CoreExpr
out_rhs)
| Type Type
out_ty <- CoreExpr
out_rhs
= Bool
-> SDoc
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
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
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
out_rhs)
(SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Type -> Subst
extendTvSubst Subst
subst Id
in_bndr Type
out_ty }, Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing)
| Coercion Coercion
out_co <- CoreExpr
out_rhs
= Bool
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
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, CoreExpr)
forall a. Maybe a
Nothing)
| Bool
otherwise
= SimpleOptEnv
-> Id
-> Maybe Id
-> CoreExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
forall a. Maybe a
Nothing CoreExpr
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
-> CoreExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr CoreExpr
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 -> CoreExpr -> Subst
extendIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
in_bndr CoreExpr
out_rhs }
, Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing)
| Bool
otherwise
= ( SimpleOptEnv
env', (Id, CoreExpr) -> Maybe (Id, CoreExpr)
forall a. a -> Maybe a
Just (Id
out_bndr, CoreExpr
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 -> CoreExpr -> Id -> Id
add_info SimpleOptEnv
env' Id
in_bndr TopLevelFlag
top_level CoreExpr
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
| CoreExpr -> Bool
exprIsTrivial CoreExpr
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, [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
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
= (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreExpr -> Bool
exprIsTrivial [CoreExpr]
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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 -> CoreExpr -> IdSubstEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdSubstEnv
id_subst Id
old_id (Id -> CoreExpr
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 -> CoreExpr -> Id -> Id
add_info SimpleOptEnv
env Id
old_bndr TopLevelFlag
top_level CoreExpr
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 = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
old_bndr
new_info :: IdInfo
new_info = HasDebugCallStack => 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 -> CoreExpr -> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
InlineRhs
(TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_level)
Bool
False
CoreExpr
new_rhs
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, CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Maybe (Id, CoreExpr)
Nothing CoreExpr
body = CoreExpr
body
wrapLet (Just (Id
b,CoreExpr
r)) CoreExpr
body = InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
r) CoreExpr
body
joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
joinPointBinding_maybe :: Id -> CoreExpr -> Maybe (Id, CoreExpr)
joinPointBinding_maybe Id
bndr CoreExpr
rhs
| Bool -> Bool
not (Id -> Bool
isId Id
bndr)
= Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing
| Id -> Bool
isJoinId Id
bndr
= (Id, CoreExpr) -> Maybe (Id, CoreExpr)
forall a. a -> Maybe a
Just (Id
bndr, CoreExpr
rhs)
| AlwaysTailCalled FullArgCount
join_arity <- OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)
, ([Id]
bndrs, CoreExpr
body) <- FullArgCount -> CoreExpr -> ([Id], CoreExpr)
etaExpandToJoinPoint FullArgCount
join_arity CoreExpr
rhs
, let str_sig :: DmdSig
str_sig = Id -> DmdSig
idDmdSig Id
bndr
str_arity :: FullArgCount
str_arity = (Id -> Bool) -> [Id] -> FullArgCount
forall a. (a -> Bool) -> [a] -> FullArgCount
count Id -> Bool
isId [Id]
bndrs
join_bndr :: Id
join_bndr = Id
bndr Id -> FullArgCount -> Id
`asJoinId` FullArgCount
join_arity
Id -> DmdSig -> Id
`setIdDmdSig` FullArgCount -> DmdSig -> DmdSig
etaConvertDmdSig FullArgCount
str_arity DmdSig
str_sig
= (Id, CoreExpr) -> Maybe (Id, CoreExpr)
forall a. a -> Maybe a
Just (Id
join_bndr, [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs CoreExpr
body)
| Bool
otherwise
= Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing
joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
joinPointBindings_maybe :: [(Id, CoreExpr)] -> Maybe [(Id, CoreExpr)]
joinPointBindings_maybe [(Id, CoreExpr)]
bndrs
= ((Id, CoreExpr) -> Maybe (Id, CoreExpr))
-> [(Id, CoreExpr)] -> Maybe [(Id, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Id -> CoreExpr -> Maybe (Id, CoreExpr))
-> (Id, CoreExpr) -> Maybe (Id, CoreExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> CoreExpr -> Maybe (Id, CoreExpr)
joinPointBinding_maybe) [(Id, CoreExpr)]
bndrs
data ConCont = CC [CoreExpr] Coercion
exprIsConApp_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe :: (InScopeSet, IdUnfoldingFun)
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) CoreExpr
expr
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [] CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [] (Type -> Coercion
mkRepReflCo (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr)))
where
go :: Either InScopeSet Subst
-> [FloatBind] -> CoreExpr -> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go :: Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats (Tick CoreTickish
t CoreExpr
expr) ConCont
cont
| Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
expr ConCont
cont
go Either InScopeSet Subst
subst [FloatBind]
floats (Cast CoreExpr
expr Coercion
co1) (CC [CoreExpr]
args Coercion
co2)
| Just ([CoreExpr]
args', MCoercion
m_co1') <- Coercion -> [CoreExpr] -> Maybe ([CoreExpr], MCoercion)
pushCoArgs (Either InScopeSet Subst -> Coercion -> Coercion
forall a. Either a Subst -> Coercion -> Coercion
subst_co Either InScopeSet Subst
subst Coercion
co1) [CoreExpr]
args
= case MCoercion
m_co1' of
MCo Coercion
co1' -> Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args' (Coercion
co1' Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2))
MCoercion
MRefl -> Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args' Coercion
co2)
go Either InScopeSet Subst
subst [FloatBind]
floats (App CoreExpr
fun CoreExpr
arg) (CC [CoreExpr]
args Coercion
co)
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
fun ([CoreExpr] -> Coercion -> ConCont
CC (Either InScopeSet Subst -> CoreExpr -> CoreExpr
forall a. Either a Subst -> CoreExpr -> CoreExpr
subst_expr Either InScopeSet Subst
subst CoreExpr
arg CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) Coercion
co)
go Either InScopeSet Subst
subst [FloatBind]
floats (Lam Id
bndr CoreExpr
body) (CC (CoreExpr
arg:[CoreExpr]
args) Coercion
co)
| CoreExpr -> Bool
exprIsTrivial CoreExpr
arg
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (Either InScopeSet Subst
-> Id -> CoreExpr -> Either InScopeSet Subst
forall a.
Either InScopeSet Subst -> Id -> CoreExpr -> Either a Subst
extend Either InScopeSet Subst
subst Id
bndr CoreExpr
arg) [FloatBind]
floats CoreExpr
body ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
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 -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreExpr
arg)
in Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) CoreExpr
body ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args Coercion
co)
go Either InScopeSet Subst
subst [FloatBind]
floats (Let (NonRec Id
bndr CoreExpr
rhs) CoreExpr
expr) ConCont
cont
| Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)
= let rhs' :: CoreExpr
rhs' = Either InScopeSet Subst -> CoreExpr -> CoreExpr
forall a. Either a Subst -> CoreExpr -> CoreExpr
subst_expr Either InScopeSet Subst
subst CoreExpr
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 -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreExpr
rhs')
in Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) CoreExpr
expr ConCont
cont
go Either InScopeSet Subst
subst [FloatBind]
floats (Case CoreExpr
scrut Id
b Type
_ [Alt AltCon
con [Id]
vars CoreExpr
expr]) ConCont
cont
= let
scrut' :: CoreExpr
scrut' = Either InScopeSet Subst -> CoreExpr -> CoreExpr
forall a. Either a Subst -> CoreExpr -> CoreExpr
subst_expr Either InScopeSet Subst
subst CoreExpr
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 = CoreExpr -> Id -> AltCon -> [Id] -> FloatBind
FloatCase CoreExpr
scrut' Id
b' AltCon
con [Id]
vars'
in
Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst'' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) CoreExpr
expr ConCont
cont
go (Right Subst
sub) [FloatBind]
floats (Var Id
v) ConCont
cont
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left (Subst -> InScopeSet
substInScope Subst
sub))
[FloatBind]
floats
(HasDebugCallStack => Subst -> Id -> CoreExpr
Subst -> Id -> CoreExpr
lookupIdSubst Subst
sub Id
v)
ConCont
cont
go (Left InScopeSet
in_scope) [FloatBind]
floats (Var Id
fun) cont :: ConCont
cont@(CC [CoreExpr]
args Coercion
co)
| Just DataCon
con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
, (CoreExpr -> Bool) -> [CoreExpr] -> FullArgCount
forall a. (a -> Bool) -> [a] -> FullArgCount
count CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
args FullArgCount -> FullArgCount -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> FullArgCount
idArity Id
fun
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$
DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
con [CoreExpr]
args Coercion
co
| Id -> Bool
isDataConWrapId Id
fun
, let rhs :: CoreExpr
rhs = Unfolding -> CoreExpr
uf_tmpl (IdUnfoldingFun
realIdUnfolding Id
fun)
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [FloatBind]
floats CoreExpr
rhs ConCont
cont
| DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
dfun_args } <- Unfolding
unfolding
, [Id]
bndrs [Id] -> [CoreExpr] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [CoreExpr]
args
, let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope ([CoreExpr] -> VarSet
exprsFreeVars [CoreExpr]
dfun_args)
subst :: Subst
subst = InScopeSet -> [(Id, CoreExpr)] -> Subst
mkOpenSubst InScopeSet
in_scope' ([Id]
bndrs [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreExpr]
args)
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$
DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
con ((CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
Subst -> CoreExpr -> CoreExpr
substExpr Subst
subst) [CoreExpr]
dfun_args) Coercion
co
| Id -> FullArgCount
idArity Id
fun FullArgCount -> FullArgCount -> Bool
forall a. Eq a => a -> a -> Bool
== FullArgCount
0
, Just CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe Unfolding
unfolding
, let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope (CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs)
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope') [FloatBind]
floats CoreExpr
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)
, [CoreExpr
arg] <- [CoreExpr]
args
, Just (LitString ByteString
str) <- (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) CoreExpr
arg
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$
Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
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]
_ CoreExpr
_ ConCont
_ = Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a. Maybe a
Nothing
succeedWith :: InScopeSet -> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith :: InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
rev_floats Maybe (DataCon, [Type], [CoreExpr])
x
= do { (DataCon
con, [Type]
tys, [CoreExpr]
args) <- Maybe (DataCon, [Type], [CoreExpr])
x
; let floats :: [FloatBind]
floats = [FloatBind] -> [FloatBind]
forall a. [a] -> [a]
reverse [FloatBind]
rev_floats
; (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return (InScopeSet
in_scope, [FloatBind]
floats, DataCon
con, [Type]
tys, [CoreExpr]
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 -> CoreExpr -> CoreExpr
subst_expr (Left {}) CoreExpr
e = CoreExpr
e
subst_expr (Right Subst
s) CoreExpr
e = HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
Subst -> CoreExpr -> CoreExpr
substExpr Subst
s CoreExpr
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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 -> CoreExpr -> Either a Subst
extend (Left InScopeSet
in_scope) Id
v CoreExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> CoreExpr -> Subst
extendSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) Id
v CoreExpr
e)
extend (Right Subst
s) Id
v CoreExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> CoreExpr -> Subst
extendSubst Subst
s Id
v CoreExpr
e)
dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
-> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral :: Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral Id
fun ByteString
str Coercion
co =
case ByteString -> Maybe (Char, ByteString)
utf8UnconsByteString ByteString
str of
Maybe (Char, ByteString)
Nothing -> DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
nilDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
charTy] Coercion
co
Just (Char
char, ByteString
charTail) ->
let char_expr :: CoreExpr
char_expr = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
charDataCon [Char -> CoreExpr
forall b. Char -> Expr b
mkCharLit Char
char]
rest :: CoreExpr
rest = if ByteString -> Bool
BS.null ByteString
charTail
then DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
nilDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
charTy]
else CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fun)
(Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
charTail))
in DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
consDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
charTy, CoreExpr
char_expr, CoreExpr
rest] Coercion
co
exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe :: (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe env :: (InScopeSet, IdUnfoldingFun)
env@(InScopeSet
_, IdUnfoldingFun
id_unf) CoreExpr
e
= case CoreExpr
e of
Lit Literal
l -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
Tick CoreTickish
_ CoreExpr
e' -> (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env CoreExpr
e'
Var Id
v -> Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
v)
Maybe CoreExpr -> (CoreExpr -> Maybe Literal) -> Maybe Literal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env
CoreExpr
_ -> Maybe Literal
forall a. Maybe a
Nothing
exprIsLambda_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (Var, CoreExpr,[CoreTickish])
exprIsLambda_maybe :: (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ (Lam Id
x CoreExpr
e)
= (Id, CoreExpr, [CoreTickish])
-> Maybe (Id, CoreExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, CoreExpr
e, [])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Tick CoreTickish
t CoreExpr
e)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
, Just (Id
x, CoreExpr
e, [CoreTickish]
ts) <- (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [CoreTickish])
HasDebugCallStack =>
(InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) CoreExpr
e
= (Id, CoreExpr, [CoreTickish])
-> Maybe (Id, CoreExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, CoreExpr
e, CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts)
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Cast CoreExpr
casted_e Coercion
co)
| Just (Id
x, CoreExpr
e,[CoreTickish]
ts) <- (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [CoreTickish])
HasDebugCallStack =>
(InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) CoreExpr
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',CoreExpr
e') <- HasDebugCallStack =>
InScopeSet -> Id -> CoreExpr -> Coercion -> Maybe (Id, CoreExpr)
InScopeSet -> Id -> CoreExpr -> Coercion -> Maybe (Id, CoreExpr)
pushCoercionIntoLambda InScopeSet
in_scope_set Id
x CoreExpr
e Coercion
co
, let res :: Maybe (Id, CoreExpr, [CoreTickish])
res = (Id, CoreExpr, [CoreTickish])
-> Maybe (Id, CoreExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x',CoreExpr
e',[CoreTickish]
ts)
=
Maybe (Id, CoreExpr, [CoreTickish])
res
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) CoreExpr
e
| (Var Id
f, [CoreExpr]
as, [CoreTickish]
ts) <- (CoreTickish -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
e
, Id -> FullArgCount
idArity Id
f FullArgCount -> FullArgCount -> Bool
forall a. Ord a => a -> a -> Bool
> (CoreExpr -> Bool) -> [CoreExpr] -> FullArgCount
forall a. (a -> Bool) -> [a] -> FullArgCount
count CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
as
, Just CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
f)
, let e' :: CoreExpr
e' = HasDebugCallStack => SimpleOpts -> Subst -> CoreExpr -> CoreExpr
SimpleOpts -> Subst -> CoreExpr -> CoreExpr
simpleOptExprWith SimpleOpts
defaultSimpleOpts (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope_set) (CoreExpr
rhs CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [CoreExpr]
as)
, Just (Id
x', CoreExpr
e'', [CoreTickish]
ts') <- (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [CoreTickish])
HasDebugCallStack =>
(InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) CoreExpr
e'
, let res :: Maybe (Id, CoreExpr, [CoreTickish])
res = (Id, CoreExpr, [CoreTickish])
-> Maybe (Id, CoreExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x', CoreExpr
e'', [CoreTickish]
ts[CoreTickish] -> [CoreTickish] -> [CoreTickish]
forall a. [a] -> [a] -> [a]
++[CoreTickish]
ts')
=
Maybe (Id, CoreExpr, [CoreTickish])
res
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ CoreExpr
_e
=
Maybe (Id, CoreExpr, [CoreTickish])
forall a. Maybe a
Nothing