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 (file)
--- 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 
 
 \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.
 
 
   | 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
 
           !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
 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)
   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 (file)
--- 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
   = 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
        -- "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`
 
     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 (file)
--- 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 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}
 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
        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
 \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}
 
 
 \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
 
        -- Non-recursive case

-reOrderRec env (AcyclicSCC (bind, _, _)) = [bind]
+reOrderRec (AcyclicSCC (bind, _, _)) = [bind]

 
        -- Common case of simple self-recursion
 
        -- 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
 
   = [(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
   =    -- 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
     [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
 
   where

@@ -398,7 +413,7 @@ addRuleUsage :: UsageDetails -> Id -> UsageDetails
 addRuleUsage usage id
   = foldVarSet add usage (idRuleVars id)
   where
 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}
                                                -- (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, 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 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 (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}
 orOccInfo info1 info2 = NoOccInfo
 \end{code}

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index dffdd75..7c4a2ce 100644 (file)
--- 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)
     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
   where 
     unfolding    = mkUnfolding (isTopLevel top_lvl) new_rhs
     loop_breaker = isLoopBreaker occ_info