From 6a944ae7fe1e8e2e456c68717188463263f8978f Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 19 Nov 2009 12:57:11 +0000 Subject: [PATCH] Implement -fexpose-all-unfoldings, and fix a non-termination bug The -fexpose-all-unfoldings flag arranges to put unfoldings for *everything* in the interface file. Of course, this makes the file a lot bigger, but it also makes it complete, and that's great for supercompilation; or indeed any whole-program work. Consequences: * Interface files need to record loop-breaker-hood. (Previously, loop breakers were never exposed, so that info wasn't necessary.) Hence a small interface file format change. * When inlining, must check loop-breaker-hood. (Previously, loop breakers didn't have an unfolding at all, so no need to check.) * Ditto in exprIsConApp_maybe. Roman actually tripped this bug, because a DFun, which had an unfolding, was also a loop breaker * TidyPgm.tidyIdInfo must be careful to preserve loop-breaker-hood So Id.idUnfolding checks for loop-breaker-hood and returns NoUnfolding if so. When you want the unfolding regardless of loop-breaker-hood, use Id.realIdUnfolding. I have not documented the flag yet, because it's experimental. Nor have I tested it thoroughly. But with the flag off (the normal case) everything should work. --- compiler/basicTypes/BasicTypes.lhs | 16 ++++++++------ compiler/basicTypes/Id.lhs | 15 ++++++++++--- compiler/basicTypes/IdInfo.lhs | 4 ++-- compiler/coreSyn/CoreFVs.lhs | 5 ++++- compiler/coreSyn/CoreUnfold.lhs | 11 +++++----- compiler/coreSyn/CoreUtils.lhs | 14 +++++++----- compiler/deSugar/DsBinds.lhs | 2 +- compiler/iface/BinIface.hs | 8 ++++--- compiler/iface/IfaceSyn.lhs | 17 +++++++++++---- compiler/iface/MkIface.lhs | 30 +++++++++++++++----------- compiler/iface/TcIface.lhs | 8 +++++-- compiler/main/DynFlags.hs | 8 +++++-- compiler/main/TidyPgm.lhs | 42 +++++++++++++++++++++++------------- compiler/prelude/PrelRules.lhs | 6 +++--- compiler/simplCore/OccurAnal.lhs | 5 +++-- compiler/simplCore/Simplify.lhs | 16 ++++++++------ compiler/specialise/Specialise.lhs | 2 +- 17 files changed, 135 insertions(+), 74 deletions(-) diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 9b21399..849d507 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -42,8 +42,9 @@ module BasicTypes( TupCon(..), tupleParens, - OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, + OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, + nonRuleLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -476,17 +477,20 @@ isNonRuleLoopBreaker :: OccInfo -> Bool isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle isNonRuleLoopBreaker _ = False +nonRuleLoopBreaker :: OccInfo +nonRuleLoopBreaker = IAmALoopBreaker False + isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True isDeadOcc _ = False isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc _ _ _) = True -isOneOcc _ = False +isOneOcc (OneOcc {}) = True +isOneOcc _ = False -isFragileOcc :: OccInfo -> Bool -isFragileOcc (OneOcc _ _ _) = True -isFragileOcc _ = False +zapFragileOcc :: OccInfo -> OccInfo +zapFragileOcc (OneOcc {}) = NoOccInfo +zapFragileOcc occ = occ \end{code} \begin{code} diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 8712db1..b72d8c2 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -69,7 +69,7 @@ module Id ( idArity, idNewDemandInfo, idNewDemandInfo_maybe, idNewStrictness, idNewStrictness_maybe, - idUnfolding, + idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idLBVarInfo, @@ -99,7 +99,7 @@ module Id ( #include "HsVersions.h" -import CoreSyn ( CoreRule, Unfolding ) +import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) ) import IdInfo import BasicTypes @@ -510,7 +510,16 @@ isStrictId id --------------------------------- -- UNFOLDING idUnfolding :: Id -> Unfolding -idUnfolding id = unfoldingInfo (idInfo id) +-- Do not expose the unfolding of a loop breaker! +idUnfolding id + | isNonRuleLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info + where + info = idInfo id + +realIdUnfolding :: Id -> Unfolding +-- Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 9446f7d..9b74a48 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -58,7 +58,7 @@ module IdInfo ( -- ** The OccInfo type OccInfo(..), - isFragileOcc, isDeadOcc, isLoopBreaker, + isDeadOcc, isLoopBreaker, occInfo, setOccInfo, InsideLam, OneBranch, @@ -723,7 +723,7 @@ zapFragileInfo :: IdInfo -> Maybe IdInfo zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo `setUnfoldingInfo` noUnfolding - `setOccInfo` if isFragileOcc occ then NoOccInfo else occ) + `setOccInfo` zapFragileOcc occ) where occ = occInfo info \end{code} diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index f94f61d..3ff583e 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -416,8 +416,11 @@ idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) idUnfoldingVars :: Id -> VarSet -- Produce free vars for an unfolding, but NOT for an ordinary -- (non-inline) unfolding, since it is a dup of the rhs +-- and we'll get exponential behaviour if we look at both unf and rhs! +-- But do look at the *real* unfolding, even for loop breakers, else +-- we might get out-of-scope variables idUnfoldingVars id - = case idUnfolding id of + = case realIdUnfolding id of CoreUnfolding { uf_tmpl = rhs, uf_guidance = InlineRule {} } -> exprFreeVars rhs DFunUnfolding _ args -> exprsFreeVars args diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 654cfa7..fd76f23 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -633,10 +633,7 @@ instance Outputable CallCtxt where ppr ValAppCtxt = ptext (sLit "ValAppCtxt") callSiteInline dflags active_inline id lone_variable arg_infos cont_info - = let - n_val_args = length arg_infos - in - case idUnfolding id of { + = case idUnfolding id of { NoUnfolding -> Nothing ; OtherCon _ -> Nothing ; DFunUnfolding {} -> Nothing ; -- Never unfold a DFun @@ -645,6 +642,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules let + n_val_args = length arg_infos + result | yes_or_no = Just unf_template | otherwise = Nothing @@ -1132,7 +1131,9 @@ exprIsConApp_maybe expr analyse rhs args where is_saturated = count isValArg args == idArity fun - unfolding = idUnfolding fun + unfolding = idUnfolding fun -- Does not look through loop breakers + -- ToDo: we *may* look through variables that are NOINLINE + -- in this phase, and that is really not right analyse _ _ = Nothing diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index d200f81..9761db1 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -507,17 +507,20 @@ exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x || exprIsCheap' is_conlike e + exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e && - and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts] + and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) -- This improves arities of overloaded functions where -- there is only dictionary selection (no construction) involved + exprIsCheap' is_conlike (Let (NonRec x _) e) | isUnLiftedType (idType x) = exprIsCheap' is_conlike e | otherwise = False - -- strict lets always have cheap right hand sides, - -- and do no allocation. + -- Strict lets always have cheap right hand sides, + -- and do no allocation, so just look at the body + -- Non-strict lets do allocation so we don't treat them as cheap exprIsCheap' is_conlike other_expr -- Applications and variables = go other_expr [] @@ -725,8 +728,9 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value - -- A worry: what if an Id's unfolding is just itself: - -- then we could get an infinite loop... + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop is_hnf_like (Lit _) = True is_hnf_like (Type _) = True -- Types are honorary Values; diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 3fe8d54..0bb7045 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -452,7 +452,7 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } | otherwise -> do - { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id) + { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id) ; let f_body = fix_up (Let mono_bind (Var mono_id)) spec_ty = exprType ds_spec_expr diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 323e269..ce023d7 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1161,8 +1161,9 @@ instance Binary IfaceInfoItem where put_ bh (HsStrictness ab) = do putByte bh 1 put_ bh ab - put_ bh (HsUnfold ad) = do + put_ bh (HsUnfold lb ad) = do putByte bh 2 + put_ bh lb put_ bh ad put_ bh (HsInline ad) = do putByte bh 3 @@ -1176,8 +1177,9 @@ instance Binary IfaceInfoItem where return (HsArity aa) 1 -> do ab <- get bh return (HsStrictness ab) - 2 -> do ad <- get bh - return (HsUnfold ad) + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) 3 -> do ad <- get bh return (HsInline ad) _ -> do return HsNoCafRefs diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 2e2967d..4311e65 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -202,7 +202,8 @@ data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma - | HsUnfold IfaceUnfolding + | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs -- NB: Specialisations and rules come in separately and are @@ -256,6 +257,13 @@ data IfaceBinding data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo \end{code} +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + Note [IdInfo on nested let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Occasionally we want to preserve IdInfo on nested let bindings. The one @@ -660,7 +668,8 @@ instance Outputable IfaceIdInfo where ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> ppr unf + ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) + <> colon <+> ppr unf ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str @@ -786,8 +795,8 @@ freeNamesIfIdInfo NoInfo = emptyNameSet freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet -freeNamesItem (HsUnfold u) = freeNamesIfUnfold u -freeNamesItem _ = emptyNameSet +freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u +freeNamesItem _ = emptyNameSet freeNamesIfUnfold :: IfaceUnfolding -> NameSet freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 0bfdae7..4da21d8 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1471,7 +1471,8 @@ toIfaceIdInfo id_info _other -> Nothing ------------ Unfolding -------------- - unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info) + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isNonRuleLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info @@ -1479,20 +1480,25 @@ toIfaceIdInfo id_info | otherwise = Just (HsInline inline_prag) -------------------------- -toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem -toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance }) +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance }) = case guidance of - 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))) - -toIfUnfolding (DFunUnfolding _con ops) - = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops))) + InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold lb (IfWrapper arity (idName w))) + InlineRule { ir_sat = InlSat } -> Just (HsUnfold lb (IfInlineRule arity True (toIfaceExpr rhs))) + InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold lb (IfInlineRule arity False (toIfaceExpr rhs))) + UnfoldIfGoodArgs {} -> vanilla_unfold + UnfoldNever -> vanilla_unfold -- Yes, even if guidance is UnfoldNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + where + vanilla_unfold = Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs))) + +toIfUnfolding lb (DFunUnfolding _con ops) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun -toIfUnfolding _ +toIfUnfolding _ _ = Nothing -------------------------- diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 689dd4b..e1588a1 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -40,6 +40,7 @@ import DataCon import TysWiredIn import TysPrim ( anyTyConOfKind ) import Var ( TyVar ) +import BasicTypes ( nonRuleLoopBreaker ) import qualified Var import VarEnv import Name @@ -993,8 +994,11 @@ tcIdInfo ignore_prags name ty info tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) -- The next two are lazy, so they don't transitively suck stuff in - tcPrag info (HsUnfold if_unf) = do { unf <- tcUnfolding name ty info if_unf - ; return (info `setUnfoldingInfoLazily` unf) } + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding name ty info if_unf + ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfoLazily` unf) } \end{code} \begin{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 862e064..10ab3d0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -270,8 +270,6 @@ data DynFlag | Opt_CSE | Opt_LiberateCase | Opt_SpecConstr - | Opt_IgnoreInterfacePragmas - | Opt_OmitInterfacePragmas | Opt_DoLambdaEtaExpansion | Opt_IgnoreAsserts | Opt_DoEtaReduction @@ -284,6 +282,11 @@ data DynFlag | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + -- profiling opts | Opt_AutoSccsOnAllToplevs | Opt_AutoSccsOnExportedToplevs @@ -1728,6 +1731,7 @@ fFlags = [ ( "cse", Opt_CSE, const Supported ), ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, const Supported ), ( "omit-interface-pragmas", Opt_OmitInterfacePragmas, const Supported ), + ( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, const Supported ), ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, const Supported ), ( "ignore-asserts", Opt_IgnoreAsserts, const Supported ), ( "do-eta-reduction", Opt_DoEtaReduction, const Supported ), diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index dbca2e3..ffe0eca 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -298,6 +298,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, = do { let { dflags = hsc_dflags hsc_env ; omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = dopt Opt_TemplateHaskell dflags } ; showPass dflags "Tidy Core" @@ -305,7 +306,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ; let { implicit_binds = getImplicitBinds type_env } ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_rules + <- chooseExternalIds hsc_env mod omit_prags expose_all + binds implicit_binds imp_rules ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env } -- See Note [Which rules to expose] @@ -353,7 +355,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_insts, - md_vect_info = tidy_vect_info, md_fam_insts = fam_insts, + md_vect_info = tidy_vect_info, + md_fam_insts = fam_insts, md_exports = exports, md_anns = anns -- are already tidy }) @@ -550,7 +553,7 @@ getImplicitBinds type_env implicit_ids _ = [] get_defn :: Id -> CoreBind - get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) + get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) \end{code} @@ -572,14 +575,14 @@ type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) chooseExternalIds :: HscEnv -> Module - -> Bool + -> Bool -> Bool -> [CoreBind] -> [CoreBind] -> [CoreRule] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules +chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 } @@ -650,7 +653,7 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules let (new_ids, show_unfold) | omit_prags = ([], False) - | otherwise = addExternal refined_id + | otherwise = addExternal expose_all refined_id -- 'idocc' is an *occurrence*, but we need to see the -- unfolding in the *definition*; so look up in binder_set @@ -672,8 +675,8 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env' -addExternal :: Id -> ([Id],Bool) -addExternal id = (new_needed_ids, show_unfold) +addExternal :: Bool -> Id -> ([Id],Bool) +addExternal expose_all id = (new_needed_ids, show_unfold) where new_needed_ids = unfold_ids ++ filter (\id -> isLocalId id && @@ -695,10 +698,12 @@ addExternal id = (new_needed_ids, show_unfold) mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold mb_unfold_ids = case unfoldingInfo idinfo of CoreUnfolding { uf_tmpl = unf_rhs, uf_guidance = guide } - | not bottoming_fn -- Not necessary - , not dont_inline - , not loop_breaker - , not (neverUnfoldGuidance guide) + | expose_all || -- expose_all says to expose all + -- unfoldings willy-nilly + not (bottoming_fn -- No need to inline bottom functions + || dont_inline -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance guide) -> Just (exprFvsInOrder unf_rhs) DFunUnfolding _ ops -> Just (exprsFvsInOrder ops) _ -> Nothing @@ -987,7 +992,8 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) idinfo = idInfo bndr idinfo' = tidyTopIdInfo (isExternalName name') idinfo unfold_info - arity caf_info + arity caf_info + (occInfo idinfo) unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs1 (unfoldingInfo idinfo) | otherwise = noUnfolding @@ -1027,19 +1033,21 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. tidyTopIdInfo :: Bool -> IdInfo -> Unfolding - -> ArityInfo -> CafInfo + -> ArityInfo -> CafInfo -> OccInfo -> IdInfo -tidyTopIdInfo is_external idinfo unfold_info arity caf_info +tidyTopIdInfo is_external idinfo unfold_info arity caf_info occ_info | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. CoreTidy.tidyLetBndr + `setOccInfo` robust_occ_info `setCafInfo` caf_info `setArityInfo` arity `setAllStrictnessInfo` newStrictnessInfo idinfo | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo + `setOccInfo` robust_occ_info `setCafInfo` caf_info `setArityInfo` arity `setAllStrictnessInfo` newStrictnessInfo idinfo @@ -1047,6 +1055,10 @@ tidyTopIdInfo is_external idinfo unfold_info arity caf_info `setUnfoldingInfo` unfold_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules + where + robust_occ_info = zapFragileOcc occ_info + -- It's important to keep loop-breaker information + -- when we are doing -fexpose-all-unfoldings diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 236cee6..1515fb9 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -21,7 +21,7 @@ module PrelRules ( primOpRules, builtinRules ) where import CoreSyn import MkCore ( mkWildCase ) -import Id ( idUnfolding ) +import Id ( realIdUnfolding ) import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit @@ -551,7 +551,7 @@ match_eq_string _ = Nothing --------------------------------------------------- -- The rule is this: -- inline f_ty (f a b c) = a b c --- (if f has an unfolding) +-- (if f has an unfolding, EVEN if it's a loop breaker) -- -- It's important to allow the argument to 'inline' to have args itself -- (a) because its more forgiving to allow the programmer to write @@ -564,7 +564,7 @@ match_eq_string _ = Nothing match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_inline (Type _ : e : _) | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (idUnfolding f) + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) = Just (mkApps unf args1) match_inline _ = Nothing diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 53a89d5..5824874 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -559,8 +559,9 @@ reOrderCycle depth (bind : binds) pairs | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined - | canUnfold (idUnfolding bndr) = 1 - -- the Id has some kind of unfolding + | canUnfold (realIdUnfolding bndr) = 1 + -- The Id has some kind of unfolding + -- Ignore loop-breaker-ness here because that is what we are setting! | otherwise = 0 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 5e63221..eb2884c 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -35,8 +35,7 @@ import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRuleLoopBreaker ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM ) import Maybes ( orElse ) import Data.List ( mapAccumL ) @@ -680,11 +679,14 @@ simplUnfolding env top_lvl _ _ _ (guide { ir_info = mb_wkr' })) } -- See Note [Top-level flag on inline rules] in CoreUnfold -simplUnfolding _ top_lvl _ occ_info new_rhs _ - | omit_unfolding = return NoUnfolding - | otherwise = return (mkUnfolding (isTopLevel top_lvl) new_rhs) - where - omit_unfolding = isNonRuleLoopBreaker occ_info +simplUnfolding _ top_lvl _ _occ_info new_rhs _ + = return (mkUnfolding (isTopLevel top_lvl) new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. \end{code} Note [Arity decrease] diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index b772a3f..6d071e2 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -800,7 +800,7 @@ specDefn subst body_uds fn rhs where fn_type = idType fn fn_arity = idArity fn - fn_unf = idUnfolding fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta -- 1.7.10.4