From: simonpj@microsoft.com Date: Thu, 5 Nov 2009 17:03:13 +0000 (+0000) Subject: Another refactoring on the shape of an Unfolding X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a263737bbf44050a7b5ecbe267ddf85d410b73e5 Another refactoring on the shape of an Unfolding I found that a compulsory unfolding was getting dropped on the floor, so I took that as a hint to tidy up the data type so that it won't happen again. No big change in functionality. --- diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 4b42c0d..14eccc6 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -510,27 +510,27 @@ substUnfolding subst (DFunUnfolding con args) substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) }) -- Retain an InlineRule! = seqExpr new_tmpl `seq` - new_mb_wkr `seq` - unf { uf_tmpl = new_tmpl, uf_guidance = guide { ug_ir_info = new_mb_wkr } } + new_info `seq` + unf { uf_tmpl = new_tmpl, uf_guidance = guide { ir_info = new_info } } where - new_tmpl = substExpr subst tmpl - new_mb_wkr = substInlineRuleGuidance subst (ug_ir_info guide) + new_tmpl = substExpr subst tmpl + new_info = substInlineRuleInfo subst (ir_info guide) substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard -- Always zap a CoreUnfolding, to save substitution work -substUnfolding _ unf = unf -- Otherwise no substitution to do +substUnfolding _ unf = unf -- NoUnfolding, OtherCon ------------------- -substInlineRuleGuidance :: Subst -> InlineRuleInfo -> InlineRuleInfo -substInlineRuleGuidance subst (InlWrapper wkr) +substInlineRuleInfo :: Subst -> InlineRuleInfo -> InlineRuleInfo +substInlineRuleInfo subst (InlWrapper wkr) = case lookupIdSubst subst wkr of Var w1 -> InlWrapper w1 other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr wkr ) - InlUnSat -- Worker has got substituted away altogether + InlVanilla -- Worker has got substituted away altogether -- (This can happen if it's trivial, via -- postInlineUnconditionally, hence only warning) -substInlineRuleGuidance _ info = info +substInlineRuleInfo _ info = info ------------------ substIdOcc :: Subst -> Id -> Id diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index b6e7313..e9e7f8d 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -35,7 +35,7 @@ module CoreSyn ( isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), + Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), InlSatFlag(..), -- Abstract everywhere but in CoreUnfold.lhs -- ** Constructing 'Unfolding's @@ -440,20 +440,14 @@ data Unfolding ------------------------------------------------ -- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance - = UnfoldAlways -- There is /no original definition/, so you'd better unfold. - -- The unfolding is guaranteed to have no free variables - -- so no need to think about it during dependency analysis - - | InlineRule { -- See Note [InlineRules] - -- Be very keen to inline this + = InlineRule { -- Be very keen to inline this; See Note [InlineRules] -- The uf_tmpl is the *original* RHS; do *not* replace it on -- each simlifier run. Hence, the *actual* RHS of the function -- may be different by now, because it may have been optimised. - ug_ir_info :: InlineRuleInfo, -- Supplementary info about the InlineRule - ug_small :: Bool -- True <=> the RHS is so small (eg no bigger than a call) - -- that you should always inline a saturated call, - } -- regardless of how boring the context is - -- See Note [INLINE for small functions] in CoreUnfold] + + ir_sat :: InlSatFlag, + ir_info :: InlineRuleInfo + } | UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the -- result of a simple analysis of the RHS @@ -468,20 +462,29 @@ data UnfoldingGuidance } -- a context (case (thing args) of ...), -- (where there are the right number of arguments.) - | UnfoldNever + | UnfoldNever -- A variant of UnfoldIfGoodArgs, used for big RHSs data InlineRuleInfo - = InlSat -- A user-specifed or compiler injected INLINE pragma - -- ONLY inline when it's applied to 'arity' arguments + = InlAlways -- Inline absolutely always, however boring the context. + -- There is /no original definition/. Only a few primop-like things + -- have this property (see MkId.lhs, calls to mkCompulsoryUnfolding). + + | InlSmall -- The RHS is very small (eg no bigger than a call), so inline any + -- /saturated/ application, regardless of context + -- See Note [INLINE for small functions] in CoreUnfold + + | InlVanilla - | InlUnSat -- The compiler decided to "capture" the RHS into an - -- InlineRule, but do not require that it appears saturated + | InlWrapper Id -- This unfolding is a the wrapper in a + -- worker/wrapper split from the strictness analyser + -- Used to abbreviate the uf_tmpl in interface files + -- which don't need to contain the RHS; + -- it can be derived from the strictness info + -- [In principle this is orthogonal to the InlSmall/InVanilla thing, + -- but it's convenient to have it here.] - | InlWrapper Id -- This unfolding is a the wrapper in a - -- worker/wrapper split from the strictness analyser - -- Used to abbreviate the uf_tmpl in interface files - -- which don't need to contain the RHS; - -- it can be derived from the strictness info +data InlSatFlag = InlSat | InlUnSat + -- Specifies whether to INLINE only if the thing is applied to 'arity' args ------------------------------------------------ noUnfolding :: Unfolding @@ -564,10 +567,10 @@ isInlineRule :: Unfolding -> Bool isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True isInlineRule _ = False -isInlineRule_maybe :: Unfolding -> Maybe InlineRuleInfo -isInlineRule_maybe (CoreUnfolding { - uf_guidance = InlineRule { ug_ir_info = inl } }) = Just inl -isInlineRule_maybe _ = Nothing +isInlineRule_maybe :: Unfolding -> Maybe (InlineRuleInfo, InlSatFlag) +isInlineRule_maybe (CoreUnfolding { uf_guidance = + InlineRule { ir_info = inl, ir_sat = sat } }) = Just (inl,sat) +isInlineRule_maybe _ = Nothing isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 2d83a0f..d467e89 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -79,21 +79,6 @@ mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr) -mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding -mkWwInlineRule id = mkInlineRule (InlWrapper id) - -mkInlineRule :: InlineRuleInfo -> CoreExpr -> Arity -> Unfolding -mkInlineRule inl_info expr arity - = mkCoreUnfolding True -- Note [Top-level flag on inline rules] - expr' arity - (InlineRule { ug_ir_info = inl_info, ug_small = small }) - where - expr' = simpleOptExpr expr - small = case calcUnfoldingGuidance (arity+1) expr' of - (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) - -> uncondInline arity_e size_e - _other {- actually UnfoldNever -} -> False - -- Note [Top-level flag on inline rules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Slight hack: note that mk_inline_rules conservatively sets the @@ -129,9 +114,28 @@ mkCoreUnfolding top_lvl expr arity guidance mkDFunUnfolding :: DataCon -> [Id] -> Unfolding mkDFunUnfolding con ops = DFunUnfolding con (map Var ops) +mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule id expr arity + = mkCoreUnfolding True (simpleOptExpr expr) arity + (InlineRule { ir_sat = InlUnSat, ir_info = InlWrapper id }) + mkCompulsoryUnfolding :: CoreExpr -> Unfolding -mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding True expr 0 UnfoldAlways -- Arity of unfolding doesn't matter +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding True expr 0 -- Arity of unfolding doesn't matter + (InlineRule { ir_info = InlAlways, ir_sat = InlUnSat }) + +mkInlineRule :: InlSatFlag -> CoreExpr -> Arity -> Unfolding +mkInlineRule sat expr arity + = mkCoreUnfolding True -- Note [Top-level flag on inline rules] + expr' arity + (InlineRule { ir_sat = sat, ir_info = info }) + where + expr' = simpleOptExpr expr + info = if small then InlSmall else InlVanilla + small = case calcUnfoldingGuidance (arity+1) expr' of + (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) + -> uncondInline arity_e size_e + _other {- actually UnfoldNever -} -> False \end{code} @@ -552,7 +556,6 @@ certainlyWillInline :: Unfolding -> Bool -- Sees if the unfolding is pretty certain to inline certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance }) = case guidance of - UnfoldAlways {} -> True UnfoldNever -> False InlineRule {} -> True UnfoldIfGoodArgs { ug_size = size} @@ -661,23 +664,19 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info = case guidance of UnfoldNever -> False - UnfoldAlways -> True - -- UnfoldAlways => there is no top-level binding for - -- these things, so we must inline it. Only a few - -- primop-like things have compulsory unfoldings (see - -- MkId.lhs). Ignore is_active because we want to - -- inline even if SimplGently is on. - - InlineRule { ug_ir_info = inl_info, ug_small = uncond_inline } + InlineRule { ir_info = inl_info, ir_sat = sat } + | InlAlways <- inl_info -> True -- No top-level binding, so inline! + -- Ignore is_active because we want to + -- inline even if SimplGently is on. | not active_inline -> False | n_val_args < uf_arity -> yes_unsat -- Not enough value args - | uncond_inline -> True -- Note [INLINE for small functions] + | InlSmall <- inl_info -> True -- Note [INLINE for small functions] | otherwise -> some_benefit -- Saturated or over-saturated where -- See Note [Inlining an InlineRule] - yes_unsat = case inl_info of - InlSat -> False - _other -> interesting_args + yes_unsat = case sat of + InlSat -> False + InlUnSat -> interesting_args UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } | not active_inline -> False @@ -743,7 +742,7 @@ Consider {-# INLINE f #-} g y = f y Then f's RHS is no larger than its LHS, so we should inline it into even the most boring context. (We do so if there is no INLINE -pragma!) That's the reason for the 'inl_small' flag on an InlineRule. +pragma!) That's the reason for the 'ug_small' flag on an InlineRule. Note [Things to watch] @@ -899,7 +898,7 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info CaseCtxt -> res_discount _other -> 4 `min` res_discount -- res_discount can be very large when a function returns - -- construtors; but we only want to invoke that large discount + -- constructors; but we only want to invoke that large discount -- when there's a case continuation. -- Otherwise we, rather arbitrarily, threshold it. Yuk. -- But we want to aovid inlining large functions that return diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 9213e9c..3bdb79c 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -379,20 +379,24 @@ showAttributes stuff \begin{code} instance Outputable UnfoldingGuidance where ppr UnfoldNever = ptext (sLit "NEVER") - ppr UnfoldAlways = ptext (sLit "ALWAYS") - ppr (InlineRule { ug_ir_info = inl_info, ug_small = small }) - = ptext (sLit "InlineRule") <> ppr (inl_info,small) + ppr (InlineRule { ir_info = info, ir_sat = sat }) + = ptext (sLit "InlineRule") <> ppr (sat,info) ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) = hsep [ ptext (sLit "IF_ARGS"), brackets (hsep (map int cs)), int size, int discount ] -instance Outputable InlineRuleInfo where - ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w +instance Outputable InlSatFlag where ppr InlSat = ptext (sLit "sat") ppr InlUnSat = ptext (sLit "unsat") +instance Outputable InlineRuleInfo where + ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w + ppr InlSmall = ptext (sLit "small") + ppr InlAlways = ptext (sLit "always") + ppr InlVanilla = ptext (sLit "-") + instance Outputable Unfolding where ppr NoUnfolding = ptext (sLit "No unfolding") ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 549fce6..2c106b0 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1482,14 +1482,12 @@ toIfaceIdInfo id_info toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance }) = case guidance of - InlineRule { ug_ir_info = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs))) - InlineRule { ug_ir_info = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs))) - InlineRule { ug_ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w))) + InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w))) + InlineRule { ir_sat = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs))) + InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs))) UnfoldNever -> Nothing UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs))) - UnfoldAlways -> panic "toIfUnfolding:UnfoldAlways" - -- Never happens because we never have - -- bindings for unfold-always things + toIfUnfolding (DFunUnfolding _con ops) = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops))) -- No need to serialise the data constructor; diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index fc40f5a..dbca2e3 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1055,7 +1055,7 @@ tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs , uf_guidance = guide@(InlineRule {}) }) = unf { uf_tmpl = tidyExpr tidy_env rhs, -- Preserves OccInfo - uf_guidance = guide { ug_ir_info = tidyInl tidy_env (ug_ir_info guide) } } + uf_guidance = guide { ir_info = tidyInl tidy_env (ir_info guide) } } tidyUnfolding tidy_env _ (DFunUnfolding con ids) = DFunUnfolding con (map (tidyExpr tidy_env) ids) tidyUnfolding _ tidy_rhs (CoreUnfolding {}) diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 91e34f8..a3e3732 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -533,7 +533,7 @@ reOrderCycle depth (bind : binds) pairs -- where df is the exported dictionary. Then df makes a really -- bad choice for loop breaker - | Just inl_rule_info <- isInlineRule_maybe (idUnfolding bndr) + | Just (inl_rule_info, _) <- isInlineRule_maybe (idUnfolding bndr) = case inl_rule_info of InlWrapper {} -> 10 -- Note [INLINE pragmas] _other -> 3 -- Data structures are more important than this diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index c541096..56b07c4 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -410,7 +410,7 @@ Inlining is controlled partly by the SimplifierMode switch. This has two settings: SimplGently (a) Simplifying before specialiser/full laziness - (b) Simplifiying inside INLINE pragma + (b) Simplifiying inside InlineRules (c) Simplifying the LHS of a rule (d) Simplifying a GHCi expression or Template Haskell splice @@ -431,11 +431,11 @@ running it, we don't want to use -O2. Indeed, we don't want to inline anything, because the byte-code interpreter might get confused about unboxed tuples and suchlike. -INLINE pragmas -~~~~~~~~~~~~~~ -We don't simplify inside InlineRules (which come from INLINE pragmas). -It really is important to switch off inlinings inside such -expressions. Consider the following example +Note [Simplifying gently inside InlineRules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do much simplification inside InlineRules (which come from +INLINE pragmas). It really is important to switch off inlinings +inside such expressions. Consider the following example let f = \pq -> BIG in @@ -444,16 +444,14 @@ expressions. Consider the following example in ...g...g...g...g...g... Now, if that's the ONLY occurrence of f, it will be inlined inside g, -and thence copied multiple times when g is inlined. +and thence copied multiple times when g is inlined. - -This function may be inlinined in other modules, so we -don't want to remove (by inlining) calls to functions that have -specialisations, or that may have transformation rules in an importing -scope. +This function may be inlinined in other modules, so we don't want to +remove (by inlining) calls to functions that have specialisations, or +that may have transformation rules in an importing scope. E.g. {-# INLINE f #-} - f x = ...g... + f x = ...g... and suppose that g is strict *and* has specialisations. If we inline g's wrapper, we deny f the chance of getting the specialised version @@ -471,15 +469,14 @@ continuation. That's why the keep_inline predicate returns True for ArgOf continuations. It shouldn't do any harm not to dissolve the inline-me note under these circumstances. -Note that the result is that we do very little simplification -inside an InlineMe. +Although we do very little simplification inside an InlineRule, +the RHS is simplified as normal. For example: all xs = foldr (&&) True xs any p = all . map p {-# INLINE any #-} -Problem: any won't get deforested, and so if it's exported and the -importer doesn't use the inlining, (eg passes it as an arg) then we -won't get deforestation at all. We havn't solved this problem yet! +The RHS of 'any' will get optimised and deforested; but the InlineRule +will still mention the original RHS. preInlineUnconditionally diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index d169518..f9cbc0a 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -656,9 +656,10 @@ simplUnfolding env top_lvl _ _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_guidance = guide@(InlineRule {}) }) = do { expr' <- simplExpr (setMode SimplGently env) expr - ; let mb_wkr' = CoreSubst.substInlineRuleGuidance (mkCoreSubst env) (ug_ir_info guide) + -- See Note [Simplifying gently inside InlineRules] in SimplUtils + ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide) ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity - (guide { ug_ir_info = mb_wkr' })) } + (guide { ir_info = mb_wkr' })) } -- See Note [Top-level flag on inline rules] in CoreUnfold simplUnfolding _ top_lvl _ occ_info new_rhs _ diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index c51b27d..b772a3f 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -29,7 +29,6 @@ import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, isJust ) -import BasicTypes ( Arity ) import Bag import Util import Outputable @@ -809,15 +808,12 @@ specDefn subst body_uds fn rhs -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] - fn_has_inline_rule :: Maybe (InlineRuleInfo, Arity) -- Gives arity of the *specialised* inline rule - fn_has_inline_rule - | Just inl <- isInlineRule_maybe fn_unf - = case inl of - InlWrapper _ -> Just (InlUnSat, spec_arity) - _ -> Just (inl, spec_arity) - | otherwise = Nothing - where - spec_arity = unfoldingArity fn_unf - n_dicts + fn_has_inline_rule :: Maybe InlSatFlag -- Derive sat-flag from existing thing + fn_has_inline_rule = case isInlineRule_maybe fn_unf of + Just (_,sat) -> Just sat + Nothing -> Nothing + + spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs @@ -910,9 +906,9 @@ specDefn subst body_uds fn rhs final_uds = foldr consDictBind rhs_uds dx_binds -- See Note [Inline specialisations] - final_spec_f | Just (inl, spec_arity) <- fn_has_inline_rule + final_spec_f | Just sat <- fn_has_inline_rule = spec_f_w_arity `setInlineActivation` inline_act - `setIdUnfolding` mkInlineRule inl spec_rhs spec_arity + `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity -- I'm not sure this should be unconditionally InlSat | otherwise = spec_f_w_arity