From: simonpj@microsoft.com Date: Tue, 3 Oct 2006 15:30:57 +0000 (+0000) Subject: Make recursion and RULES interact better X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c248518fe81b6d2807d3bcbb8a09ae14facce1ad Make recursion and RULES interact better See Trac #683 This patch improves the interaction of recursion and RULES; at least I hope it does. The problem was that a RULE was being treated uniformly like an "extra RHS". This worked badly when you have a non-recursive definition that is made recursive only by RULE. This patch maeks the occurrence analyser know whether a binder is referred to only from RULES (the RulesOnly constructor in OccInfo). Then we can ignore such edges when deciding on the order of bindings in a letrec, and when setting the LoopBreaker flag. The remaining potential problem is this: rec{ f = ...g... ; g = ...f... RULE g True = ... } The RULE for g may not be visible in f's rhs. This is fixable, but not today. --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index d73e4f1..e6e3a90 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -365,12 +365,14 @@ defn of OccInfo here, safely at the bottom \begin{code} data OccInfo - = NoOccInfo + = NoOccInfo -- Many occurrences, or unknown + + | RulesOnly -- Occurs only in the RHS of one or more rules | IAmDead -- Marks unused variables. Sometimes useful for -- lambda and case-bound variables. - | OneOcc !InsideLam + | OneOcc !InsideLam -- Occurs exactly once, not inside a rule !OneBranch !InterestingCxt @@ -422,6 +424,7 @@ isFragileOcc other = False 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 (OneOcc inside_lam one_branch int_cxt) diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 4e01fd3..aee6743 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -451,9 +451,10 @@ addExternal (id,rhs) needed = extendVarEnv (foldVarSet add_occ needed new_needed_ids) id show_unfold where - add_occ id needed = extendVarEnv needed id False + add_occ id needed | id `elemVarEnv` needed = needed + | otherwise = extendVarEnv needed id False -- "False" because we don't know we need the Id's unfolding - -- We'll override it later when we find the binding site + -- Don't override existing bindings; we might have already set it to True new_needed_ids = worker_ids `unionVarSet` unfold_ids `unionVarSet` diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 4082fcc..e6013f3 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 ) +import UniqFM ( keysUFM, lookupUFM_Directly ) import Util ( zipWithEqual, mapAndUnzip ) import Outputable \end{code} @@ -200,10 +200,23 @@ occAnalBind env (Rec pairs) body_usage rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details] total_usage = foldr combineUsageDetails body_usage rhs_usages (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs - final_bind = Rec (reOrderRec env new_cycle) - - new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_bndrs cycle) - mk_new_bind tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys) + final_bind = Rec (doReorder edges) + + -- 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') + = ((tagged_bndr, rhs'), idUnique tagged_bndr, used) + where + used = [key | key <- keys, used_outside_rule rhs_usage key ] + + used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of + Nothing -> False + Just RulesOnly -> False -- Ignore rules + other -> True \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic @@ -262,27 +275,29 @@ IMustNotBeINLINEd pragma is much much better. \begin{code} -reOrderRec - :: OccEnv - -> SCC (Node Details2) - -> [Details2] - -- Sorted into a plausible order. Enough of the Ids have - -- dontINLINE pragmas that there are no loops left. +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 env (AcyclicSCC (bind, _, _)) = [bind] +reOrderRec (AcyclicSCC (bind, _, _)) = [bind] -- Common case of simple self-recursion -reOrderRec env (CyclicSCC [bind]) +reOrderRec (CyclicSCC []) + = panic "reOrderRec" + +reOrderRec (CyclicSCC [bind]) = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] where ((tagged_bndr, rhs), _, _) = bind -reOrderRec env (CyclicSCC (bind : binds)) +reOrderRec (CyclicSCC (bind : binds)) = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out - concat (map (reOrderRec env) (stronglyConnCompR unchosen)) - ++ + doReorder unchosen ++ [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] where @@ -398,7 +413,7 @@ addRuleUsage :: UsageDetails -> Id -> UsageDetails addRuleUsage usage id = foldVarSet add usage (idRuleVars id) where - add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info + add v u = addOneOcc u v RulesOnly -- Give a non-committal binder info -- (i.e manyOcc) because many copies -- of the specialised thing can appear \end{code} @@ -824,20 +839,21 @@ markInsideLam occ = occ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo -addOccInfo IAmDead info2 = info2 -addOccInfo info1 IAmDead = info1 -addOccInfo info1 info2 = NoOccInfo +addOccInfo IAmDead info2 = info2 +addOccInfo info1 IAmDead = info1 +addOccInfo RulesOnly RulesOnly = RulesOnly +addOccInfo info1 info2 = NoOccInfo -- (orOccInfo orig new) is used -- when combining occurrence info from branches of a case orOccInfo IAmDead info2 = info2 orOccInfo info1 IAmDead = info1 +orOccInfo RulesOnly RulesOnly = RulesOnly orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1) (OneOcc in_lam2 one_branch2 int_cxt2) = OneOcc (in_lam1 || in_lam2) False -- False, because it occurs in both branches (int_cxt1 && int_cxt2) - orOccInfo info1 info2 = NoOccInfo \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index dffdd75..7c4a2ce 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -633,7 +633,6 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs final_id `seq` -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ returnSmpl (unitFloat env final_id new_rhs, env) - where unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs loop_breaker = isLoopBreaker occ_info