diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-06-16 12:30:22 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-09 11:19:24 -0400 |
| commit | 3f32a9c0f4ddceab14a381bfd3732bcad6be43f7 (patch) | |
| tree | 8e78c5b1681bf9ffd92e4fdb6a9134bb60ac05c8 | |
| parent | 8c892689058912c35ed36e07b5a9ed0df86abc03 (diff) | |
| download | haskell-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.
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 = |