module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where
import GHC.Prelude
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Utils ( exprType, exprIsHNF )
import GHC.Core.FVs ( exprFreeVars )
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Type
import GHC.Types.Unique.Supply
import GHC.Types.Basic
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Config
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.SourceText
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Types.Unique
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Core.FamInstEnv
import GHC.Utils.Monad
wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds DynFlags
dflags FamInstEnvs
fam_envs UniqSupply
us CoreProgram
top_binds
= UniqSupply -> UniqSM CoreProgram -> CoreProgram
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM CoreProgram -> CoreProgram)
-> UniqSM CoreProgram -> CoreProgram
forall a b. (a -> b) -> a -> b
$ do
[CoreProgram]
top_binds' <- (CoreBind -> UniqSM CoreProgram)
-> CoreProgram -> UniqSM [CoreProgram]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> FamInstEnvs -> CoreBind -> UniqSM CoreProgram
wwBind DynFlags
dflags FamInstEnvs
fam_envs) CoreProgram
top_binds
CoreProgram -> UniqSM CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreProgram] -> CoreProgram
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [CoreProgram]
top_binds')
wwBind :: DynFlags
-> FamInstEnvs
-> CoreBind
-> UniqSM [CoreBind]
wwBind :: DynFlags -> FamInstEnvs -> CoreBind -> UniqSM CoreProgram
wwBind DynFlags
dflags FamInstEnvs
fam_envs (NonRec CoreBndr
binder Expr CoreBndr
rhs) = do
Expr CoreBndr
new_rhs <- DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
rhs
[(CoreBndr, Expr CoreBndr)]
new_pairs <- DynFlags
-> FamInstEnvs
-> RecFlag
-> CoreBndr
-> Expr CoreBndr
-> UniqSM [(CoreBndr, Expr CoreBndr)]
tryWW DynFlags
dflags FamInstEnvs
fam_envs RecFlag
NonRecursive CoreBndr
binder Expr CoreBndr
new_rhs
CoreProgram -> UniqSM CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return [CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b Expr CoreBndr
e | (CoreBndr
b,Expr CoreBndr
e) <- [(CoreBndr, Expr CoreBndr)]
new_pairs]
wwBind DynFlags
dflags FamInstEnvs
fam_envs (Rec [(CoreBndr, Expr CoreBndr)]
pairs)
= CoreBind -> CoreProgram
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreProgram)
-> ([(CoreBndr, Expr CoreBndr)] -> CoreBind)
-> [(CoreBndr, Expr CoreBndr)]
-> CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(CoreBndr, Expr CoreBndr)] -> CoreProgram)
-> UniqSM [(CoreBndr, Expr CoreBndr)] -> UniqSM CoreProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreBndr, Expr CoreBndr) -> UniqSM [(CoreBndr, Expr CoreBndr)])
-> [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (CoreBndr, Expr CoreBndr) -> UniqSM [(CoreBndr, Expr CoreBndr)]
do_one [(CoreBndr, Expr CoreBndr)]
pairs
where
do_one :: (CoreBndr, Expr CoreBndr) -> UniqSM [(CoreBndr, Expr CoreBndr)]
do_one (CoreBndr
binder, Expr CoreBndr
rhs) = do Expr CoreBndr
new_rhs <- DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
rhs
DynFlags
-> FamInstEnvs
-> RecFlag
-> CoreBndr
-> Expr CoreBndr
-> UniqSM [(CoreBndr, Expr CoreBndr)]
tryWW DynFlags
dflags FamInstEnvs
fam_envs RecFlag
Recursive CoreBndr
binder Expr CoreBndr
new_rhs
wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr
wwExpr :: DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
_ FamInstEnvs
_ e :: Expr CoreBndr
e@(Type {}) = Expr CoreBndr -> UniqSM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e
wwExpr DynFlags
_ FamInstEnvs
_ e :: Expr CoreBndr
e@(Coercion {}) = Expr CoreBndr -> UniqSM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e
wwExpr DynFlags
_ FamInstEnvs
_ e :: Expr CoreBndr
e@(Lit {}) = Expr CoreBndr -> UniqSM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e
wwExpr DynFlags
_ FamInstEnvs
_ e :: Expr CoreBndr
e@(Var {}) = Expr CoreBndr -> UniqSM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e
wwExpr DynFlags
dflags FamInstEnvs
fam_envs (Lam CoreBndr
binder Expr CoreBndr
expr)
= CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
new_binder (Expr CoreBndr -> Expr CoreBndr)
-> UniqSM (Expr CoreBndr) -> UniqSM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
expr
where new_binder :: CoreBndr
new_binder | CoreBndr -> Bool
isId CoreBndr
binder = CoreBndr -> CoreBndr
zapIdUsedOnceInfo CoreBndr
binder
| Bool
otherwise = CoreBndr
binder
wwExpr DynFlags
dflags FamInstEnvs
fam_envs (App Expr CoreBndr
f Expr CoreBndr
a)
= Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App (Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr)
-> UniqSM (Expr CoreBndr)
-> UniqSM (Expr CoreBndr -> Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
f UniqSM (Expr CoreBndr -> Expr CoreBndr)
-> UniqSM (Expr CoreBndr) -> UniqSM (Expr CoreBndr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
a
wwExpr DynFlags
dflags FamInstEnvs
fam_envs (Tick CoreTickish
note Expr CoreBndr
expr)
= CoreTickish -> Expr CoreBndr -> Expr CoreBndr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
note (Expr CoreBndr -> Expr CoreBndr)
-> UniqSM (Expr CoreBndr) -> UniqSM (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
expr
wwExpr DynFlags
dflags FamInstEnvs
fam_envs (Cast Expr CoreBndr
expr CoercionR
co) = do
Expr CoreBndr
new_expr <- DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
expr
Expr CoreBndr -> UniqSM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> CoercionR -> Expr CoreBndr
forall b. Expr b -> CoercionR -> Expr b
Cast Expr CoreBndr
new_expr CoercionR
co)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs (Let CoreBind
bind Expr CoreBndr
expr)
= CoreProgram -> Expr CoreBndr -> Expr CoreBndr
forall b. [Bind b] -> Expr b -> Expr b
mkLets (CoreProgram -> Expr CoreBndr -> Expr CoreBndr)
-> UniqSM CoreProgram -> UniqSM (Expr CoreBndr -> Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> FamInstEnvs -> CoreBind -> UniqSM CoreProgram
wwBind DynFlags
dflags FamInstEnvs
fam_envs CoreBind
bind UniqSM (Expr CoreBndr -> Expr CoreBndr)
-> UniqSM (Expr CoreBndr) -> UniqSM (Expr CoreBndr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
expr
wwExpr DynFlags
dflags FamInstEnvs
fam_envs (Case Expr CoreBndr
expr CoreBndr
binder Type
ty [Alt CoreBndr]
alts) = do
Expr CoreBndr
new_expr <- DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
expr
[Alt CoreBndr]
new_alts <- (Alt CoreBndr -> UniqSM (Alt CoreBndr))
-> [Alt CoreBndr] -> UniqSM [Alt CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt CoreBndr -> UniqSM (Alt CoreBndr)
ww_alt [Alt CoreBndr]
alts
let new_binder :: CoreBndr
new_binder = CoreBndr -> CoreBndr
zapIdUsedOnceInfo CoreBndr
binder
Expr CoreBndr -> UniqSM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr CoreBndr
new_expr CoreBndr
new_binder Type
ty [Alt CoreBndr]
new_alts)
where
ww_alt :: Alt CoreBndr -> UniqSM (Alt CoreBndr)
ww_alt (Alt AltCon
con [CoreBndr]
binders Expr CoreBndr
rhs) = do
Expr CoreBndr
new_rhs <- DynFlags -> FamInstEnvs -> Expr CoreBndr -> UniqSM (Expr CoreBndr)
wwExpr DynFlags
dflags FamInstEnvs
fam_envs Expr CoreBndr
rhs
let new_binders :: [CoreBndr]
new_binders = [ if CoreBndr -> Bool
isId CoreBndr
b then CoreBndr -> CoreBndr
zapIdUsedOnceInfo CoreBndr
b else CoreBndr
b
| CoreBndr
b <- [CoreBndr]
binders ]
Alt CoreBndr -> UniqSM (Alt CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [CoreBndr] -> Expr CoreBndr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
new_binders Expr CoreBndr
new_rhs)
tryWW :: DynFlags
-> FamInstEnvs
-> RecFlag
-> Id
-> CoreExpr
-> UniqSM [(Id, CoreExpr)]
tryWW :: DynFlags
-> FamInstEnvs
-> RecFlag
-> CoreBndr
-> Expr CoreBndr
-> UniqSM [(CoreBndr, Expr CoreBndr)]
tryWW DynFlags
dflags FamInstEnvs
fam_envs RecFlag
is_rec CoreBndr
fn_id Expr CoreBndr
rhs
| Just Unfolding
stable_unf <- UnfoldingOpts -> IdInfo -> Maybe Unfolding
certainlyWillInline UnfoldingOpts
uf_opts IdInfo
fn_info
= [(CoreBndr, Expr CoreBndr)] -> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (CoreBndr
new_fn_id CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` Unfolding
stable_unf, Expr CoreBndr
rhs) ]
| CoreBndr -> Bool
isRecordSelector CoreBndr
fn_id
= [(CoreBndr, Expr CoreBndr)] -> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (CoreBndr
new_fn_id, Expr CoreBndr
rhs ) ]
| Bool
is_fun Bool -> Bool -> Bool
&& Bool
is_eta_exp
= DynFlags
-> FamInstEnvs
-> CoreBndr
-> IdInfo
-> [Demand]
-> Divergence
-> Cpr
-> Expr CoreBndr
-> UniqSM [(CoreBndr, Expr CoreBndr)]
splitFun DynFlags
dflags FamInstEnvs
fam_envs CoreBndr
new_fn_id IdInfo
fn_info [Demand]
wrap_dmds Divergence
div Cpr
cpr Expr CoreBndr
rhs
| RecFlag -> Bool
isNonRec RecFlag
is_rec, Bool
is_thunk
= DynFlags
-> FamInstEnvs
-> RecFlag
-> CoreBndr
-> Expr CoreBndr
-> UniqSM [(CoreBndr, Expr CoreBndr)]
splitThunk DynFlags
dflags FamInstEnvs
fam_envs RecFlag
is_rec CoreBndr
new_fn_id Expr CoreBndr
rhs
| Bool
otherwise
= [(CoreBndr, Expr CoreBndr)] -> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (CoreBndr
new_fn_id, Expr CoreBndr
rhs) ]
where
uf_opts :: UnfoldingOpts
uf_opts = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
fn_info :: IdInfo
fn_info = HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
fn_id
([Demand]
wrap_dmds, Divergence
div) = DmdSig -> ([Demand], Divergence)
splitDmdSig (IdInfo -> DmdSig
dmdSigInfo IdInfo
fn_info)
cpr_ty :: CprType
cpr_ty = CprSig -> CprType
getCprSig (IdInfo -> CprSig
cprSigInfo IdInfo
fn_info)
cpr :: Cpr
cpr = Bool -> SDoc -> Cpr -> Cpr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (CoreBndr -> Bool
isJoinId CoreBndr
fn_id Bool -> Bool -> Bool
|| CprType
cpr_ty CprType -> CprType -> Bool
forall a. Eq a => a -> a -> Bool
== CprType
topCprType Bool -> Bool -> Bool
|| CprType -> Arity
ct_arty CprType
cpr_ty Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Arity
arityInfo IdInfo
fn_info)
(CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
fn_id SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"ct_arty:" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
int (CprType -> Arity
ct_arty CprType
cpr_ty)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"arityInfo:" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IdInfo -> Arity
arityInfo IdInfo
fn_info)) (Cpr -> Cpr) -> Cpr -> Cpr
forall a b. (a -> b) -> a -> b
$
CprType -> Cpr
ct_cpr CprType
cpr_ty
new_fn_id :: CoreBndr
new_fn_id = CoreBndr -> CoreBndr
zapIdUsedOnceInfo (CoreBndr -> CoreBndr
zapIdUsageEnvInfo CoreBndr
fn_id)
is_fun :: Bool
is_fun = [Demand] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Demand]
wrap_dmds Bool -> Bool -> Bool
|| CoreBndr -> Bool
isJoinId CoreBndr
fn_id
is_eta_exp :: Bool
is_eta_exp = [Demand] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
wrap_dmds Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Expr CoreBndr -> Arity
manifestArity Expr CoreBndr
rhs
is_thunk :: Bool
is_thunk = Bool -> Bool
not Bool
is_fun Bool -> Bool -> Bool
&& Bool -> Bool
not (Expr CoreBndr -> Bool
exprIsHNF Expr CoreBndr
rhs) Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreBndr -> Bool
isJoinId CoreBndr
fn_id)
Bool -> Bool -> Bool
&& Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (CoreBndr -> Type
idType CoreBndr
fn_id))
splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr
-> UniqSM [(Id, CoreExpr)]
splitFun :: DynFlags
-> FamInstEnvs
-> CoreBndr
-> IdInfo
-> [Demand]
-> Divergence
-> Cpr
-> Expr CoreBndr
-> UniqSM [(CoreBndr, Expr CoreBndr)]
splitFun DynFlags
dflags FamInstEnvs
fam_envs CoreBndr
fn_id IdInfo
fn_info [Demand]
wrap_dmds Divergence
div Cpr
cpr Expr CoreBndr
rhs
= Bool
-> SDoc
-> UniqSM [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)]
forall a. HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not ([Demand]
wrap_dmds [Demand] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` Arity
arity)) (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
fn_id SDoc -> SDoc -> SDoc
<+> (Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
arity SDoc -> SDoc -> SDoc
$$ [Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
wrap_dmds SDoc -> SDoc -> SDoc
$$ Cpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cpr
cpr)) (UniqSM [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)])
-> UniqSM [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)]
forall a b. (a -> b) -> a -> b
$
do { Maybe WwResult
mb_stuff <- WwOpts
-> VarSet -> CoreBndr -> [Demand] -> Cpr -> UniqSM (Maybe WwResult)
mkWwBodies (DynFlags -> FamInstEnvs -> WwOpts
initWwOpts DynFlags
dflags FamInstEnvs
fam_envs) VarSet
rhs_fvs CoreBndr
fn_id [Demand]
wrap_dmds Cpr
use_cpr_info
; case Maybe WwResult
mb_stuff of
Maybe WwResult
Nothing -> [(CoreBndr, Expr CoreBndr)] -> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(CoreBndr
fn_id, Expr CoreBndr
rhs)]
Just WwResult
stuff -> do { Unique
work_uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; [(CoreBndr, Expr CoreBndr)] -> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
-> CoreBndr
-> IdInfo
-> Arity
-> Expr CoreBndr
-> Unique
-> Divergence
-> Cpr
-> WwResult
-> [(CoreBndr, Expr CoreBndr)]
mkWWBindPair DynFlags
dflags CoreBndr
fn_id IdInfo
fn_info Arity
arity Expr CoreBndr
rhs
Unique
work_uniq Divergence
div Cpr
cpr WwResult
stuff) } }
where
rhs_fvs :: VarSet
rhs_fvs = Expr CoreBndr -> VarSet
exprFreeVars Expr CoreBndr
rhs
arity :: Arity
arity = IdInfo -> Arity
arityInfo IdInfo
fn_info
use_cpr_info :: Cpr
use_cpr_info | CoreBndr -> Bool
isJoinId CoreBndr
fn_id = Cpr
topCpr
| Bool
otherwise = Cpr
cpr
mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity
-> CoreExpr -> Unique -> Divergence -> Cpr
-> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)
-> [(Id, CoreExpr)]
mkWWBindPair :: DynFlags
-> CoreBndr
-> IdInfo
-> Arity
-> Expr CoreBndr
-> Unique
-> Divergence
-> Cpr
-> WwResult
-> [(CoreBndr, Expr CoreBndr)]
mkWWBindPair DynFlags
dflags CoreBndr
fn_id IdInfo
fn_info Arity
arity Expr CoreBndr
rhs Unique
work_uniq Divergence
div Cpr
cpr
([Demand]
work_demands, Arity
join_arity, CoreBndr -> Expr CoreBndr
wrap_fn, Expr CoreBndr -> Expr CoreBndr
work_fn)
= [(CoreBndr
work_id, Expr CoreBndr
work_rhs), (CoreBndr
wrap_id, Expr CoreBndr
wrap_rhs)]
where
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
work_rhs :: Expr CoreBndr
work_rhs = Expr CoreBndr -> Expr CoreBndr
work_fn Expr CoreBndr
rhs
work_act :: Activation
work_act = case InlineSpec
fn_inline_spec of
InlineSpec
NoInline -> InlinePragma -> Activation
inl_act InlinePragma
fn_inl_prag
InlineSpec
_ -> InlinePragma -> Activation
inl_act InlinePragma
wrap_prag
work_prag :: InlinePragma
work_prag = InlinePragma :: SourceText
-> InlineSpec
-> Maybe Arity
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma { inl_src :: SourceText
inl_src = String -> SourceText
SourceText String
"{-# INLINE"
, inl_inline :: InlineSpec
inl_inline = InlineSpec
fn_inline_spec
, inl_sat :: Maybe Arity
inl_sat = Maybe Arity
forall a. Maybe a
Nothing
, inl_act :: Activation
inl_act = Activation
work_act
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
FunLike }
work_join_arity :: Maybe Arity
work_join_arity | CoreBndr -> Bool
isJoinId CoreBndr
fn_id = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
join_arity
| Bool
otherwise = Maybe Arity
forall a. Maybe a
Nothing
work_id :: CoreBndr
work_id = Unique -> CoreBndr -> Type -> CoreBndr
mkWorkerId Unique
work_uniq CoreBndr
fn_id (Expr CoreBndr -> Type
exprType Expr CoreBndr
work_rhs)
CoreBndr -> OccInfo -> CoreBndr
`setIdOccInfo` IdInfo -> OccInfo
occInfo IdInfo
fn_info
CoreBndr -> InlinePragma -> CoreBndr
`setInlinePragma` InlinePragma
work_prag
CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` SimpleOpts
-> (Expr CoreBndr -> Expr CoreBndr) -> Unfolding -> Unfolding
mkWorkerUnfolding SimpleOpts
simpl_opts Expr CoreBndr -> Expr CoreBndr
work_fn Unfolding
fn_unfolding
CoreBndr -> DmdSig -> CoreBndr
`setIdDmdSig` [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
work_demands Divergence
div
CoreBndr -> CprSig -> CoreBndr
`setIdCprSig` Arity -> Cpr -> CprSig
mkCprSig Arity
work_arity Cpr
work_cpr_info
CoreBndr -> Demand -> CoreBndr
`setIdDemandInfo` Demand
worker_demand
CoreBndr -> Arity -> CoreBndr
`setIdArity` Arity
work_arity
CoreBndr -> Maybe Arity -> CoreBndr
`asJoinId_maybe` Maybe Arity
work_join_arity
work_arity :: Arity
work_arity = [Demand] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
work_demands
single_call :: Bool
single_call = Arity -> Demand -> Bool
saturatedByOneShots Arity
arity (IdInfo -> Demand
demandInfo IdInfo
fn_info)
worker_demand :: Demand
worker_demand | Bool
single_call = Arity -> Demand
mkWorkerDemand Arity
work_arity
| Bool
otherwise = Demand
topDmd
wrap_rhs :: Expr CoreBndr
wrap_rhs = CoreBndr -> Expr CoreBndr
wrap_fn CoreBndr
work_id
wrap_prag :: InlinePragma
wrap_prag = InlinePragma -> InlinePragma
mkStrWrapperInlinePrag InlinePragma
fn_inl_prag
wrap_id :: CoreBndr
wrap_id = CoreBndr
fn_id CoreBndr -> Unfolding -> CoreBndr
`setIdUnfolding` SimpleOpts -> Expr CoreBndr -> Arity -> Unfolding
mkWwInlineRule SimpleOpts
simpl_opts Expr CoreBndr
wrap_rhs Arity
arity
CoreBndr -> InlinePragma -> CoreBndr
`setInlinePragma` InlinePragma
wrap_prag
CoreBndr -> OccInfo -> CoreBndr
`setIdOccInfo` OccInfo
noOccInfo
fn_inl_prag :: InlinePragma
fn_inl_prag = IdInfo -> InlinePragma
inlinePragInfo IdInfo
fn_info
fn_inline_spec :: InlineSpec
fn_inline_spec = InlinePragma -> InlineSpec
inl_inline InlinePragma
fn_inl_prag
fn_unfolding :: Unfolding
fn_unfolding = IdInfo -> Unfolding
unfoldingInfo IdInfo
fn_info
work_cpr_info :: Cpr
work_cpr_info | CoreBndr -> Bool
isJoinId CoreBndr
fn_id = Cpr
cpr
| Bool
otherwise = Cpr
topCpr
mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma
mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma
mkStrWrapperInlinePrag (InlinePragma { inl_act :: InlinePragma -> Activation
inl_act = Activation
act, inl_rule :: InlinePragma -> RuleMatchInfo
inl_rule = RuleMatchInfo
rule_info })
= InlinePragma :: SourceText
-> InlineSpec
-> Maybe Arity
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma { inl_src :: SourceText
inl_src = String -> SourceText
SourceText String
"{-# INLINE"
, inl_inline :: InlineSpec
inl_inline = InlineSpec
NoUserInlinePrag
, inl_sat :: Maybe Arity
inl_sat = Maybe Arity
forall a. Maybe a
Nothing
, inl_act :: Activation
inl_act = Activation
wrap_act
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
rule_info }
where
wrap_act :: Activation
wrap_act = case Activation
act of
Activation
NeverActive -> Activation
activateDuringFinal
Activation
FinalActive -> Activation
act
ActiveAfter {} -> Activation
act
ActiveBefore {} -> Activation
activateAfterInitial
Activation
AlwaysActive -> Activation
activateAfterInitial
splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
splitThunk :: DynFlags
-> FamInstEnvs
-> RecFlag
-> CoreBndr
-> Expr CoreBndr
-> UniqSM [(CoreBndr, Expr CoreBndr)]
splitThunk DynFlags
dflags FamInstEnvs
fam_envs RecFlag
is_rec CoreBndr
x Expr CoreBndr
rhs
= Bool
-> UniqSM [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)]
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (CoreBndr -> Bool
isJoinId CoreBndr
x)) (UniqSM [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)])
-> UniqSM [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)]
forall a b. (a -> b) -> a -> b
$
do { let x' :: CoreBndr
x' = CoreBndr -> CoreBndr
localiseId CoreBndr
x
; (Bool
useful,[CoreBndr]
_, Expr CoreBndr -> Expr CoreBndr
wrap_fn, Expr CoreBndr -> Expr CoreBndr
work_fn)
<- WwOpts
-> ArgOfInlineableFun
-> [CoreBndr]
-> UniqSM
(Bool, [CoreBndr], Expr CoreBndr -> Expr CoreBndr,
Expr CoreBndr -> Expr CoreBndr)
mkWWstr (DynFlags -> FamInstEnvs -> WwOpts
initWwOpts DynFlags
dflags FamInstEnvs
fam_envs) ArgOfInlineableFun
NotArgOfInlineableFun [CoreBndr
x']
; let res :: [(CoreBndr, Expr CoreBndr)]
res = [ (CoreBndr
x, CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
x' Expr CoreBndr
rhs) (Expr CoreBndr -> Expr CoreBndr
wrap_fn (Expr CoreBndr -> Expr CoreBndr
work_fn (CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
x')))) ]
; if Bool
useful then Bool
-> SDoc
-> ([(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)])
-> [(CoreBndr, Expr CoreBndr)]
-> UniqSM [(CoreBndr, Expr CoreBndr)]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (RecFlag -> Bool
isNonRec RecFlag
is_rec) (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
x)
[(CoreBndr, Expr CoreBndr)] -> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(CoreBndr, Expr CoreBndr)]
res
else [(CoreBndr, Expr CoreBndr)] -> UniqSM [(CoreBndr, Expr CoreBndr)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(CoreBndr
x, Expr CoreBndr
rhs)] }