summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-06-16 12:30:22 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-09-09 11:19:24 -0400
commit3f32a9c0f4ddceab14a381bfd3732bcad6be43f7 (patch)
tree8e78c5b1681bf9ffd92e4fdb6a9134bb60ac05c8
parent8c892689058912c35ed36e07b5a9ed0df86abc03 (diff)
downloadhaskell-3f32a9c0f4ddceab14a381bfd3732bcad6be43f7.tar.gz
DynFlags: add UnfoldingOpts and SimpleOpts
Milestone: after this patch, we only use 'unsafeGlobalDynFlags' for the state hack and for debug in Outputable.
-rw-r--r--compiler/GHC.hs1
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs2
-rw-r--r--compiler/GHC/Core/Opt/LiberateCase.hs48
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs2
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs3
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs26
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Env.hs7
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Monad.hs8
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs13
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs6
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs6
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs13
-rw-r--r--compiler/GHC/Core/SimpleOpt.hs85
-rw-r--r--compiler/GHC/Core/SimpleOpt.hs-boot11
-rw-r--r--compiler/GHC/Core/Unfold.hs400
-rw-r--r--compiler/GHC/Core/Unfold.hs-boot21
-rw-r--r--compiler/GHC/Core/Unfold/Make.hs311
-rw-r--r--compiler/GHC/Driver/Backpack.hs1
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs1
-rw-r--r--compiler/GHC/Driver/Config.hs25
-rw-r--r--compiler/GHC/Driver/Finder.hs1
-rw-r--r--compiler/GHC/Driver/Main.hs1
-rw-r--r--compiler/GHC/Driver/Make.hs1
-rw-r--r--compiler/GHC/Driver/Pipeline.hs1
-rw-r--r--compiler/GHC/Driver/Session.hs41
-rw-r--r--compiler/GHC/Driver/Types.hs1
-rw-r--r--compiler/GHC/HsToCore.hs15
-rw-r--r--compiler/GHC/HsToCore/Binds.hs20
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs8
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Oracle.hs5
-rw-r--r--compiler/GHC/HsToCore/Usage.hs1
-rw-r--r--compiler/GHC/Iface/Rename.hs1
-rw-r--r--compiler/GHC/Iface/Tidy.hs34
-rw-r--r--compiler/GHC/IfaceToCore.hs8
-rw-r--r--compiler/GHC/SysTools.hs1
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs5
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs1
-rw-r--r--compiler/GHC/Types/Id/Make.hs20
-rw-r--r--compiler/GHC/Unit.hs3
-rw-r--r--compiler/GHC/Unit/State.hs-boot3
-rw-r--r--compiler/ghc.cabal.in2
-rw-r--r--ghc/GHCi/UI.hs1
-rw-r--r--testsuite/tests/parser/should_run/CountParserDeps.hs2
43 files changed, 675 insertions, 491 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index bd3f0b6d9f..e92f7f16aa 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -313,6 +313,7 @@ import GHC.Iface.Load ( loadSysInterface )
import GHC.Tc.Types
import GHC.Core.Predicate
import GHC.Unit
+import GHC.Unit.State
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Hs
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index eaf7aa65e4..892dd445f9 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -48,7 +48,7 @@ import GHC.Core.TyCon
import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType
, stripTicksTop, stripTicksTopT, mkTicks )
-import GHC.Core.Unfold ( exprIsConApp_maybe )
+import GHC.Core.SimpleOpt ( exprIsConApp_maybe )
import GHC.Core.Multiplicity
import GHC.Core.FVs
import GHC.Core.Type
diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs
index 211fc39920..1405e6acd2 100644
--- a/compiler/GHC/Core/Opt/LiberateCase.hs
+++ b/compiler/GHC/Core/Opt/LiberateCase.hs
@@ -13,7 +13,7 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Core
-import GHC.Core.Unfold ( couldBeSmallEnoughToInline )
+import GHC.Core.Unfold
import GHC.Builtin.Types ( unitDataConId )
import GHC.Types.Id
import GHC.Types.Var.Env
@@ -104,13 +104,24 @@ and the level of @h@ is zero (NB not one).
-}
liberateCase :: DynFlags -> CoreProgram -> CoreProgram
-liberateCase dflags binds = do_prog (initEnv dflags) binds
+liberateCase dflags binds = do_prog (initLiberateCaseEnv dflags) binds
where
do_prog _ [] = []
do_prog env (bind:binds) = bind' : do_prog env' binds
where
(env', bind') = libCaseBind env bind
+
+initLiberateCaseEnv :: DynFlags -> LibCaseEnv
+initLiberateCaseEnv dflags = LibCaseEnv
+ { lc_threshold = liberateCaseThreshold dflags
+ , lc_uf_opts = unfoldingOpts dflags
+ , lc_lvl = 0
+ , lc_lvl_env = emptyVarEnv
+ , lc_rec_env = emptyVarEnv
+ , lc_scruts = []
+ }
+
{-
************************************************************************
* *
@@ -152,9 +163,9 @@ libCaseBind env (Rec pairs)
-- size, build a fake binding (let { dup_pairs } in (),
-- and find the size of that
-- See Note [Small enough]
- small_enough = case bombOutSize env of
+ small_enough = case lc_threshold env of
Nothing -> True -- Infinity
- Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $
+ Just size -> couldBeSmallEnoughToInline (lc_uf_opts env) size $
Let (Rec dup_pairs) (Var unitDataConId)
ok_pair (id,_)
@@ -392,23 +403,28 @@ topLevel = 0
data LibCaseEnv
= LibCaseEnv {
- lc_dflags :: DynFlags,
+ lc_threshold :: Maybe Int,
+ -- ^ Bomb-out size for deciding if potential liberatees are too
+ -- big.
- lc_lvl :: LibCaseLevel, -- Current level
+ lc_uf_opts :: UnfoldingOpts,
+ -- ^ Unfolding options
+
+ lc_lvl :: LibCaseLevel, -- ^ Current level
-- The level is incremented when (and only when) going
-- inside the RHS of a (sufficiently small) recursive
-- function.
lc_lvl_env :: IdEnv LibCaseLevel,
- -- Binds all non-top-level in-scope Ids (top-level and
+ -- ^ Binds all non-top-level in-scope Ids (top-level and
-- imported things have a level of zero)
lc_rec_env :: IdEnv CoreBind,
- -- Binds *only* recursively defined ids, to their own
+ -- ^ Binds *only* recursively defined ids, to their own
-- binding group, and *only* in their own RHSs
lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
- -- Each of these Ids was scrutinised by an enclosing
+ -- ^ Each of these Ids was scrutinised by an enclosing
-- case expression, at a level deeper than its binding
-- level.
--
@@ -426,17 +442,3 @@ data LibCaseEnv
-- although that'd be unusual:
-- case x of { (a,b) -> ....(case x of ...) .. }
}
-
-initEnv :: DynFlags -> LibCaseEnv
-initEnv dflags
- = LibCaseEnv { lc_dflags = dflags,
- lc_lvl = 0,
- lc_lvl_env = emptyVarEnv,
- lc_rec_env = emptyVarEnv,
- lc_scruts = [] }
-
--- Bomb-out size for deciding if
--- potential liberatees are too big.
--- (passed in from cmd-line args)
-bombOutSize :: LibCaseEnv -> Maybe Int
-bombOutSize = liberateCaseThreshold . lc_dflags
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 7e37592878..9eddb64ce5 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -51,6 +51,7 @@ module GHC.Core.Opt.Monad (
import GHC.Prelude hiding ( read )
import GHC.Core
+import GHC.Core.Unfold
import GHC.Driver.Types
import GHC.Unit.Module
import GHC.Driver.Session
@@ -160,6 +161,7 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
, sm_phase :: CompilerPhase
, sm_dflags :: DynFlags -- Just for convenient non-monadic
-- access; we don't override these
+ , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
, sm_rules :: Bool -- Whether RULES are enabled
, sm_inline :: Bool -- Whether inlining is enabled
, sm_case_case :: Bool -- Whether case-of-case is enabled
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 1a308d11af..a44a81480e 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -16,7 +16,7 @@ import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Core
import GHC.Driver.Types
-import GHC.Core.Opt.CSE ( cseProgram )
+import GHC.Core.Opt.CSE ( cseProgram )
import GHC.Core.Rules ( mkRuleBase, unionRuleBase,
extendRuleBaseList, ruleCheckProgram, addRuleInfo,
getRules, initRuleOpts )
@@ -154,6 +154,7 @@ getCoreToDo dflags
base_mode = SimplMode { sm_phase = panic "base_mode"
, sm_names = []
, sm_dflags = dflags
+ , sm_uf_opts = unfoldingOpts dflags
, sm_rules = rules_on
, sm_eta_expand = eta_expand_on
, sm_inline = True
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index d0477f505a..1e8b9178d7 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -16,6 +16,8 @@ import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Driver.Ppr
+import GHC.Driver.Config
+import GHC.Core.SimpleOpt ( exprIsConApp_maybe )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
import GHC.Core.Opt.Simplify.Env
@@ -46,6 +48,7 @@ import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Types.Unique ( hasKey )
import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType
, idArityType, etaExpandAT )
@@ -341,7 +344,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
else -- Do type-abstraction first
{-#SCC "simplLazyBind-type-abstraction-first" #-}
do { tick LetFloatFromLet
- ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl
+ ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl
tvs' body_floats2 body2
; let floats = foldl' extendFloats (emptyFloats env) poly_binds
; rhs' <- mkLam env tvs' body3 rhs_cont
@@ -675,7 +678,7 @@ makeTrivialBinding mode top_lvl occ_fs info expr expr_ty
-- Now something very like completeBind,
-- but without the postInlineUnconditionally part
; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1
- ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2
+ ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2
; let final_id = addLetBndrInfo var arity_type unf
bind = NonRec final_id expr2
@@ -3008,7 +3011,7 @@ addAltUnfoldings env scrut case_bndr con_app
; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
; return env2 }
where
- mk_simple_unf = mkSimpleUnfolding (seDynFlags env)
+ mk_simple_unf = mkSimpleUnfolding (seUnfoldingOpts env)
addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
addBinderUnfolding env bndr unf
@@ -3431,7 +3434,8 @@ mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs')
= return (jfloats, (con, bndrs', rhs'))
| otherwise
- = do { let rhs_ty' = exprType rhs'
+ = do { simpl_opts <- initSimpleOptOpts <$> getDynFlags
+ ; let rhs_ty' = exprType rhs'
scrut_ty = idType case_bndr
case_bndr_w_unf
= case con of
@@ -3439,7 +3443,7 @@ mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs')
DataAlt dc -> setIdUnfolding case_bndr unf
where
-- See Note [Case binders and join points]
- unf = mkInlineUnfolding rhs
+ unf = mkInlineUnfolding simpl_opts rhs
rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
LitAlt {} -> WARN( True, text "mkDupableAlt"
@@ -3778,14 +3782,14 @@ simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf
| isExitJoinId id
= return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify
| otherwise
- = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs
+ = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs
-------------------
-mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource
+mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
-> InId -> OutExpr -> SimplM Unfolding
-mkLetUnfolding dflags top_lvl src id new_rhs
+mkLetUnfolding uf_opts top_lvl src id new_rhs
= is_bottoming `seq` -- See Note [Force bottoming field]
- return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)
+ return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)
-- We make an unfolding *even for loop-breakers*.
-- Reason: (a) It might be useful to know that they are WHNF
-- (b) In GHC.Iface.Tidy we currently assume that, if we want to
@@ -3848,14 +3852,14 @@ simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf
-- See Note [Top-level flag on inline rules] in GHC.Core.Unfold
_other -- Happens for INLINABLE things
- -> mkLetUnfolding dflags top_lvl src id expr' }
+ -> mkLetUnfolding uf_opts top_lvl src id expr' }
-- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-- unfolding, and we need to make sure the guidance is kept up
-- to date with respect to any changes in the unfolding.
| otherwise -> return noUnfolding -- Discard unstable unfoldings
where
- dflags = seDynFlags env
+ uf_opts = seUnfoldingOpts env
is_top_lvl = isTopLevel top_lvl
act = idInlineActivation id
unf_env = updMode (updModeForStableUnfoldings act) env
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index b0245162ee..4ceaf637ed 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -8,7 +8,7 @@
module GHC.Core.Opt.Simplify.Env (
-- * The simplifier mode
- setMode, getMode, updMode, seDynFlags,
+ setMode, getMode, updMode, seDynFlags, seUnfoldingOpts,
-- * Environments
SimplEnv(..), pprSimplEnv, -- Temp not abstract
@@ -52,6 +52,7 @@ import GHC.Core.Opt.Monad ( SimplMode(..) )
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Multiplicity ( scaleScaled )
+import GHC.Core.Unfold
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
@@ -309,6 +310,10 @@ getMode env = seMode env
seDynFlags :: SimplEnv -> DynFlags
seDynFlags env = sm_dflags (seMode env)
+seUnfoldingOpts :: SimplEnv -> UnfoldingOpts
+seUnfoldingOpts env = sm_uf_opts (seMode env)
+
+
setMode :: SimplMode -> SimplEnv -> SimplEnv
setMode mode env = env { seMode = mode }
diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index 9fc51af32e..620db9da22 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -34,6 +34,7 @@ import GHC.Core.Utils ( mkLamTypes )
import GHC.Core.Coercion.Opt
import GHC.Types.Unique.Supply
import GHC.Driver.Session
+import GHC.Driver.Config
import GHC.Core.Opt.Monad
import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -98,12 +99,11 @@ initSmpl dflags rules fam_envs us size m
= do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
return (result, count)
where
- env = STE { st_flags = dflags, st_rules = rules
+ env = STE { st_flags = dflags
+ , st_rules = rules
, st_max_ticks = computeMaxTicks dflags size
, st_fams = fam_envs
- , st_co_opt_opts = OptCoercionOpts
- { optCoercionEnabled = not (hasNoOptCoercion dflags)
- }
+ , st_co_opt_opts = initOptCoercionOpts dflags
}
computeMaxTicks :: DynFlags -> Int -> IntWithInf
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index febd937fdf..2b5d37946c 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -53,6 +53,7 @@ import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -862,6 +863,7 @@ simplEnvForGHCi dflags
= mkSimplEnv $ SimplMode { sm_names = ["GHCi"]
, sm_phase = InitialPhase
, sm_dflags = dflags
+ , sm_uf_opts = uf_opts
, sm_rules = rules_on
, sm_inline = False
, sm_eta_expand = eta_expand_on
@@ -869,6 +871,7 @@ simplEnvForGHCi dflags
where
rules_on = gopt Opt_EnableRewriteRules dflags
eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
+ uf_opts = unfoldingOpts dflags
-- Do not do any inlining, in case we expose some unboxed
-- tuple stuff that confuses the bytecode interpreter
@@ -1370,7 +1373,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs
-> n_br < 100 -- See Note [Suppress exponential blowup]
- && smallEnoughToInline dflags unfolding -- Small enough to dup
+ && smallEnoughToInline uf_opts unfolding -- Small enough to dup
-- ToDo: consider discount on smallEnoughToInline if int_cxt is true
--
-- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1
@@ -1416,7 +1419,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs
where
unfolding = idUnfolding bndr
- dflags = seDynFlags env
+ uf_opts = seUnfoldingOpts env
active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
-- See Note [pre/postInlineUnconditionally in gentle mode]
@@ -1908,9 +1911,9 @@ new binding is abstracted. Note that
which is obviously bogus.
-}
-abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats
+abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
-> OutExpr -> SimplM ([OutBind], OutExpr)
-abstractFloats dflags top_lvl main_tvs floats body
+abstractFloats uf_opts top_lvl main_tvs floats body
= ASSERT( notNull body_floats )
ASSERT( isNilOL (sfJoinFloats floats) )
do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
@@ -1986,7 +1989,7 @@ abstractFloats dflags top_lvl main_tvs floats body
= (poly_id `setIdUnfolding` unf, poly_rhs)
where
poly_rhs = mkLams tvs_here rhs
- unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs
+ unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs
-- We want the unfolding. Consider
-- let
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 6f7d61894e..30645a0259 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -21,7 +21,7 @@ import GHC.Prelude
import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
-import GHC.Core.Unfold ( couldBeSmallEnoughToInline )
+import GHC.Core.Unfold
import GHC.Core.FVs ( exprsFreeVarsList )
import GHC.Core.Opt.Monad
import GHC.Types.Literal ( litIsLifted )
@@ -783,6 +783,7 @@ the function is applied to a data constructor.
-}
data ScEnv = SCE { sc_dflags :: DynFlags,
+ sc_uf_opts :: !UnfoldingOpts, -- ^ Unfolding options
sc_module :: !Module,
sc_size :: Maybe Int, -- Size threshold
-- Nothing => no limit
@@ -835,6 +836,7 @@ instance Outputable Value where
initScEnv :: DynFlags -> Module -> ScEnv
initScEnv dflags this_mod
= SCE { sc_dflags = dflags,
+ sc_uf_opts = unfoldingOpts dflags,
sc_module = this_mod,
sc_size = specConstrThreshold dflags,
sc_count = specConstrCount dflags,
@@ -1364,7 +1366,7 @@ scTopBind _ usage _
scTopBind env body_usage (Rec prs)
| Just threshold <- sc_size env
, not force_spec
- , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)
+ , not (all (couldBeSmallEnoughToInline (sc_uf_opts env) threshold) rhss)
-- No specialisation
= -- pprTrace "scTopBind: nospec" (ppr bndrs) $
do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index a002630c08..ef83426326 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -26,6 +26,7 @@ import GHC.Core.Coercion( Coercion )
import GHC.Core.Opt.Monad
import qualified GHC.Core.Subst as Core
import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Types.Var ( isLocalVar )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
@@ -47,6 +48,7 @@ import GHC.Driver.Types
import GHC.Data.Bag
import GHC.Driver.Session
import GHC.Driver.Ppr
+import GHC.Driver.Config
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -1478,6 +1480,8 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- See Note [Specialising Calls]
spec_uds = foldr consDictBind rhs_uds dx_binds
+ simpl_opts = initSimpleOptOpts dflags
+
--------------------------------------
-- Add a suitable unfolding if the spec_inl_prag says so
-- See Note [Inline specialisations]
@@ -1490,7 +1494,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
= (inl_prag { inl_inline = NoUserInline }, noUnfolding)
| otherwise
- = (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args)
+ = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)
rule_lhs_args fn_unf)
--------------------------------------
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index b1af5f9d62..4c58ef911e 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -11,7 +11,8 @@ import GHC.Prelude
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core
-import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )
+import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.Utils ( exprType, exprIsHNF )
import GHC.Core.FVs ( exprFreeVars )
import GHC.Types.Var
@@ -22,6 +23,7 @@ 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.Core.Opt.WorkWrap.Utils
@@ -467,7 +469,7 @@ tryWW :: DynFlags
tryWW dflags fam_envs is_rec fn_id rhs
-- See Note [Worker-wrapper for NOINLINE functions]
- | Just stable_unf <- certainlyWillInline dflags fn_info
+ | Just stable_unf <- certainlyWillInline uf_opts fn_info
= return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]
-- See Note [Don't w/w INLINE things]
-- See Note [Don't w/w inline small non-loop-breaker things]
@@ -482,6 +484,7 @@ tryWW dflags fam_envs is_rec fn_id rhs
= return [ (new_fn_id, rhs) ]
where
+ uf_opts = unfoldingOpts dflags
fn_info = idInfo fn_id
(wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info)
@@ -602,6 +605,8 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
-- worker is join point iff wrapper is join point
-- (see Note [Don't w/w join points for CPR])
+ simpl_opts = initSimpleOptOpts dflags
+
work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
`setIdOccInfo` occInfo fn_info
-- Copy over occurrence info from parent
@@ -611,7 +616,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
`setInlinePragma` work_prag
- `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding
+ `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding
-- See Note [Worker-wrapper for INLINABLE functions]
`setIdStrictness` mkClosedStrictSig work_demands div
@@ -637,7 +642,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
wrap_rhs = wrap_fn work_id
wrap_prag = mkStrWrapperInlinePrag fn_inl_prag
- wrap_id = fn_id `setIdUnfolding` mkWwInlineRule dflags wrap_rhs arity
+ wrap_id = fn_id `setIdUnfolding` mkWwInlineRule simpl_opts wrap_rhs arity
`setInlinePragma` wrap_prag
`setIdOccInfo` noOccInfo
-- Zap any loop-breaker-ness, to avoid bleating from Lint
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 300588e0fc..e72b6073b4 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -7,6 +7,8 @@
{-# LANGUAGE MultiWayIf #-}
module GHC.Core.SimpleOpt (
+ SimpleOptOpts (..), defaultSimpleOptOpts,
+
-- ** Simple expression optimiser
simpleOptPgm, simpleOptExpr, simpleOptExprWith,
@@ -30,9 +32,9 @@ import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.FVs
-import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding )
+import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.Make ( FloatBind(..) )
-import GHC.Core.Ppr ( pprCoreBindings, pprRules )
import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import GHC.Types.Literal
import GHC.Types.Id
@@ -52,8 +54,6 @@ import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Unit.Module ( Module )
-import GHC.Utils.Error
-import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -95,7 +95,27 @@ little dance in action; the full Simplifier is a lot more complicated.
-}
-simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr
+-- | Simple optimiser options
+data SimpleOptOpts = SimpleOptOpts
+ { so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
+ , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
+ }
+
+-- | Default options for the Simple optimiser.
+--
+-- These are used:
+-- - to optimise compulsory unfolding in 'GHC.Core.Unfold.mkCompulsoryUnfolding'
+-- - to perform beta-reduction in 'exprIsLambda_maybe'
+--
+-- For now these can't be overriden by user flags.
+defaultSimpleOptOpts :: SimpleOptOpts
+defaultSimpleOptOpts = SimpleOptOpts
+ { so_uf_opts = defaultUnfoldingOpts
+ , so_co_opts = OptCoercionOpts
+ { optCoercionEnabled = False }
+ }
+
+simpleOptExpr :: HasDebugCallStack => SimpleOptOpts -> CoreExpr -> CoreExpr
-- See Note [The simple optimiser]
-- Do simple optimisation on an expression
-- The optimisation is very straightforward: just
@@ -112,9 +132,9 @@ simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr
-- in (let x = y in ....) we substitute for x; so y's occ-info
-- may change radically
-simpleOptExpr dflags expr
+simpleOptExpr opts expr
= -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
- simpleOptExprWith dflags init_subst expr
+ simpleOptExprWith opts init_subst expr
where
init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
-- It's potentially important to make a proper in-scope set
@@ -127,30 +147,29 @@ simpleOptExpr dflags expr
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
-simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr
+simpleOptExprWith :: HasDebugCallStack => SimpleOptOpts -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
-simpleOptExprWith dflags subst expr
+simpleOptExprWith opts subst expr
= simple_opt_expr init_env (occurAnalyseExpr expr)
where
- init_env = (emptyEnv dflags) { soe_subst = subst }
+ init_env = (emptyEnv opts) { soe_subst = subst }
----------------------
-simpleOptPgm :: DynFlags -> Module
- -> CoreProgram -> [CoreRule]
- -> IO (CoreProgram, [CoreRule])
+simpleOptPgm :: SimpleOptOpts
+ -> Module
+ -> CoreProgram
+ -> [CoreRule]
+ -> (CoreProgram, [CoreRule], CoreProgram)
-- See Note [The simple optimiser]
-simpleOptPgm dflags this_mod binds rules
- = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
- FormatCore (pprCoreBindings occ_anald_binds $$ pprRules rules );
-
- ; return (reverse binds', rules') }
+simpleOptPgm opts this_mod binds rules =
+ (reverse binds', rules', occ_anald_binds)
where
occ_anald_binds = occurAnalysePgm this_mod
(\_ -> True) {- All unfoldings active -}
(\_ -> False) {- No rules active -}
rules binds
- (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds
+ (final_env, binds') = foldl' do_one (emptyEnv opts, []) occ_anald_binds
final_subst = soe_subst final_env
rules' = substRulesForImportedIds final_subst rules
@@ -168,10 +187,12 @@ simpleOptPgm dflags this_mod binds rules
type SimpleClo = (SimpleOptEnv, InExpr)
data SimpleOptEnv
- = SOE { soe_dflags :: DynFlags
- , soe_co_opt_opts :: !OptCoercionOpts
+ = SOE { soe_co_opt_opts :: !OptCoercionOpts
-- ^ Options for the coercion optimiser
+ , soe_uf_opts :: !UnfoldingOpts
+ -- ^ Unfolding options
+
, soe_inl :: IdEnv SimpleClo
-- ^ Deals with preInlineUnconditionally; things
-- that occur exactly once and are inlined
@@ -187,15 +208,13 @@ instance Outputable SimpleOptEnv where
, text "soe_subst =" <+> ppr subst ]
<+> text "}"
-emptyEnv :: DynFlags -> SimpleOptEnv
-emptyEnv dflags
- = SOE { soe_dflags = dflags
- , soe_inl = emptyVarEnv
- , soe_subst = emptySubst
- , soe_co_opt_opts = OptCoercionOpts
- { optCoercionEnabled = not (hasNoOptCoercion dflags)
- }
- }
+emptyEnv :: SimpleOptOpts -> SimpleOptEnv
+emptyEnv opts = SOE
+ { soe_inl = emptyVarEnv
+ , soe_subst = emptySubst
+ , soe_co_opt_opts = so_co_opts opts
+ , soe_uf_opts = so_uf_opts opts
+ }
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst env@(SOE { soe_subst = subst })
@@ -629,7 +648,7 @@ add_info env old_bndr top_level new_rhs new_bndr
| otherwise = lazySetIdInfo new_bndr new_info
where
subst = soe_subst env
- dflags = soe_dflags env
+ uf_opts = soe_uf_opts env
old_info = idInfo old_bndr
-- Add back in the rules and unfolding which were
@@ -648,7 +667,7 @@ add_info env old_bndr top_level new_rhs new_bndr
| otherwise
= unfolding_from_rhs
- unfolding_from_rhs = mkUnfolding dflags InlineRhs
+ unfolding_from_rhs = mkUnfolding uf_opts InlineRhs
(isTopLevel top_level)
False -- may be bottom or not
new_rhs
@@ -1317,7 +1336,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) e
-- Make sure there is hope to get a lambda
, Just rhs <- expandUnfolding_maybe (id_unf f)
-- Optimize, for beta-reduction
- , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as)
+ , let e' = simpleOptExprWith defaultSimpleOptOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-- Recurse, because of possible casts
, Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
, let res = Just (x', e'', ts++ts')
diff --git a/compiler/GHC/Core/SimpleOpt.hs-boot b/compiler/GHC/Core/SimpleOpt.hs-boot
new file mode 100644
index 0000000000..7a708eb4c8
--- /dev/null
+++ b/compiler/GHC/Core/SimpleOpt.hs-boot
@@ -0,0 +1,11 @@
+module GHC.Core.SimpleOpt where
+
+import GHC.Core
+import {-# SOURCE #-} GHC.Core.Unfold
+import GHC.Utils.Misc (HasDebugCallStack)
+
+data SimpleOptOpts
+
+so_uf_opts :: SimpleOptOpts -> UnfoldingOpts
+
+simpleOptExpr :: HasDebugCallStack => SimpleOptOpts -> CoreExpr -> CoreExpr
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index ea778f5a2d..414d5184f4 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -22,13 +22,10 @@ find, unsurprisingly, a Core expression.
module GHC.Core.Unfold (
Unfolding, UnfoldingGuidance, -- Abstract types
- noUnfolding,
- mkUnfolding, mkCoreUnfolding,
- mkFinalUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
- mkInlineUnfolding, mkInlineUnfoldingWithArity,
- mkInlinableUnfolding, mkWwInlineRule,
- mkCompulsoryUnfolding, mkDFunUnfolding,
- specUnfolding,
+ UnfoldingOpts (..), defaultUnfoldingOpts,
+ updateCreationThreshold, updateUseThreshold,
+ updateFunAppDiscount, updateDictDiscount,
+ updateVeryAggressive,
ArgSummary(..),
@@ -36,10 +33,7 @@ module GHC.Core.Unfold (
certainlyWillInline, smallEnoughToInline,
callSiteInline, CallCtxt(..),
-
- -- Reexport from GHC.Core.Subst (it only live there so it can be used
- -- by the Very Simple Optimiser)
- exprIsConApp_maybe, exprIsLiteral_maybe
+ calcUnfoldingGuidance
) where
#include "HsVersions.h"
@@ -49,12 +43,9 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Core
-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
-import GHC.Core.SimpleOpt
-import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core.Utils
import GHC.Types.Id
-import GHC.Types.Demand ( StrictSig, isDeadEndSig )
+import GHC.Types.Demand ( isDeadEndSig )
import GHC.Core.DataCon
import GHC.Types.Literal
import GHC.Builtin.PrimOps
@@ -66,7 +57,6 @@ import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Utils.Outputable
-import GHC.Utils.Panic
import GHC.Types.ForeignCall
import GHC.Types.Name
import GHC.Utils.Error
@@ -74,275 +64,65 @@ import GHC.Utils.Error
import qualified Data.ByteString as BS
import Data.List
-{-
-************************************************************************
-* *
-\subsection{Making unfoldings}
-* *
-************************************************************************
--}
-mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
--- "Final" in the sense that this is a GlobalId that will not be further
--- simplified; so the unfolding should be occurrence-analysed
-mkFinalUnfolding dflags src strict_sig expr
- = mkUnfolding dflags src
- True {- Top level -}
- (isDeadEndSig strict_sig)
- expr
-
-mkCompulsoryUnfolding :: CoreExpr -> Unfolding
-mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
- = mkCoreUnfolding InlineCompulsory True
- (simpleOptExpr unsafeGlobalDynFlags expr)
- (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
- , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
-
-
--- Note [Top-level flag on inline rules]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Slight hack: note that mk_inline_rules conservatively sets the
--- top-level flag to True. It gets set more accurately by the simplifier
--- Simplify.simplUnfolding.
-
-mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding
-mkSimpleUnfolding dflags rhs
- = mkUnfolding dflags InlineRhs False False rhs
-
-mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
-mkDFunUnfolding bndrs con ops
- = DFunUnfolding { df_bndrs = bndrs
- , df_con = con
- , df_args = map occurAnalyseExpr ops }
- -- See Note [Occurrence analysis of unfoldings]
-
-mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding
-mkWwInlineRule dflags expr arity
- = mkCoreUnfolding InlineStable True
- (simpleOptExpr dflags expr)
- (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk
- , ug_boring_ok = boringCxtNotOk })
-
-mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
--- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap
-mkWorkerUnfolding dflags work_fn
- (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
- , uf_is_top = top_lvl })
- | isStableSource src
- = mkCoreUnfolding src top_lvl new_tmpl guidance
- where
- new_tmpl = simpleOptExpr dflags (work_fn tmpl)
- guidance = calcUnfoldingGuidance dflags False new_tmpl
-
-mkWorkerUnfolding _ _ _ = noUnfolding
-
--- | Make an unfolding that may be used unsaturated
--- (ug_unsat_ok = unSaturatedOk) and that is reported as having its
--- manifest arity (the number of outer lambdas applications will
--- resolve before doing any work).
-mkInlineUnfolding :: CoreExpr -> Unfolding
-mkInlineUnfolding expr
- = mkCoreUnfolding InlineStable
- True -- Note [Top-level flag on inline rules]
- expr' guide
- where
- expr' = simpleOptExpr unsafeGlobalDynFlags expr
- guide = UnfWhen { ug_arity = manifestArity expr'
- , ug_unsat_ok = unSaturatedOk
- , ug_boring_ok = boring_ok }
- boring_ok = inlineBoringOk expr'
-
--- | Make an unfolding that will be used once the RHS has been saturated
--- to the given arity.
-mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding
-mkInlineUnfoldingWithArity arity expr
- = mkCoreUnfolding InlineStable
- True -- Note [Top-level flag on inline rules]
- expr' guide
- where
- expr' = simpleOptExpr unsafeGlobalDynFlags expr
- guide = UnfWhen { ug_arity = arity
- , ug_unsat_ok = needSaturated
- , ug_boring_ok = boring_ok }
- -- See Note [INLINE pragmas and boring contexts] as to why we need to look
- -- at the arity here.
- boring_ok | arity == 0 = True
- | otherwise = inlineBoringOk expr'
-
-mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding
-mkInlinableUnfolding dflags expr
- = mkUnfolding dflags InlineStable False False expr'
- where
- expr' = simpleOptExpr dflags expr
-
-specUnfolding :: DynFlags
- -> [Var] -> (CoreExpr -> CoreExpr)
- -> [CoreArg] -- LHS arguments in the RULE
- -> Unfolding -> Unfolding
--- See Note [Specialising unfoldings]
--- specUnfolding spec_bndrs spec_args unf
--- = \spec_bndrs. unf spec_args
---
-specUnfolding dflags spec_bndrs spec_app rule_lhs_args
- df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
- = ASSERT2( rule_lhs_args `equalLength` old_bndrs
- , ppr df $$ ppr rule_lhs_args )
- -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise
- mkDFunUnfolding spec_bndrs con (map spec_arg args)
- -- For DFunUnfoldings we transform
- -- \obs. MkD <op1> ... <opn>
- -- to
- -- \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>
- where
- spec_arg arg = simpleOptExpr dflags $
- spec_app (mkLams old_bndrs arg)
- -- The beta-redexes created by spec_app will be
- -- simplified away by simplOptExpr
-
-specUnfolding dflags spec_bndrs spec_app rule_lhs_args
- (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
- , uf_is_top = top_lvl
- , uf_guidance = old_guidance })
- | isStableSource src -- See Note [Specialising unfoldings]
- , UnfWhen { ug_arity = old_arity } <- old_guidance
- = mkCoreUnfolding src top_lvl new_tmpl
- (old_guidance { ug_arity = old_arity - arity_decrease })
- where
- new_tmpl = simpleOptExpr dflags $
- mkLams spec_bndrs $
- spec_app tmpl -- The beta-redexes created by spec_app
- -- will besimplified away by simplOptExpr
- arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs
+-- | Unfolding options
+data UnfoldingOpts = UnfoldingOpts
+ { unfoldingCreationThreshold :: !Int
+ -- ^ Threshold above which unfoldings are not *created*
+ , unfoldingUseThreshold :: !Int
+ -- ^ Threshold above which unfoldings are not *inlined*
-specUnfolding _ _ _ _ _ = noUnfolding
+ , unfoldingFunAppDiscount :: !Int
+ -- ^ Discount for lambdas that are used (applied)
-{- Note [Specialising unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we specialise a function for some given type-class arguments, we use
-specUnfolding to specialise its unfolding. Some important points:
-
-* If the original function has a DFunUnfolding, the specialised one
- must do so too! Otherwise we lose the magic rules that make it
- interact with ClassOps
-
-* There is a bit of hack for INLINABLE functions:
- f :: Ord a => ....
- f = <big-rhs>
- {- INLINABLE f #-}
- Now if we specialise f, should the specialised version still have
- an INLINABLE pragma? If it does, we'll capture a specialised copy
- of <big-rhs> as its unfolding, and that probably won't inline. But
- if we don't, the specialised version of <big-rhs> might be small
- enough to inline at a call site. This happens with Control.Monad.liftM3,
- and can cause a lot more allocation as a result (nofib n-body shows this).
-
- Moreover, keeping the INLINABLE thing isn't much help, because
- the specialised function (probably) isn't overloaded any more.
-
- Conclusion: drop the INLINEALE pragma. In practice what this means is:
- if a stable unfolding has UnfoldingGuidance of UnfWhen,
- we keep it (so the specialised thing too will always inline)
- if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs
- (which arises from INLINABLE), we discard it
-
-Note [Honour INLINE on 0-ary bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
- x = <expensive>
- {-# INLINE x #-}
+ , unfoldingDictDiscount :: !Int
+ -- ^ Discount for dictionaries
- f y = ...x...
+ , unfoldingVeryAggressive :: !Bool
+ -- ^ Force inlining in many more cases
+ }
-The semantics of an INLINE pragma is
+defaultUnfoldingOpts :: UnfoldingOpts
+defaultUnfoldingOpts = UnfoldingOpts
+ { unfoldingCreationThreshold = 750
+ -- The unfoldingCreationThreshold threshold must be reasonably high
+ -- to take account of possible discounts.
+ -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to
+ -- inline into Csg.calc (The unfolding for sqr never makes it
+ -- into the interface file.)
- inline x at every call site, provided it is saturated;
- that is, applied to at least as many arguments as appear
- on the LHS of the Haskell source definition.
+ , unfoldingUseThreshold = 90
+ -- Last adjusted upwards in #18282, when I reduced
+ -- the result discount for constructors.
-(This source-code-derived arity is stored in the `ug_arity` field of
-the `UnfoldingGuidance`.)
+ , unfoldingFunAppDiscount = 60
+ -- Be fairly keen to inline a function if that means
+ -- we'll be able to pick the right method from a dictionary
-In the example, x's ug_arity is 0, so we should inline it at every use
-site. It's rare to have such an INLINE pragma (usually INLINE Is on
-functions), but it's occasionally very important (#15578, #15519).
-In #15519 we had something like
- x = case (g a b) of I# r -> T r
- {-# INLINE x #-}
- f y = ...(h x)....
+ , unfoldingDictDiscount = 30
+ -- Be fairly keen to inline a function if that means
+ -- we'll be able to pick the right method from a dictionary
-where h is strict. So we got
- f y = ...(case g a b of I# r -> h (T r))...
+ , unfoldingVeryAggressive = False
+ }
-and that in turn allowed SpecConstr to ramp up performance.
+-- Helpers for "GHC.Driver.Session"
-How do we deliver on this? By adjusting the ug_boring_ok
-flag in mkInlineUnfoldingWithArity; see
-Note [INLINE pragmas and boring contexts]
+updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateCreationThreshold n opts = opts { unfoldingCreationThreshold = n }
-NB: there is a real risk that full laziness will float it right back
-out again. Consider again
- x = factorial 200
- {-# INLINE x #-}
- f y = ...x...
+updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateUseThreshold n opts = opts { unfoldingUseThreshold = n }
-After inlining we get
- f y = ...(factorial 200)...
+updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateFunAppDiscount n opts = opts { unfoldingFunAppDiscount = n }
-but it's entirely possible that full laziness will do
- lvl23 = factorial 200
- f y = ...lvl23...
-
-That's a problem for another day.
-
-Note [INLINE pragmas and boring contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An INLINE pragma uses mkInlineUnfoldingWithArity to build the
-unfolding. That sets the ug_boring_ok flag to False if the function
-is not tiny (inlineBoringOK), so that even INLINE functions are not
-inlined in an utterly boring context. E.g.
- \x y. Just (f y x)
-Nothing is gained by inlining f here, even if it has an INLINE
-pragma.
-
-But for 0-ary bindings, we want to inline regardless; see
-Note [Honour INLINE on 0-ary bindings].
-
-I'm a bit worried that it's possible for the same kind of problem
-to arise for non-0-ary functions too, but let's wait and see.
--}
-
-mkUnfolding :: DynFlags -> UnfoldingSource
- -> Bool -- Is top-level
- -> Bool -- Definitely a bottoming binding
- -- (only relevant for top-level bindings)
- -> CoreExpr
- -> Unfolding
--- Calculates unfolding guidance
--- Occurrence-analyses the expression before capturing it
-mkUnfolding dflags src top_lvl is_bottoming expr
- = mkCoreUnfolding src top_lvl expr guidance
- where
- is_top_bottoming = top_lvl && is_bottoming
- guidance = calcUnfoldingGuidance dflags is_top_bottoming expr
- -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
- -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
-
-mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
- -> UnfoldingGuidance -> Unfolding
--- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding src top_lvl expr guidance
- = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
- -- See Note [Occurrence analysis of unfoldings]
- uf_src = src,
- uf_is_top = top_lvl,
- uf_is_value = exprIsHNF expr,
- uf_is_conlike = exprIsConLike expr,
- uf_is_work_free = exprIsWorkFree expr,
- uf_expandable = exprIsExpandable expr,
- uf_guidance = guidance }
+updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateDictDiscount n opts = opts { unfoldingDictDiscount = n }
+updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts
+updateVeryAggressive n opts = opts { unfoldingVeryAggressive = n }
{-
Note [Occurrence analysis of unfoldings]
@@ -420,15 +200,15 @@ inlineBoringOk e
go _ _ = boringCxtNotOk
calcUnfoldingGuidance
- :: DynFlags
+ :: UnfoldingOpts
-> Bool -- Definitely a top-level, bottoming binding
-> CoreExpr -- Expression to look at
-> UnfoldingGuidance
-calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr)
+calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)
| not (tickishIsCode t) -- non-code ticks don't matter for unfolding
- = calcUnfoldingGuidance dflags is_top_bottoming expr
-calcUnfoldingGuidance dflags is_top_bottoming expr
- = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of
+ = calcUnfoldingGuidance opts is_top_bottoming expr
+calcUnfoldingGuidance opts is_top_bottoming expr
+ = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of
TooBig -> UnfNever
SizeIs size cased_bndrs scrut_discount
| uncondInline expr n_val_bndrs size
@@ -446,7 +226,7 @@ calcUnfoldingGuidance dflags is_top_bottoming expr
where
(bndrs, body) = collectBinders expr
- bOMB_OUT_SIZE = ufCreationThreshold dflags
+ bOMB_OUT_SIZE = unfoldingCreationThreshold opts
-- Bomb out if size gets bigger than this
val_bndrs = filter isId bndrs
n_val_bndrs = length val_bndrs
@@ -605,7 +385,7 @@ uncondInline rhs arity size
| arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)
| otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4)
-sizeExpr :: DynFlags
+sizeExpr :: UnfoldingOpts
-> Int -- Bomb out if it gets bigger than this
-> [Id] -- Arguments; we're interested in which of these
-- get case'd
@@ -614,7 +394,7 @@ sizeExpr :: DynFlags
-- Note [Computing the size of an expression]
-sizeExpr dflags bOMB_OUT_SIZE top_args expr
+sizeExpr opts bOMB_OUT_SIZE top_args expr
= size_up expr
where
size_up (Cast e _) = size_up e
@@ -633,7 +413,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0)
size_up (Lam b e)
- | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10)
+ | isId b && not (isRealWorldId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)
| otherwise = size_up e
size_up (Let (NonRec binder rhs) body)
@@ -754,8 +534,8 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
FCallId _ -> sizeN (callSize (length val_args) voids)
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op -> primOpSize op (length val_args)
- ClassOpId _ -> classOpSize dflags top_args val_args
- _ -> funSize dflags top_args fun (length val_args) voids
+ ClassOpId _ -> classOpSize opts top_args val_args
+ _ -> funSize opts top_args fun (length val_args) voids
------------
size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
@@ -819,11 +599,11 @@ litSize _other = 0 -- Must match size of nullary constructors
-- Key point: if x |-> 4, then x must inline unconditionally
-- (eg via case binding)
-classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize
+classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize
-- See Note [Conlike is interesting]
classOpSize _ _ []
= sizeZero
-classOpSize dflags top_args (arg1 : other_args)
+classOpSize opts top_args (arg1 : other_args)
= SizeIs size arg_discount 0
where
size = 20 + (10 * length other_args)
@@ -832,7 +612,7 @@ classOpSize dflags top_args (arg1 : other_args)
-- The actual discount is rather arbitrarily chosen
arg_discount = case arg1 of
Var dict | dict `elem` top_args
- -> unitBag (dict, ufDictDiscount dflags)
+ -> unitBag (dict, unfoldingDictDiscount opts)
_other -> emptyBag
-- | The size of a function call
@@ -856,10 +636,10 @@ jumpSize n_val_args voids = 2 * (1 + n_val_args - voids)
-- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a
-- better solution?
-funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize
+funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize
-- Size for functions that are not constructors or primops
-- Note [Function applications]
-funSize dflags top_args fun n_val_args voids
+funSize opts top_args fun n_val_args voids
| fun `hasKey` buildIdKey = buildSize
| fun `hasKey` augmentIdKey = augmentSize
| otherwise = SizeIs size arg_discount res_discount
@@ -874,12 +654,12 @@ funSize dflags top_args fun n_val_args voids
-- DISCOUNTS
-- See Note [Function and non-function discounts]
arg_discount | some_val_args && fun `elem` top_args
- = unitBag (fun, ufFunAppDiscount dflags)
+ = unitBag (fun, unfoldingFunAppDiscount opts)
| otherwise = emptyBag
-- If the function is an argument and is applied
-- to some values, give it an arg-discount
- res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags
+ res_discount | idArity fun > n_val_args = unfoldingFunAppDiscount opts
| otherwise = 0
-- If the function is partially applied, show a result discount
-- XXX maybe behave like ConSize for eval'd variable
@@ -1011,8 +791,8 @@ augmentSize = SizeIs 0 emptyBag 40
-- e plus ys. The -2 accounts for the \cn
-- When we return a lambda, give a discount if it's used (applied)
-lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize
-lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags)
+lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize
+lamScrutDiscount opts (SizeIs n vs _) = SizeIs n vs (unfoldingFunAppDiscount opts)
lamScrutDiscount _ TooBig = TooBig
{-
@@ -1027,30 +807,27 @@ binary sizes shrink significantly either.
Note [Discounts and thresholds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Constants for discounts and thesholds are defined in "GHC.Driver.Session",
-all of form ufXxxx. They are:
-ufCreationThreshold
+Constants for discounts and thesholds are defined in 'UnfoldingOpts'. They are:
+
+unfoldingCreationThreshold
At a definition site, if the unfolding is bigger than this, we
may discard it altogether
-ufUseThreshold
+unfoldingUseThreshold
At a call site, if the unfolding, less discounts, is smaller than
this, then it's small enough inline
-ufDictDiscount
+unfoldingDictDiscount
The discount for each occurrence of a dictionary argument
as an argument of a class method. Should be pretty small
else big functions may get inlined
-ufFunAppDiscount
+unfoldingFunAppDiscount
Discount for a function argument that is applied. Quite
large, because if we inline we avoid the higher-order call.
-ufDearOp
- The size of a foreign call or not-dupable PrimOp
-
-ufVeryAggressive
+unfoldingVeryAggressive
If True, the compiler ignores all the thresholds and inlines very
aggressively. It still adheres to arity, simplifier phase control and
loop breakers.
@@ -1136,27 +913,27 @@ flaggery. Just the same as smallEnoughToInline, except that it has no
actual arguments.
-}
-couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool
-couldBeSmallEnoughToInline dflags threshold rhs
- = case sizeExpr dflags threshold [] body of
+couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool
+couldBeSmallEnoughToInline opts threshold rhs
+ = case sizeExpr opts threshold [] body of
TooBig -> False
_ -> True
where
(_, body) = collectBinders rhs
----------------
-smallEnoughToInline :: DynFlags -> Unfolding -> Bool
-smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})
- = size <= ufUseThreshold dflags
+smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool
+smallEnoughToInline opts (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})
+ = size <= unfoldingUseThreshold opts
smallEnoughToInline _ _
= False
----------------
-certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding
+certainlyWillInline :: UnfoldingOpts -> IdInfo -> Maybe Unfolding
-- ^ Sees if the unfolding is pretty certain to inline.
-- If so, return a *stable* unfolding for it, that will always inline.
-certainlyWillInline dflags fn_info
+certainlyWillInline opts fn_info
= case unfoldingInfo fn_info of
CoreUnfolding { uf_tmpl = e, uf_guidance = g }
| loop_breaker -> Nothing -- Won't inline, so try w/w
@@ -1191,7 +968,7 @@ certainlyWillInline dflags fn_info
-- it seems smallish. We've carefully lifted it out to top level,
-- so we don't want to re-inline it.
, let unf_arity = length args
- , size - (10 * (unf_arity + 1)) <= ufUseThreshold dflags
+ , size - (10 * (unf_arity + 1)) <= unfoldingUseThreshold opts
= Just (fn_unf { uf_src = InlineStable
, uf_guidance = UnfWhen { ug_arity = unf_arity
, ug_unsat_ok = unSaturatedOk
@@ -1341,7 +1118,7 @@ tryUnfolding dflags id lone_variable
UnfNever -> traceInline dflags id str (text "UnfNever") Nothing
UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
- | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags)
+ | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive uf_opts)
-- See Note [INLINE for small functions (3)]
-> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template)
| otherwise
@@ -1351,7 +1128,7 @@ tryUnfolding dflags id lone_variable
enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
- | ufVeryAggressive dflags
+ | unfoldingVeryAggressive uf_opts
-> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)
| is_wf && some_benefit && small_enough
-> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)
@@ -1361,10 +1138,11 @@ tryUnfolding dflags id lone_variable
some_benefit = calc_some_benefit (length arg_discounts)
extra_doc = text "discounted size =" <+> int discounted_size
discounted_size = size - discount
- small_enough = discounted_size <= ufUseThreshold dflags
+ small_enough = discounted_size <= unfoldingUseThreshold uf_opts
discount = computeDiscount arg_discounts res_discount arg_infos cont_info
where
+ uf_opts = unfoldingOpts dflags
mk_doc some_benefit extra_doc yes_or_no
= vcat [ text "arg infos" <+> ppr arg_infos
, text "interesting continuation" <+> ppr cont_info
diff --git a/compiler/GHC/Core/Unfold.hs-boot b/compiler/GHC/Core/Unfold.hs-boot
index 4706af49e7..b86f8b2585 100644
--- a/compiler/GHC/Core/Unfold.hs-boot
+++ b/compiler/GHC/Core/Unfold.hs-boot
@@ -1,16 +1,13 @@
-module GHC.Core.Unfold (
- mkUnfolding, mkInlineUnfolding
- ) where
+module GHC.Core.Unfold where
import GHC.Prelude
-import GHC.Core
-import GHC.Driver.Session
-mkInlineUnfolding :: CoreExpr -> Unfolding
+data UnfoldingOpts
-mkUnfolding :: DynFlags
- -> UnfoldingSource
- -> Bool
- -> Bool
- -> CoreExpr
- -> Unfolding
+defaultUnfoldingOpts :: UnfoldingOpts
+
+updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
+updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
new file mode 100644
index 0000000000..4f0fd85c55
--- /dev/null
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -0,0 +1,311 @@
+{-# LANGUAGE CPP #-}
+
+-- | Unfolding creation
+module GHC.Core.Unfold.Make
+ ( noUnfolding
+ , mkUnfolding
+ , mkCoreUnfolding
+ , mkFinalUnfolding
+ , mkSimpleUnfolding
+ , mkWorkerUnfolding
+ , mkInlineUnfolding
+ , mkInlineUnfoldingWithArity
+ , mkInlinableUnfolding
+ , mkWwInlineRule
+ , mkCompulsoryUnfolding
+ , mkCompulsoryUnfolding'
+ , mkDFunUnfolding
+ , specUnfolding
+ )
+where
+
+#include "HsVersions.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
+
+-- the very simple optimiser is used to optimise unfoldings
+import {-# SOURCE #-} GHC.Core.SimpleOpt
+
+
+
+mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
+-- "Final" in the sense that this is a GlobalId that will not be further
+-- simplified; so the unfolding should be occurrence-analysed
+mkFinalUnfolding opts src strict_sig expr
+ = mkUnfolding opts src
+ True {- Top level -}
+ (isDeadEndSig strict_sig)
+ expr
+
+-- | Used for things that absolutely must be unfolded
+mkCompulsoryUnfolding :: SimpleOptOpts -> CoreExpr -> Unfolding
+mkCompulsoryUnfolding opts expr = mkCompulsoryUnfolding' (simpleOptExpr opts expr)
+
+-- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed
+-- on the unfolding.
+mkCompulsoryUnfolding' :: CoreExpr -> Unfolding
+mkCompulsoryUnfolding' expr
+ = mkCoreUnfolding InlineCompulsory True
+ expr
+ (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
+ , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
+
+-- Note [Top-level flag on inline rules]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Slight hack: note that mk_inline_rules conservatively sets the
+-- top-level flag to True. It gets set more accurately by the simplifier
+-- Simplify.simplUnfolding.
+
+mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
+mkSimpleUnfolding opts rhs
+ = mkUnfolding opts InlineRhs False False rhs
+
+mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
+mkDFunUnfolding bndrs con ops
+ = DFunUnfolding { df_bndrs = bndrs
+ , df_con = con
+ , df_args = map occurAnalyseExpr ops }
+ -- See Note [Occurrence analysis of unfoldings]
+
+mkWwInlineRule :: SimpleOptOpts -> CoreExpr -> Arity -> Unfolding
+mkWwInlineRule opts expr arity
+ = mkCoreUnfolding InlineStable True
+ (simpleOptExpr opts expr)
+ (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk
+ , ug_boring_ok = boringCxtNotOk })
+
+mkWorkerUnfolding :: SimpleOptOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
+-- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap
+mkWorkerUnfolding opts work_fn
+ (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
+ , uf_is_top = top_lvl })
+ | isStableSource src
+ = mkCoreUnfolding src top_lvl new_tmpl guidance
+ where
+ new_tmpl = simpleOptExpr opts (work_fn tmpl)
+ guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl
+
+mkWorkerUnfolding _ _ _ = noUnfolding
+
+-- | Make an unfolding that may be used unsaturated
+-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its
+-- manifest arity (the number of outer lambdas applications will
+-- resolve before doing any work).
+mkInlineUnfolding :: SimpleOptOpts -> CoreExpr -> Unfolding
+mkInlineUnfolding opts expr
+ = mkCoreUnfolding InlineStable
+ True -- Note [Top-level flag on inline rules]
+ expr' guide
+ where
+ expr' = simpleOptExpr opts expr
+ guide = UnfWhen { ug_arity = manifestArity expr'
+ , ug_unsat_ok = unSaturatedOk
+ , ug_boring_ok = boring_ok }
+ boring_ok = inlineBoringOk expr'
+
+-- | Make an unfolding that will be used once the RHS has been saturated
+-- to the given arity.
+mkInlineUnfoldingWithArity :: Arity -> SimpleOptOpts -> CoreExpr -> Unfolding
+mkInlineUnfoldingWithArity arity opts expr
+ = mkCoreUnfolding InlineStable
+ True -- Note [Top-level flag on inline rules]
+ expr' guide
+ where
+ expr' = simpleOptExpr opts expr
+ guide = UnfWhen { ug_arity = arity
+ , ug_unsat_ok = needSaturated
+ , ug_boring_ok = boring_ok }
+ -- See Note [INLINE pragmas and boring contexts] as to why we need to look
+ -- at the arity here.
+ boring_ok | arity == 0 = True
+ | otherwise = inlineBoringOk expr'
+
+mkInlinableUnfolding :: SimpleOptOpts -> CoreExpr -> Unfolding
+mkInlinableUnfolding opts expr
+ = mkUnfolding (so_uf_opts opts) InlineStable False False expr'
+ where
+ expr' = simpleOptExpr opts expr
+
+specUnfolding :: SimpleOptOpts
+ -> [Var] -> (CoreExpr -> CoreExpr)
+ -> [CoreArg] -- LHS arguments in the RULE
+ -> Unfolding -> Unfolding
+-- See Note [Specialising unfoldings]
+-- specUnfolding spec_bndrs spec_args unf
+-- = \spec_bndrs. unf spec_args
+--
+specUnfolding opts spec_bndrs spec_app rule_lhs_args
+ df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
+ = ASSERT2( rule_lhs_args `equalLength` old_bndrs
+ , ppr df $$ ppr rule_lhs_args )
+ -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise
+ mkDFunUnfolding spec_bndrs con (map spec_arg args)
+ -- For DFunUnfoldings we transform
+ -- \obs. MkD <op1> ... <opn>
+ -- to
+ -- \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>
+ where
+ spec_arg arg = simpleOptExpr opts $
+ spec_app (mkLams old_bndrs arg)
+ -- The beta-redexes created by spec_app will be
+ -- simplified away by simplOptExpr
+
+specUnfolding opts spec_bndrs spec_app rule_lhs_args
+ (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
+ , uf_is_top = top_lvl
+ , uf_guidance = old_guidance })
+ | isStableSource src -- See Note [Specialising unfoldings]
+ , UnfWhen { ug_arity = old_arity } <- old_guidance
+ = mkCoreUnfolding src top_lvl new_tmpl
+ (old_guidance { ug_arity = old_arity - arity_decrease })
+ where
+ new_tmpl = simpleOptExpr opts $
+ mkLams spec_bndrs $
+ spec_app tmpl -- The beta-redexes created by spec_app
+ -- will besimplified away by simplOptExpr
+ arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs
+
+
+specUnfolding _ _ _ _ _ = noUnfolding
+
+{- Note [Specialising unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise a function for some given type-class arguments, we use
+specUnfolding to specialise its unfolding. Some important points:
+
+* If the original function has a DFunUnfolding, the specialised one
+ must do so too! Otherwise we lose the magic rules that make it
+ interact with ClassOps
+
+* There is a bit of hack for INLINABLE functions:
+ f :: Ord a => ....
+ f = <big-rhs>
+ {- INLINABLE f #-}
+ Now if we specialise f, should the specialised version still have
+ an INLINABLE pragma? If it does, we'll capture a specialised copy
+ of <big-rhs> as its unfolding, and that probably won't inline. But
+ if we don't, the specialised version of <big-rhs> might be small
+ enough to inline at a call site. This happens with Control.Monad.liftM3,
+ and can cause a lot more allocation as a result (nofib n-body shows this).
+
+ Moreover, keeping the INLINABLE thing isn't much help, because
+ the specialised function (probably) isn't overloaded any more.
+
+ Conclusion: drop the INLINEALE pragma. In practice what this means is:
+ if a stable unfolding has UnfoldingGuidance of UnfWhen,
+ we keep it (so the specialised thing too will always inline)
+ if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs
+ (which arises from INLINABLE), we discard it
+
+Note [Honour INLINE on 0-ary bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ x = <expensive>
+ {-# INLINE x #-}
+
+ f y = ...x...
+
+The semantics of an INLINE pragma is
+
+ inline x at every call site, provided it is saturated;
+ that is, applied to at least as many arguments as appear
+ on the LHS of the Haskell source definition.
+
+(This source-code-derived arity is stored in the `ug_arity` field of
+the `UnfoldingGuidance`.)
+
+In the example, x's ug_arity is 0, so we should inline it at every use
+site. It's rare to have such an INLINE pragma (usually INLINE Is on
+functions), but it's occasionally very important (#15578, #15519).
+In #15519 we had something like
+ x = case (g a b) of I# r -> T r
+ {-# INLINE x #-}
+ f y = ...(h x)....
+
+where h is strict. So we got
+ f y = ...(case g a b of I# r -> h (T r))...
+
+and that in turn allowed SpecConstr to ramp up performance.
+
+How do we deliver on this? By adjusting the ug_boring_ok
+flag in mkInlineUnfoldingWithArity; see
+Note [INLINE pragmas and boring contexts]
+
+NB: there is a real risk that full laziness will float it right back
+out again. Consider again
+ x = factorial 200
+ {-# INLINE x #-}
+ f y = ...x...
+
+After inlining we get
+ f y = ...(factorial 200)...
+
+but it's entirely possible that full laziness will do
+ lvl23 = factorial 200
+ f y = ...lvl23...
+
+That's a problem for another day.
+
+Note [INLINE pragmas and boring contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An INLINE pragma uses mkInlineUnfoldingWithArity to build the
+unfolding. That sets the ug_boring_ok flag to False if the function
+is not tiny (inlineBoringOK), so that even INLINE functions are not
+inlined in an utterly boring context. E.g.
+ \x y. Just (f y x)
+Nothing is gained by inlining f here, even if it has an INLINE
+pragma.
+
+But for 0-ary bindings, we want to inline regardless; see
+Note [Honour INLINE on 0-ary bindings].
+
+I'm a bit worried that it's possible for the same kind of problem
+to arise for non-0-ary functions too, but let's wait and see.
+-}
+
+mkUnfolding :: UnfoldingOpts
+ -> UnfoldingSource
+ -> Bool -- Is top-level
+ -> Bool -- Definitely a bottoming binding
+ -- (only relevant for top-level bindings)
+ -> CoreExpr
+ -> Unfolding
+-- Calculates unfolding guidance
+-- Occurrence-analyses the expression before capturing it
+mkUnfolding opts src top_lvl is_bottoming expr
+ = mkCoreUnfolding src top_lvl expr guidance
+ where
+ is_top_bottoming = top_lvl && is_bottoming
+ guidance = calcUnfoldingGuidance opts is_top_bottoming expr
+ -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
+ -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+
+mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
+ -> UnfoldingGuidance -> Unfolding
+-- Occurrence-analyses the expression before capturing it
+mkCoreUnfolding src top_lvl expr guidance
+ = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
+ -- See Note [Occurrence analysis of unfoldings]
+ uf_src = src,
+ uf_is_top = top_lvl,
+ uf_is_value = exprIsHNF expr,
+ uf_is_conlike = exprIsConLike expr,
+ uf_is_work_free = exprIsWorkFree expr,
+ uf_expandable = exprIsExpandable expr,
+ uf_guidance = guidance }
+
+
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 743ce77926..36be9d15db 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -33,6 +33,7 @@ import GHC.Driver.Ppr
import GHC.Tc.Utils.Monad
import GHC.Tc.Module
import GHC.Unit
+import GHC.Unit.State
import GHC.Driver.Types
import GHC.Data.StringBuffer
import GHC.Data.FastString
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 122efe2069..841fa79d33 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -39,6 +39,7 @@ import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Unit
+import GHC.Unit.State
import GHC.Types.SrcLoc
import GHC.Types.CostCentre
diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs
new file mode 100644
index 0000000000..b67e74eeb4
--- /dev/null
+++ b/compiler/GHC/Driver/Config.hs
@@ -0,0 +1,25 @@
+-- | Subsystem configuration
+module GHC.Driver.Config
+ ( initOptCoercionOpts
+ , initSimpleOptOpts
+ )
+where
+
+import GHC.Prelude
+
+import GHC.Driver.Session
+import GHC.Core.SimpleOpt
+import GHC.Core.Coercion.Opt
+
+-- | Initialise coercion optimiser configuration from DynFlags
+initOptCoercionOpts :: DynFlags -> OptCoercionOpts
+initOptCoercionOpts dflags = OptCoercionOpts
+ { optCoercionEnabled = not (hasNoOptCoercion dflags)
+ }
+
+-- | Initialise Simple optimiser configuration from DynFlags
+initSimpleOptOpts :: DynFlags -> SimpleOptOpts
+initSimpleOptOpts dflags = SimpleOptOpts
+ { so_uf_opts = unfoldingOpts dflags
+ , so_co_opts = initOptCoercionOpts dflags
+ }
diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs
index c598e36791..771d153952 100644
--- a/compiler/GHC/Driver/Finder.hs
+++ b/compiler/GHC/Driver/Finder.hs
@@ -37,6 +37,7 @@ module GHC.Driver.Finder (
import GHC.Prelude
import GHC.Unit
+import GHC.Unit.State
import GHC.Driver.Types
import GHC.Data.FastString
import GHC.Utils.Misc
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index a78df33e86..90a07d7490 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -102,6 +102,7 @@ import GHC.Core.ConLike
import GHC.Parser.Annotation
import GHC.Unit
+import GHC.Unit.State
import GHC.Types.Name.Reader
import GHC.Hs
import GHC.Hs.Dump
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 1fcc539384..de1746c815 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -47,6 +47,7 @@ import GHC.Driver.Monad
import GHC.Parser.Header
import GHC.Driver.Types
import GHC.Unit
+import GHC.Unit.State
import GHC.IfaceToCore ( typecheckIface )
import GHC.Tc.Utils.Monad ( initIfaceCheck )
import GHC.Driver.Main
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 79d2411bba..66487c497d 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -41,6 +41,7 @@ import GHC.Prelude
import GHC.Driver.Pipeline.Monad
import GHC.Unit
+import GHC.Unit.State
import GHC.Platform.Ways
import GHC.Platform.ArchOS
import GHC.Parser.Header
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index a0c2331d53..b72d579e33 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -250,6 +250,7 @@ import GHC.Driver.Flags
import GHC.Driver.Backend
import GHC.Settings.Config
import GHC.Utils.CliOption
+import {-# SOURCE #-} GHC.Core.Unfold
import GHC.Driver.CmdLine hiding (WarnReason(..))
import qualified GHC.Driver.CmdLine as Cmd
import GHC.Settings.Constants
@@ -693,14 +694,9 @@ data DynFlags = DynFlags {
-- by template-haskell
extensionFlags :: EnumSet LangExt.Extension,
- -- Unfolding control
+ -- | Unfolding control
-- See Note [Discounts and thresholds] in GHC.Core.Unfold
- ufCreationThreshold :: Int,
- ufUseThreshold :: Int,
- ufFunAppDiscount :: Int,
- ufDictDiscount :: Int,
- ufDearOp :: Int,
- ufVeryAggressive :: Bool,
+ unfoldingOpts :: !UnfoldingOpts,
maxWorkerArgs :: Int,
@@ -1303,25 +1299,7 @@ defaultDynFlags mySettings llvmConfig =
extensions = [],
extensionFlags = flattenExtensionFlags Nothing [],
- ufCreationThreshold = 750,
- -- The ufCreationThreshold threshold must be reasonably high
- -- to take account of possible discounts.
- -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to
- -- inline into Csg.calc (The unfolding for sqr never makes it
- -- into the interface file.)
-
- ufUseThreshold = 90,
- -- Last adjusted upwards in #18282, when I reduced
- -- the result discount for constructors.
-
- ufFunAppDiscount = 60,
- -- Be fairly keen to inline a function if that means
- -- we'll be able to pick the right method from a dictionary
-
- ufDictDiscount = 30,
- ufDearOp = 40,
- ufVeryAggressive = False,
-
+ unfoldingOpts = defaultUnfoldingOpts,
maxWorkerArgs = 10,
ghciHistSize = 50, -- keep a log of length 50 by default
@@ -2893,17 +2871,20 @@ dynamic_flags_deps = [
parseWeights s (cfgWeights d)})))
, make_ord_flag defFlag "fhistory-size"
(intSuffix (\n d -> d { historySize = n }))
+
, make_ord_flag defFlag "funfolding-creation-threshold"
- (intSuffix (\n d -> d {ufCreationThreshold = n}))
+ (intSuffix (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)}))
, make_ord_flag defFlag "funfolding-use-threshold"
- (intSuffix (\n d -> d {ufUseThreshold = n}))
+ (intSuffix (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)}))
, make_ord_flag defFlag "funfolding-fun-discount"
- (intSuffix (\n d -> d {ufFunAppDiscount = n}))
+ (intSuffix (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)}))
, make_ord_flag defFlag "funfolding-dict-discount"
- (intSuffix (\n d -> d {ufDictDiscount = n}))
+ (intSuffix (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)}))
+
, make_dep_flag defFlag "funfolding-keeness-factor"
(floatSuffix (\_ d -> d))
"-funfolding-keeness-factor is no longer respected as of GHC 8.12"
+
, make_ord_flag defFlag "fmax-worker-args"
(intSuffix (\n d -> d {maxWorkerArgs = n}))
, make_ord_flag defGhciFlag "fghci-hist-size"
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 1cfd153523..9e922850e2 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -175,6 +175,7 @@ import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Avail
import GHC.Unit
+import GHC.Unit.State
import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead )
import GHC.Core.FamInstEnv
import GHC.Core ( CoreProgram, RuleBase, CoreRule )
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 2b98d9343f..eda5ad8130 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -22,6 +22,7 @@ import GHC.Prelude
import GHC.HsToCore.Usage
import GHC.Driver.Session
+import GHC.Driver.Config
import GHC.Driver.Types
import GHC.Driver.Backend
import GHC.Hs
@@ -38,7 +39,7 @@ import GHC.Core
import GHC.Core.FVs ( exprsSomeFreeVarsList )
import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
import GHC.Core.Utils
-import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.Ppr
import GHC.HsToCore.Monad
import GHC.HsToCore.Expr
@@ -170,10 +171,13 @@ deSugar hsc_env
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
- ; (ds_binds, ds_rules_for_imps)
- <- simpleOptPgm dflags mod final_pgm rules_for_imps
+ ; let simpl_opts = initSimpleOptOpts dflags
+ ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
+ = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
+ ; dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+ FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
@@ -409,7 +413,8 @@ dsRule (L loc (HsRule { rd_name = name
-- we don't want to attach rules to the bindings of implicit Ids,
-- because they don't show up in the bindings until just before code gen
fn_name = idName fn_id
- final_rhs = simpleOptExpr dflags rhs'' -- De-crap it
+ simpl_opts = initSimpleOptOpts dflags
+ final_rhs = simpleOptExpr simpl_opts rhs'' -- De-crap it
rule_name = snd (unLoc name)
final_bndrs_set = mkVarSet final_bndrs
arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
@@ -738,7 +743,7 @@ mkUnsafeCoercePrimPair _old_id old_expr
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding' rhs
ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ] $
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 8e54489f1e..b05162aa3c 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -42,7 +42,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Core.Make
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( etaExpand )
-import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.FVs
import GHC.Data.Graph.Directed
import GHC.Core.Predicate
@@ -72,6 +72,7 @@ import GHC.Data.Bag
import GHC.Types.Basic
import GHC.Driver.Session
import GHC.Driver.Ppr
+import GHC.Driver.Config
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Types.Unique.Set( nonDetEltsUniqSet )
@@ -380,7 +381,7 @@ makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
makeCorePair dflags gbl_id is_default_method dict_arity rhs
| is_default_method -- Default methods are *always* inlined
-- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance
- = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
+ = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding simpl_opts rhs, rhs)
| otherwise
= case inlinePragmaSpec inline_prag of
@@ -390,20 +391,21 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
Inline -> inline_pair
where
+ simpl_opts = initSimpleOptOpts dflags
inline_prag = idInlinePragma gbl_id
- inlinable_unf = mkInlinableUnfolding dflags rhs
+ inlinable_unf = mkInlinableUnfolding simpl_opts rhs
inline_pair
| Just arity <- inlinePragmaSat inline_prag
-- Add an Unfolding for an INLINE (but not for NOINLINE)
-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
, let real_arity = dict_arity + arity
-- NB: The arity in the InlineRule takes account of the dictionaries
- = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
+ = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity simpl_opts rhs
, etaExpand real_arity rhs)
| otherwise
= pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
- (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
+ (gbl_id `setIdUnfolding` mkInlineUnfolding simpl_opts rhs, rhs)
dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity
@@ -704,8 +706,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
{ this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
- spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf
- spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many.
+ simpl_opts = initSimpleOptOpts dflags
+ spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf
+ spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many.
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
@@ -863,8 +866,9 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs
| otherwise
= Left bad_shape_msg
where
+ simpl_opts = initSimpleOptOpts dflags
lhs1 = drop_dicts orig_lhs
- lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS]
+ lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS]
(fun2,args2) = collectArgs lhs2
lhs_fvs = exprFreeVars lhs2
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 2790137912..0c5d8676eb 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -27,7 +27,7 @@ import GHC.HsToCore.Monad
import GHC.Hs
import GHC.Core.DataCon
-import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Unit.Module
@@ -53,6 +53,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Driver.Session
+import GHC.Driver.Config
import GHC.Platform
import GHC.Data.OrdList
import GHC.Utils.Misc
@@ -286,8 +287,11 @@ dsFCall fn_id co fcall mDeclHeader = do
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkLams (tvs ++ args) wrapper_body
wrap_rhs' = Cast wrap_rhs co
+ simpl_opts = initSimpleOptOpts dflags
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
- (length args) wrap_rhs'
+ (length args)
+ simpl_opts
+ wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index bf21c8594b..3919b91893 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -30,6 +30,7 @@ import GHC.Prelude
import GHC.HsToCore.PmCheck.Types
import GHC.Driver.Session
+import GHC.Driver.Config
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Misc
@@ -1667,8 +1668,8 @@ representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e
-- want to record @x ~ y@.
addCoreCt :: Delta -> Id -> CoreExpr -> MaybeT DsM Delta
addCoreCt delta x e = do
- dflags <- getDynFlags
- let e' = simpleOptExpr dflags e
+ simpl_opts <- initSimpleOptOpts <$> getDynFlags
+ let e' = simpleOptExpr simpl_opts e
lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')
execStateT (core_expr x e') delta
where
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index 7fe799ebe4..b3de3cc4ce 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -20,6 +20,7 @@ import GHC.Tc.Types
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Unit
+import GHC.Unit.State
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.Unique.Set
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index 376eee8350..7a511fdc49 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -23,6 +23,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Driver.Types
import GHC.Unit
+import GHC.Unit.State
import GHC.Types.Unique.FM
import GHC.Types.Avail
import GHC.Iface.Syntax
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 557c3e0922..4afd7517e8 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -22,6 +22,7 @@ import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Core
import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.FVs
import GHC.Core.Tidy
import GHC.Core.Opt.Monad
@@ -381,8 +382,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; let { (trimmed_binds, trimmed_rules)
= findExternalRules omit_prags binds imp_rules unfold_env }
+ ; let uf_opts = unfoldingOpts dflags
; (tidy_env, tidy_binds)
- <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds
+ <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
; (spt_entries, tidy_binds') <-
@@ -1108,43 +1110,41 @@ tidyTopName mod nc_var maybe_ref occ_env id
--
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
-tidyTopBinds :: HscEnv
+tidyTopBinds :: UnfoldingOpts
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
-tidyTopBinds hsc_env unfold_env init_occ_env binds
+tidyTopBinds uf_opts unfold_env init_occ_env binds
= do let result = tidy init_env binds
seqBinds (snd result) `seq` return result
-- This seqBinds avoids a spike in space usage (see #13564)
where
- dflags = hsc_dflags hsc_env
-
init_env = (init_occ_env, emptyVarEnv)
- tidy = mapAccumL (tidyTopBind dflags unfold_env)
+ tidy = mapAccumL (tidyTopBind uf_opts unfold_env)
------------------------
-tidyTopBind :: DynFlags
+tidyTopBind :: UnfoldingOpts
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
-tidyTopBind dflags unfold_env
+tidyTopBind uf_opts unfold_env
(occ_env,subst1) (NonRec bndr rhs)
= (tidy_env2, NonRec bndr' rhs')
where
Just (name',show_unfold) = lookupVarEnv unfold_env bndr
- (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 name' (bndr, rhs)
+ (bndr', rhs') = tidyTopPair uf_opts show_unfold tidy_env2 name' (bndr, rhs)
subst2 = extendVarEnv subst1 bndr bndr'
tidy_env2 = (occ_env, subst2)
-tidyTopBind dflags unfold_env (occ_env, subst1) (Rec prs)
+tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs)
= (tidy_env2, Rec prs')
where
- prs' = [ tidyTopPair dflags show_unfold tidy_env2 name' (id,rhs)
+ prs' = [ tidyTopPair uf_opts show_unfold tidy_env2 name' (id,rhs)
| (id,rhs) <- prs,
let (name',show_unfold) =
expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
@@ -1156,7 +1156,7 @@ tidyTopBind dflags unfold_env (occ_env, subst1) (Rec prs)
bndrs = map fst prs
-----------------------------------------------------------
-tidyTopPair :: DynFlags
+tidyTopPair :: UnfoldingOpts
-> Bool -- show unfolding
-> TidyEnv -- The TidyEnv is used to tidy the IdInfo
-- It is knot-tied: don't look at it!
@@ -1169,14 +1169,14 @@ tidyTopPair :: DynFlags
-- group, a variable late in the group might be mentioned
-- in the IdInfo of one early in the group
-tidyTopPair dflags show_unfold rhs_tidy_env name' (bndr, rhs)
+tidyTopPair uf_opts show_unfold rhs_tidy_env name' (bndr, rhs)
= (bndr1, rhs1)
where
bndr1 = mkGlobalId details name' ty' idinfo'
details = idDetails bndr -- Preserve the IdDetails
ty' = tidyTopType (idType bndr)
rhs1 = tidyExpr rhs_tidy_env rhs
- idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)
+ idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo bndr)
show_unfold
-- tidyTopIdInfo creates the final IdInfo for top-level
@@ -1186,9 +1186,9 @@ tidyTopPair dflags show_unfold rhs_tidy_env name' (bndr, rhs)
-- Indeed, CorePrep must eta expand where necessary to make
-- the manifest arity equal to the claimed arity.
--
-tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr
+tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr
-> IdInfo -> Bool -> IdInfo
-tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
+tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
| not is_external -- For internal Ids (not externally visible)
= vanillaIdInfo -- we only need enough info for code generation
-- Arity and strictness info are enough;
@@ -1245,7 +1245,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
| otherwise
= minimal_unfold_info
minimal_unfold_info = zapUnfolding unf_info
- unf_from_rhs = mkFinalUnfolding dflags InlineRhs final_sig tidy_rhs
+ unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs
-- NB: do *not* expose the worker if show_unfold is off,
-- because that means this thing is a loop breaker or
-- marked NOINLINE or something like that
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index b6183eae47..52267070de 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -47,7 +47,7 @@ import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Core
import GHC.Core.Utils
-import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.Lint
import GHC.Core.Make
import GHC.Types.Id
@@ -1544,13 +1544,13 @@ tcLFInfo lfi = case lfi of
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
- = do { dflags <- getDynFlags
+ = do { uf_opts <- unfoldingOpts <$> getDynFlags
; mb_expr <- tcPragExpr False toplvl name if_expr
; let unf_src | stable = InlineStable
| otherwise = InlineRhs
; return $ case mb_expr of
Nothing -> NoUnfolding
- Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr
+ Just expr -> mkFinalUnfolding uf_opts unf_src strict_sig expr
}
where
-- Strictness should occur before unfolding!
@@ -1560,7 +1560,7 @@ tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr True toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
- Just expr -> mkCompulsoryUnfolding expr) }
+ Just expr -> mkCompulsoryUnfolding' expr) }
tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
= do { mb_expr <- tcPragExpr False toplvl name if_expr
diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs
index 938f8de110..377d7bcf81 100644
--- a/compiler/GHC/SysTools.hs
+++ b/compiler/GHC/SysTools.hs
@@ -43,6 +43,7 @@ import GHC.Prelude
import GHC.Settings.Utils
import GHC.Unit
+import GHC.Unit.State
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 074fb22329..c9f70ee62a 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -51,8 +51,9 @@ import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.Unify
import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams )
import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID )
-import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
+import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
import GHC.Core.Type
+import GHC.Core.SimpleOpt
import GHC.Tc.Types.Evidence
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
@@ -1207,7 +1208,7 @@ addDFunPrags :: DFunId -> [Id] -> DFunId
-- is messing with.
addDFunPrags dfun_id sc_meth_ids
| is_newtype
- = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app
+ = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 defaultSimpleOptOpts con_app
`setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index b27002bec8..407e666e6f 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -68,6 +68,7 @@ import GHC.Tc.Errors
import GHC.Tc.Utils.Unify
import GHC.Iface.Rename
import GHC.Utils.Misc
+import GHC.Unit.State
import Control.Monad
import Data.List (find)
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 108dd41dda..49e57b44ca 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -54,7 +54,8 @@ import GHC.Tc.Utils.TcType as TcType
import GHC.Core.Make
import GHC.Core.FVs ( mkRuleInfo )
import GHC.Core.Utils ( mkCast, mkDefaultCase )
-import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
+import GHC.Core.SimpleOpt
import GHC.Types.Literal
import GHC.Core.TyCon
import GHC.Core.Class
@@ -486,6 +487,7 @@ mkDictSelId name clas
info | new_tycon
= base_info `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkInlineUnfoldingWithArity 1
+ defaultSimpleOptOpts
(mkDictSelRhs clas val_index)
-- See Note [Single-method classes] in GHC.Tc.TyCl.Instance
-- for why alwaysInlinePragma
@@ -600,7 +602,7 @@ mkDataConWorkId wkr_name data_con
isSingleton arg_tys
, ppr data_con )
-- Note [Newtype datacons]
- mkCompulsoryUnfolding $
+ mkCompulsoryUnfolding defaultSimpleOptOpts $
mkLams univ_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon res_ty_args (Var id_arg1)
@@ -733,9 +735,9 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- See Note [Inline partially-applied constructor wrappers]
-- Passing Nothing here allows the wrapper to inline when
-- unsaturated.
- wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs
+ wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding defaultSimpleOptOpts wrap_rhs
-- See Note [Compulsory newtype unfolding]
- | otherwise = mkInlineUnfolding wrap_rhs
+ | otherwise = mkInlineUnfolding defaultSimpleOptOpts wrap_rhs
wrap_rhs = mkLams wrap_tvs $
mkLams wrap_args $
wrapFamInstBody tycon res_ty_args $
@@ -1463,7 +1465,7 @@ nullAddrId :: Id
nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit)
+ `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOptOpts (Lit nullAddrLit)
`setNeverLevPoly` addrPrimTy
------------------------------------------------
@@ -1471,7 +1473,7 @@ seqId :: Id -- See Note [seqId magic]
seqId = pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setInlinePragInfo` inline_prag
- `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOptOpts rhs
inline_prag
= alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter
@@ -1508,7 +1510,7 @@ oneShotId :: Id -- See Note [The oneShot function]
oneShotId = pcMiscPrelId oneShotName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOptOpts rhs
ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkVisFunTyMany fun_ty fun_ty)
@@ -1534,7 +1536,7 @@ coerceId :: Id
coerceId = pcMiscPrelId coerceName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOptOpts rhs
eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ]
eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ]
ty = mkInvisForAllTys [ Bndr rv InferredSpec
@@ -1781,7 +1783,7 @@ voidPrimId :: Id -- Global constant :: Void#
-- We cannot define it in normal Haskell, since it's
-- a top-level unlifted value.
voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy
- (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOptOpts rhs
`setNeverLevPoly` unboxedUnitTy)
where rhs = Var (dataConWorkId unboxedUnitDataCon)
diff --git a/compiler/GHC/Unit.hs b/compiler/GHC/Unit.hs
index 0de384f52c..64577d55ae 100644
--- a/compiler/GHC/Unit.hs
+++ b/compiler/GHC/Unit.hs
@@ -17,9 +17,10 @@ where
import GHC.Unit.Types
import GHC.Unit.Info
import GHC.Unit.Parser
-import GHC.Unit.State
import GHC.Unit.Module
import GHC.Unit.Home
+-- source import to avoid DynFlags import loops
+import {-# SOURCE #-} GHC.Unit.State
{-
diff --git a/compiler/GHC/Unit/State.hs-boot b/compiler/GHC/Unit/State.hs-boot
index 7c906165df..3d06269654 100644
--- a/compiler/GHC/Unit/State.hs-boot
+++ b/compiler/GHC/Unit/State.hs-boot
@@ -1,7 +1,7 @@
module GHC.Unit.State where
import {-# SOURCE #-} GHC.Utils.Outputable
-import {-# SOURCE #-} GHC.Unit.Types (UnitId)
+import {-# SOURCE #-} GHC.Unit.Types (UnitId,Unit)
data UnitState
data UnitDatabase unit
@@ -9,3 +9,4 @@ data UnitDatabase unit
emptyUnitState :: UnitState
pprUnitIdForUser :: UnitState -> UnitId -> SDoc
pprWithUnitState :: UnitState -> SDoc -> SDoc
+unwireUnit :: UnitState -> Unit-> Unit
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2a90db9c88..577add44d1 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -301,6 +301,7 @@ Library
GHC.Data.TrieMap
GHC.Core.Tidy
GHC.Core.Unfold
+ GHC.Core.Unfold.Make
GHC.Core.Utils
GHC.Core.Map
GHC.Core.Seq
@@ -354,6 +355,7 @@ Library
GHC.Iface.Recomp.Flags
GHC.Types.Annotations
GHC.Driver.CmdLine
+ GHC.Driver.Config
GHC.Driver.CodeOutput
GHC.Settings.Config
GHC.Settings.Constants
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index d4aa14682f..57d5c528b8 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -41,6 +41,7 @@ import GHC.Runtime.Interpreter
import GHC.Runtime.Interpreter.Types
import GHCi.RemoteTypes
import GHCi.BreakArray
+import GHC.Unit.State
import GHC.Driver.Session as DynFlags
import GHC.Driver.Ppr hiding (printForUser)
import GHC.Utils.Error hiding (traceCmd)
diff --git a/testsuite/tests/parser/should_run/CountParserDeps.hs b/testsuite/tests/parser/should_run/CountParserDeps.hs
index 409522d2e8..5d3396f835 100644
--- a/testsuite/tests/parser/should_run/CountParserDeps.hs
+++ b/testsuite/tests/parser/should_run/CountParserDeps.hs
@@ -30,7 +30,7 @@ main = do
let num = sizeUniqSet modules
-- print num
-- print (map moduleNameString $ nonDetEltsUniqSet modules)
- unless (num <= 200) $ exitWith (ExitFailure num)
+ unless (num <= 201) $ exitWith (ExitFailure num)
parserDeps :: FilePath -> IO (UniqSet ModuleName)
parserDeps libdir =