{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Core.Unfold.Make
( noUnfolding
, mkUnfolding
, mkCoreUnfolding
, mkFinalUnfolding
, mkSimpleUnfolding
, mkWorkerUnfolding
, mkInlineUnfolding
, mkInlineUnfoldingWithArity
, mkInlinableUnfolding
, mkWrapperUnfolding
, mkCompulsoryUnfolding
, mkCompulsoryUnfolding'
, mkDFunUnfolding
, specUnfolding
, certainlyWillInline
)
where
import GHC.Prelude
import GHC.Core
import GHC.Core.Unfold
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core.DataCon
import GHC.Core.Utils
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand ( DmdSig, isDeadEndSig )
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import {-# SOURCE #-} GHC.Core.SimpleOpt
mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding
mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding
mkFinalUnfolding UnfoldingOpts
opts UnfoldingSource
src DmdSig
strict_sig CoreExpr
expr
= UnfoldingOpts
-> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
mkUnfolding UnfoldingOpts
opts UnfoldingSource
src
Bool
True
(DmdSig -> Bool
isDeadEndSig DmdSig
strict_sig)
CoreExpr
expr
mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
opts CoreExpr
expr = CoreExpr -> Unfolding
mkCompulsoryUnfolding' (HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts CoreExpr
expr)
mkCompulsoryUnfolding' :: CoreExpr -> Unfolding
mkCompulsoryUnfolding' :: CoreExpr -> Unfolding
mkCompulsoryUnfolding' CoreExpr
expr
= UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
InlineCompulsory Bool
True
CoreExpr
expr
(UnfWhen :: Arity -> Bool -> Bool -> UnfoldingGuidance
UnfWhen { ug_arity :: Arity
ug_arity = Arity
0
, ug_unsat_ok :: Bool
ug_unsat_ok = Bool
unSaturatedOk, ug_boring_ok :: Bool
ug_boring_ok = Bool
boringCxtOk })
mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
mkSimpleUnfolding !UnfoldingOpts
opts CoreExpr
rhs
= UnfoldingOpts
-> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
mkUnfolding UnfoldingOpts
opts UnfoldingSource
InlineRhs Bool
False Bool
False CoreExpr
rhs
mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding [Var]
bndrs DataCon
con [CoreExpr]
ops
= DFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
DFunUnfolding { df_bndrs :: [Var]
df_bndrs = [Var]
bndrs
, df_con :: DataCon
df_con = DataCon
con
, df_args :: [CoreExpr]
df_args = (CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> CoreExpr
occurAnalyseExpr [CoreExpr]
ops }
mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
mkWrapperUnfolding SimpleOpts
opts CoreExpr
expr Arity
arity
= UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
InlineStable Bool
True
(HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts CoreExpr
expr)
(UnfWhen :: Arity -> Bool -> Bool -> UnfoldingGuidance
UnfWhen { ug_arity :: Arity
ug_arity = Arity
arity
, ug_unsat_ok :: Bool
ug_unsat_ok = Bool
unSaturatedOk
, ug_boring_ok :: Bool
ug_boring_ok = Bool
boringCxtNotOk })
mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
mkWorkerUnfolding SimpleOpts
opts CoreExpr -> CoreExpr
work_fn
(CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
tmpl
, uf_is_top :: Unfolding -> Bool
uf_is_top = Bool
top_lvl })
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
= UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
src Bool
top_lvl CoreExpr
new_tmpl UnfoldingGuidance
guidance
where
new_tmpl :: CoreExpr
new_tmpl = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts (CoreExpr -> CoreExpr
work_fn CoreExpr
tmpl)
guidance :: UnfoldingGuidance
guidance = UnfoldingOpts -> Bool -> CoreExpr -> UnfoldingGuidance
calcUnfoldingGuidance (SimpleOpts -> UnfoldingOpts
so_uf_opts SimpleOpts
opts) Bool
False CoreExpr
new_tmpl
mkWorkerUnfolding SimpleOpts
_ CoreExpr -> CoreExpr
_ Unfolding
_ = Unfolding
noUnfolding
mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfolding SimpleOpts
opts CoreExpr
expr
= UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
InlineStable
Bool
True
CoreExpr
expr' UnfoldingGuidance
guide
where
expr' :: CoreExpr
expr' = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts CoreExpr
expr
guide :: UnfoldingGuidance
guide = UnfWhen :: Arity -> Bool -> Bool -> UnfoldingGuidance
UnfWhen { ug_arity :: Arity
ug_arity = CoreExpr -> Arity
manifestArity CoreExpr
expr'
, ug_unsat_ok :: Bool
ug_unsat_ok = Bool
unSaturatedOk
, ug_boring_ok :: Bool
ug_boring_ok = Bool
boring_ok }
boring_ok :: Bool
boring_ok = CoreExpr -> Bool
inlineBoringOk CoreExpr
expr'
mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Arity
arity SimpleOpts
opts CoreExpr
expr
= UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
InlineStable
Bool
True
CoreExpr
expr' UnfoldingGuidance
guide
where
expr' :: CoreExpr
expr' = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts CoreExpr
expr
guide :: UnfoldingGuidance
guide = UnfWhen :: Arity -> Bool -> Bool -> UnfoldingGuidance
UnfWhen { ug_arity :: Arity
ug_arity = Arity
arity
, ug_unsat_ok :: Bool
ug_unsat_ok = Bool
needSaturated
, ug_boring_ok :: Bool
ug_boring_ok = Bool
boring_ok }
boring_ok :: Bool
boring_ok | Arity
arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0 = Bool
True
| Bool
otherwise = CoreExpr -> Bool
inlineBoringOk CoreExpr
expr'
mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
mkInlinableUnfolding SimpleOpts
opts CoreExpr
expr
= UnfoldingOpts
-> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
mkUnfolding (SimpleOpts -> UnfoldingOpts
so_uf_opts SimpleOpts
opts) UnfoldingSource
InlineStable Bool
False Bool
False CoreExpr
expr'
where
expr' :: CoreExpr
expr' = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts CoreExpr
expr
specUnfolding :: SimpleOpts
-> [Var] -> (CoreExpr -> CoreExpr)
-> [CoreArg]
-> Unfolding -> Unfolding
specUnfolding :: SimpleOpts
-> [Var]
-> (CoreExpr -> CoreExpr)
-> [CoreExpr]
-> Unfolding
-> Unfolding
specUnfolding SimpleOpts
opts [Var]
spec_bndrs CoreExpr -> CoreExpr
spec_app [CoreExpr]
rule_lhs_args
df :: Unfolding
df@(DFunUnfolding { df_bndrs :: Unfolding -> [Var]
df_bndrs = [Var]
old_bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args })
= Bool -> SDoc -> Unfolding -> Unfolding
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([CoreExpr]
rule_lhs_args [CoreExpr] -> [Var] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Var]
old_bndrs)
(Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
df SDoc -> SDoc -> SDoc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
rule_lhs_args) (Unfolding -> Unfolding) -> Unfolding -> Unfolding
forall a b. (a -> b) -> a -> b
$
[Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding [Var]
spec_bndrs DataCon
con ((CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> CoreExpr
spec_arg [CoreExpr]
args)
where
spec_arg :: CoreExpr -> CoreExpr
spec_arg CoreExpr
arg = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> CoreExpr
spec_app ([Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
old_bndrs CoreExpr
arg)
specUnfolding SimpleOpts
opts [Var]
spec_bndrs CoreExpr -> CoreExpr
spec_app [CoreExpr]
rule_lhs_args
(CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
tmpl
, uf_is_top :: Unfolding -> Bool
uf_is_top = Bool
top_lvl
, uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
old_guidance })
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
, UnfWhen { ug_arity :: UnfoldingGuidance -> Arity
ug_arity = Arity
old_arity } <- UnfoldingGuidance
old_guidance
= UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
src Bool
top_lvl CoreExpr
new_tmpl
(UnfoldingGuidance
old_guidance { ug_arity :: Arity
ug_arity = Arity
old_arity Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
arity_decrease })
where
new_tmpl :: CoreExpr
new_tmpl = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
opts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
spec_bndrs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> CoreExpr
spec_app CoreExpr
tmpl
arity_decrease :: Arity
arity_decrease = (CoreExpr -> Bool) -> [CoreExpr] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
rule_lhs_args Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- (Var -> Bool) -> [Var] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count Var -> Bool
isId [Var]
spec_bndrs
specUnfolding SimpleOpts
_ [Var]
_ CoreExpr -> CoreExpr
_ [CoreExpr]
_ Unfolding
_ = Unfolding
noUnfolding
mkUnfolding :: UnfoldingOpts
-> UnfoldingSource
-> Bool
-> Bool
-> CoreExpr
-> Unfolding
mkUnfolding :: UnfoldingOpts
-> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
mkUnfolding UnfoldingOpts
opts UnfoldingSource
src Bool
top_lvl Bool
is_bottoming CoreExpr
expr
= UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
src Bool
top_lvl CoreExpr
expr UnfoldingGuidance
guidance
where
is_top_bottoming :: Bool
is_top_bottoming = Bool
top_lvl Bool -> Bool -> Bool
&& Bool
is_bottoming
guidance :: UnfoldingGuidance
guidance = UnfoldingOpts -> Bool -> CoreExpr -> UnfoldingGuidance
calcUnfoldingGuidance UnfoldingOpts
opts Bool
is_top_bottoming CoreExpr
expr
mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
-> UnfoldingGuidance -> Unfolding
mkCoreUnfolding :: UnfoldingSource
-> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding UnfoldingSource
src Bool
top_lvl CoreExpr
expr UnfoldingGuidance
guidance
=
let is_value :: Bool
is_value = CoreExpr -> Bool
exprIsHNF CoreExpr
expr
is_conlike :: Bool
is_conlike = CoreExpr -> Bool
exprIsConLike CoreExpr
expr
is_work_free :: Bool
is_work_free = CoreExpr -> Bool
exprIsWorkFree CoreExpr
expr
is_expandable :: Bool
is_expandable = CoreExpr -> Bool
exprIsExpandable CoreExpr
expr
in
CoreUnfolding :: CoreExpr
-> UnfoldingSource
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> UnfoldingGuidance
-> Unfolding
CoreUnfolding { uf_tmpl :: CoreExpr
uf_tmpl = Bool
is_value Bool -> CoreExpr -> CoreExpr
`seq`
Bool
is_conlike Bool -> CoreExpr -> CoreExpr
`seq`
Bool
is_work_free Bool -> CoreExpr -> CoreExpr
`seq`
Bool
is_expandable Bool -> CoreExpr -> CoreExpr
`seq`
CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
expr,
uf_src :: UnfoldingSource
uf_src = UnfoldingSource
src,
uf_is_top :: Bool
uf_is_top = Bool
top_lvl,
uf_is_value :: Bool
uf_is_value = Bool
is_value,
uf_is_conlike :: Bool
uf_is_conlike = Bool
is_conlike,
uf_is_work_free :: Bool
uf_is_work_free = Bool
is_work_free,
uf_expandable :: Bool
uf_expandable = Bool
is_expandable,
uf_guidance :: UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance }
certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding
certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding
certainlyWillInline UnfoldingOpts
opts IdInfo
fn_info CoreExpr
rhs'
= case Unfolding
fn_unf of
CoreUnfolding { uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src }
| Bool
noinline -> Maybe Unfolding
forall a. Maybe a
Nothing
| Bool
otherwise
-> case UnfoldingGuidance
guidance of
UnfoldingGuidance
UnfNever -> Maybe Unfolding
forall a. Maybe a
Nothing
UnfWhen {} -> Unfolding -> Maybe Unfolding
forall a. a -> Maybe a
Just (Unfolding
fn_unf { uf_src :: UnfoldingSource
uf_src = UnfoldingSource
src', uf_tmpl :: CoreExpr
uf_tmpl = CoreExpr
tmpl' })
UnfIfGoodArgs { ug_size :: UnfoldingGuidance -> Arity
ug_size = Arity
size, ug_args :: UnfoldingGuidance -> [Arity]
ug_args = [Arity]
args }
-> Arity -> [Arity] -> UnfoldingSource -> CoreExpr -> Maybe Unfolding
do_cunf Arity
size [Arity]
args UnfoldingSource
src' CoreExpr
tmpl'
where
src' :: UnfoldingSource
src' =
case UnfoldingSource
src of
UnfoldingSource
InlineCompulsory -> UnfoldingSource
InlineCompulsory
UnfoldingSource
_ -> UnfoldingSource
InlineStable
tmpl' :: CoreExpr
tmpl' =
case UnfoldingSource
src of
UnfoldingSource
InlineRhs -> CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
rhs'
UnfoldingSource
_ -> Unfolding -> CoreExpr
uf_tmpl Unfolding
fn_unf
DFunUnfolding {} -> Unfolding -> Maybe Unfolding
forall a. a -> Maybe a
Just Unfolding
fn_unf
Unfolding
_other_unf -> Maybe Unfolding
forall a. Maybe a
Nothing
where
noinline :: Bool
noinline = InlinePragma -> Bool
isNoInlinePragma (IdInfo -> InlinePragma
inlinePragInfo IdInfo
fn_info)
fn_unf :: Unfolding
fn_unf = IdInfo -> Unfolding
unfoldingInfo IdInfo
fn_info
do_cunf :: Arity -> [Arity] -> UnfoldingSource -> CoreExpr -> Maybe Unfolding
do_cunf Arity
size [Arity]
args UnfoldingSource
src' CoreExpr
tmpl'
| IdInfo -> Arity
arityInfo IdInfo
fn_info Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
0
, Bool -> Bool
not (DmdSig -> Bool
isDeadEndSig (IdInfo -> DmdSig
dmdSigInfo IdInfo
fn_info))
, let unf_arity :: Arity
unf_arity = [Arity] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Arity]
args
, Arity
size Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- (Arity
10 Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
* (Arity
unf_arity Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1)) Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= UnfoldingOpts -> Arity
unfoldingUseThreshold UnfoldingOpts
opts
= Unfolding -> Maybe Unfolding
forall a. a -> Maybe a
Just (Unfolding
fn_unf { uf_src :: UnfoldingSource
uf_src = UnfoldingSource
src'
, uf_tmpl :: CoreExpr
uf_tmpl = CoreExpr
tmpl'
, uf_guidance :: UnfoldingGuidance
uf_guidance = UnfWhen :: Arity -> Bool -> Bool -> UnfoldingGuidance
UnfWhen { ug_arity :: Arity
ug_arity = Arity
unf_arity
, ug_unsat_ok :: Bool
ug_unsat_ok = Bool
unSaturatedOk
, ug_boring_ok :: Bool
ug_boring_ok = CoreExpr -> Bool
inlineBoringOk CoreExpr
tmpl' } })
| Bool
otherwise
= Maybe Unfolding
forall a. Maybe a
Nothing