{-# LANGUAGE CPP #-}
module GHC.Core.Unfold.Make
( noUnfolding
, mkUnfolding
, mkCoreUnfolding
, mkFinalUnfolding
, mkSimpleUnfolding
, mkWorkerUnfolding
, mkInlineUnfolding
, mkInlineUnfoldingWithArity
, mkInlinableUnfolding
, mkWwInlineRule
, mkCompulsoryUnfolding
, mkCompulsoryUnfolding'
, mkDFunUnfolding
, specUnfolding
)
where
#include "GhclibHsVersions.h"
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.Demand ( StrictSig, isDeadEndSig )
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import {-# SOURCE #-} GHC.Core.SimpleOpt
mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
mkFinalUnfolding :: UnfoldingOpts
-> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
mkFinalUnfolding UnfoldingOpts
opts UnfoldingSource
src StrictSig
strict_sig CoreExpr
expr
= UnfoldingOpts
-> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
mkUnfolding UnfoldingOpts
opts UnfoldingSource
src
Bool
True
(StrictSig -> Bool
isDeadEndSig StrictSig
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 }
mkWwInlineRule :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
mkWwInlineRule :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
mkWwInlineRule 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 })
= ASSERT2( rule_lhs_args `equalLength` old_bndrs
, ppr df $$ ppr rule_lhs_args )
[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
= CoreUnfolding :: CoreExpr
-> UnfoldingSource
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> UnfoldingGuidance
-> Unfolding
CoreUnfolding { uf_tmpl :: CoreExpr
uf_tmpl = 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 = CoreExpr -> Bool
exprIsHNF CoreExpr
expr,
uf_is_conlike :: Bool
uf_is_conlike = CoreExpr -> Bool
exprIsConLike CoreExpr
expr,
uf_is_work_free :: Bool
uf_is_work_free = CoreExpr -> Bool
exprIsWorkFree CoreExpr
expr,
uf_expandable :: Bool
uf_expandable = CoreExpr -> Bool
exprIsExpandable CoreExpr
expr,
uf_guidance :: UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance }