From a35f75aa20bf0a329be0b782986c3e12155b4d49 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 4 Oct 2006 11:10:00 +0000 Subject: [PATCH] Second bite at the rules-only idea This is part 2 of the patch that improved the interaction of RULES and recursion. It's vital that all Ids that may be referred to from later in the module are marked 'IAmALoopBreaker' because otherwise we may do postInlineUnconditionally, and lose the binding altogether. So I've added a boolean rules-only flag to IAmALoopBreaker. Now we can do inlining for rules-only loop-breakers. --- compiler/basicTypes/BasicTypes.lhs | 51 +++++++++++++++---- compiler/coreSyn/CoreUnfold.lhs | 10 ++-- compiler/main/TidyPgm.lhs | 4 +- compiler/simplCore/OccurAnal.lhs | 97 ++++++++++++++++-------------------- compiler/simplCore/SimplUtils.lhs | 3 +- compiler/simplCore/Simplify.lhs | 15 +++--- 6 files changed, 101 insertions(+), 79 deletions(-) diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index e6e3a90..d1ad0be 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -38,7 +38,7 @@ module BasicTypes( TupCon(..), tupleParens, OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, - isDeadOcc, isLoopBreaker, isNoOcc, + isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -372,13 +372,40 @@ data OccInfo | IAmDead -- Marks unused variables. Sometimes useful for -- lambda and case-bound variables. - | OneOcc !InsideLam -- Occurs exactly once, not inside a rule - !OneBranch - !InterestingCxt + | OneOcc -- Occurs exactly once, not inside a rule + !InsideLam + !OneBranch + !InterestingCxt | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers -- in a group of recursive definitions + !Bool -- True <=> This loop breaker occurs only the RHS of a RULE +\end{code} + +Note [RulesOnly] +~~~~~~~~~~~~~~~~ +The RulesOnly constructor records if an Id occurs only in the RHS of a Rule. +Similarly, the boolean in IAmLoopbreaker True if the only reason the Id is a +loop-breaker only because of recursion through a RULE. In that case, +we can ignore the loop-breaker-ness for inlining purposes. Example +(from GHC.Enum): + + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +The two look mutually recursive only because of their RULES; +we don't want that to inhibit inlining! + +\begin{code} isNoOcc :: OccInfo -> Bool isNoOcc NoOccInfo = True isNoOcc other = False @@ -405,8 +432,12 @@ oneBranch = True notOneBranch = False isLoopBreaker :: OccInfo -> Bool -isLoopBreaker IAmALoopBreaker = True -isLoopBreaker other = False +isLoopBreaker (IAmALoopBreaker _) = True +isLoopBreaker other = False + +isNonRuleLoopBreaker :: OccInfo -> Bool +isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle +isNonRuleLoopBreaker other = False isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True @@ -423,10 +454,10 @@ isFragileOcc other = False \begin{code} instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 - ppr NoOccInfo = empty - ppr RulesOnly = ptext SLIT("RulesOnly") - ppr IAmALoopBreaker = ptext SLIT("LoopBreaker") - ppr IAmDead = ptext SLIT("Dead") + ppr NoOccInfo = empty + ppr RulesOnly = ptext SLIT("RulesOnly") + ppr (IAmALoopBreaker ro) = ptext SLIT("LoopBreaker") <> if ro then char '!' else empty + ppr IAmDead = ptext SLIT("Dead") ppr (OneOcc inside_lam one_branch int_cxt) = ptext SLIT("Once") <> pp_lam <> pp_br <> pp_args where diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 6849510..6bb778d 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -532,11 +532,11 @@ callSiteInline dflags active_inline occ id arg_infos interesting_cont yes_or_no | not active_inline = False | otherwise = case occ of - IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False - IAmALoopBreaker -> False - --OneOcc in_lam _ _ -> (not in_lam || is_cheap) && consider_safe True - other -> is_cheap && consider_safe False - -- we consider even the once-in-one-branch + IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False + IAmALoopBreaker False -> False -- Note [RulesOnly] in BasicTypes + --OneOcc in_lam _ _ -> (not in_lam || is_cheap) && consider_safe True + other -> is_cheap && consider_safe False + -- We consider even the once-in-one-branch -- occurrences, because they won't all have been -- caught by preInlineUnconditionally. In particular, -- if the occurrence is once inside a lambda, and the diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index aee6743..976c32e 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -26,7 +26,7 @@ import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, import IdInfo {- loads of stuff -} import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) import NewDemand ( isBottomingSig, topSig ) -import BasicTypes ( Arity, isNeverActive ) +import BasicTypes ( Arity, isNeverActive, isNonRuleLoopBreaker ) import Name ( Name, getOccName, nameOccName, mkInternalName, localiseName, isExternalName, nameSrcLoc, nameParent_maybe, isWiredInName, getName @@ -462,7 +462,7 @@ addExternal (id,rhs) needed idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) - loop_breaker = isLoopBreaker (occInfo idinfo) + loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) worker_info = workerInfo idinfo diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index e6013f3..de16aac 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -35,7 +35,7 @@ import Maybes ( orElse ) import Digraph ( stronglyConnCompR, SCC(..) ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique ( Unique ) -import UniqFM ( keysUFM, lookupUFM_Directly ) +import UniqFM ( keysUFM ) import Util ( zipWithEqual, mapAndUnzip ) import Outputable \end{code} @@ -79,14 +79,6 @@ Bindings ~~~~~~~~ \begin{code} -type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached - -type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, - -- which is gotten from the Id. -type Details1 = (Id, UsageDetails, CoreExpr) -type Details2 = (IdWithOccInfo, CoreExpr) - - occAnalBind :: OccEnv -> CoreBind -> UsageDetails -- Usage details of scope @@ -198,17 +190,22 @@ occAnalBind env (Rec pairs) body_usage details = [details | (details, _, _) <- cycle] bndrs = [bndr | (bndr, _, _) <- details] rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details] - total_usage = foldr combineUsageDetails body_usage rhs_usages + rhs_usage = foldr1 combineUsageDetails rhs_usages + total_usage = rhs_usage `combineUsageDetails` body_usage (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs - final_bind = Rec (doReorder edges) + + new_cycle :: [Node Details2] + new_cycle = zipWithEqual "reorder" mk_node tagged_bndrs cycle + final_bind = Rec (reOrderCycle rhs_usage new_cycle) + mk_node tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys) + +{- An alternative; rebuild the edges. No semantic difference, but perf might change -- Hopefully 'bndrs' is a relatively small group now -- Now get ready for the loop-breaking phase, this time ignoring RulesOnly references -- We've done dead-code elimination already, so no worries about un-referenced binders - edges :: [Node Details2] - edges = zipWithEqual "reorder" mk_edge tagged_bndrs details keys = map idUnique bndrs - mk_edge tagged_bndr (_, rhs_usage, rhs') + mk_node tagged_bndr (_, rhs_usage, rhs') = ((tagged_bndr, rhs'), idUnique tagged_bndr, used) where used = [key | key <- keys, used_outside_rule rhs_usage key ] @@ -217,15 +214,16 @@ occAnalBind env (Rec pairs) body_usage Nothing -> False Just RulesOnly -> False -- Ignore rules other -> True +-} \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic strongly connected component (there's guaranteed to be a cycle). It returns the same pairs, but a) in a better order, - b) with some of the Ids having a IMustNotBeINLINEd pragma + b) with some of the Ids having a IAmALoopBreaker pragma -The "no-inline" Ids are sufficient to break all cycles in the SCC. This means +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means that the simplifier can guarantee not to loop provided it never records an inlining for these no-inline guys. @@ -252,53 +250,34 @@ My solution was to make a=b bindings record b as Many, rather like INLINE bindin Perhaps something cleverer would suffice. =============== -You might think that you can prevent non-termination simply by making -sure that we simplify a recursive binding's RHS in an environment that -simply clones the recursive Id. But no. Consider - - letrec f = \x -> let z = f x' in ... - - in - let n = f y - in - case n of { ... } - -We bind n to its *simplified* RHS, we then *re-simplify* it when -we inline n. Then we may well inline f; and then the same thing -happens with z! - -I don't think it's possible to prevent non-termination by environment -manipulation in this way. Apart from anything else, successive -iterations of the simplifier may unroll recursive loops in cases like -that above. The idea of beaking every recursive loop with an -IMustNotBeINLINEd pragma is much much better. - \begin{code} -doReorder :: [Node Details2] -> [Details2] --- Sorted into a plausible order. Enough of the Ids have --- dontINLINE pragmas that there are no loops left. -doReorder nodes = concatMap reOrderRec (stronglyConnCompR nodes) - -reOrderRec :: SCC (Node Details2) -> [Details2] - - -- Non-recursive case -reOrderRec (AcyclicSCC (bind, _, _)) = [bind] +type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached - -- Common case of simple self-recursion -reOrderRec (CyclicSCC []) - = panic "reOrderRec" +type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, + -- which is gotten from the Id. +type Details1 = (Id, UsageDetails, CoreExpr) +type Details2 = (IdWithOccInfo, CoreExpr) -reOrderRec (CyclicSCC [bind]) - = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] +reOrderRec :: UsageDetails -> SCC (Node Details2) -> [Details2] +-- Sorted into a plausible order. Enough of the Ids have +-- IAmALoopBreaker pragmas that there are no loops left. +reOrderRec rhs_usg (AcyclicSCC (bind, _, _)) = [bind] +reOrderRec rhs_usg (CyclicSCC cycle) = reOrderCycle rhs_usg cycle + +reOrderCycle :: UsageDetails -> [Node Details2] -> [Details2] +reOrderCycle rhs_usg [] + = panic "reOrderCycle" +reOrderCycle rhs_usg [bind] -- Common case of simple self-recursion + = [(makeLoopBreaker rhs_usg tagged_bndr, rhs)] where ((tagged_bndr, rhs), _, _) = bind -reOrderRec (CyclicSCC (bind : binds)) +reOrderCycle rhs_usg (bind : binds) = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out - doReorder unchosen ++ - [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] + concatMap (reOrderRec rhs_usg) (stronglyConnCompR unchosen) ++ + [(makeLoopBreaker rhs_usg tagged_bndr, rhs)] where (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds @@ -355,6 +334,16 @@ reOrderRec (CyclicSCC (bind : binds)) -- But we won't because constructor args are marked "Many". not_fun_ty ty = not (isFunTy (dropForAlls ty)) + +makeLoopBreaker :: UsageDetails -> Id -> Id +-- Set the loop-breaker flag, recording whether the thing occurs only in +-- the RHS of a RULE (in this recursive group) +makeLoopBreaker rhs_usg bndr + = setIdOccInfo bndr (IAmALoopBreaker rules_only) + where + rules_only = case lookupVarEnv rhs_usg bndr of + Just RulesOnly -> True + other -> False \end{code} @occAnalRhs@ deals with the question of bindings where the Id is marked diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index b9e98f7..2342491 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -721,7 +721,8 @@ postInlineUnconditionally -> Bool postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding | not active = False - | isLoopBreaker occ_info = False + | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, dont' inline + -- because it might be referred to "earlier" | isExportedId bndr = False | exprIsTrivial rhs = True | otherwise diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index e6a65f4..80aa89a 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -26,10 +26,8 @@ import Id ( Id, idType, idInfo, idArity, isDataConWorkId, idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda ) -import IdInfo ( OccInfo(..), isLoopBreaker, - setArityInfo, zapDemandInfo, - setUnfoldingInfo, - occInfo +import IdInfo ( OccInfo(..), setArityInfo, zapDemandInfo, + setUnfoldingInfo, occInfo ) import NewDemand ( isStrictDmd ) import TcGadt ( dataConCanMatch ) @@ -58,7 +56,7 @@ import VarEnv ( elemVarEnv, emptyVarEnv ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRec + RecFlag(..), isNonRec, isNonRuleLoopBreaker ) import OrdList import List ( nub ) @@ -600,14 +598,17 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs | otherwise = let - -- Add arity info + -- Arity info new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs + -- Unfolding info -- Add the unfolding *only* for non-loop-breakers -- Making loop breakers not have an unfolding at all -- means that we can avoid tests in exprIsConApp, for example. -- This is important: if exprIsConApp says 'yes' for a recursive -- thing, then we can get into an infinite loop + + -- Demand info -- If the unfolding is a value, the demand info may -- go pear-shaped, so we nuke it. Example: -- let x = (a,b) in @@ -635,7 +636,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs returnSmpl (unitFloat env final_id new_rhs, env) where unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs - loop_breaker = isLoopBreaker occ_info + loop_breaker = isNonRuleLoopBreaker occ_info old_info = idInfo old_bndr occ_info = occInfo old_info \end{code} -- 1.7.10.4