[commit: ghc] master: Ensure that loop breakers are computed when glomming (5fa6e75)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/5fa6e75960b3dddbc72c35eb3fc0f2759215dfbb/ghc

>---------------------------------------------------------------

commit 5fa6e75960b3dddbc72c35eb3fc0f2759215dfbb
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Sep 19 14:51:54 2014 +0100

    Ensure that loop breakers are computed when glomming
    
    This patch fixes Trac #9583, a loop in the simplifier.
    
    I thought this was going to be very complicated but it turned out to
    be very simple!  The occurrence analyser does something called
    "glomming" if the application of imported RULES means that something
    that didn't look recursive becomes recursive.  See `Note [Glomming]`
    in `OccurAnal`.  Under these circumstances we group all the top-level
    bindings into a single massive `Rec`.
    
    But, crucially, I failed to repeat the occurrence analysis on this
    glommed set of bindings.  That means that we weren't establishing the
    right loop breakers (indeed there were no loop breakers whatsoever),
    and that led immediately to the loop. The only surprising this is that
    it didn't happen before.


>---------------------------------------------------------------

5fa6e75960b3dddbc72c35eb3fc0f2759215dfbb
 compiler/simplCore/OccurAnal.lhs | 34 ++++++++++++++++++++++++++--------
 1 file changed, 26 insertions(+), 8 deletions(-)

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index ca0fc22..3477073 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -59,13 +59,21 @@ occurAnalysePgm :: Module       -- Used only in debug output
                 -> CoreProgram -> CoreProgram
 occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds
   | isEmptyVarEnv final_usage
-  = binds'
+  = occ_anald_binds
+
   | otherwise   -- See Note [Glomming]
   = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)
                    2 (ppr final_usage ) )
-    [Rec (flattenBinds binds')]
+    occ_anald_glommed_binds
   where
-    (final_usage, binds') = go (initOccEnv active_rule) binds
+    init_env = initOccEnv active_rule
+    (final_usage, occ_anald_binds) = go init_env binds
+    (_, occ_anald_glommed_binds)   = occAnalRecBind init_env imp_rules_edges
+                                                    (flattenBinds occ_anald_binds)
+                                                    initial_uds
+          -- It's crucial to re-analyse the glommed-together bindings
+          -- so that we establish the right loop breakers. Otherwise
+          -- we can easily create an infinite loop (Trac #9583 is an example)
 
     initial_uds = addIdOccs emptyDetails
                             (rulesFreeVars imp_rules `unionVarSet`
@@ -90,7 +98,7 @@ occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds
         = (final_usage, bind' ++ binds')
         where
            (bs_usage, binds')   = go env binds
-           (final_usage, bind') = occAnalBind env env imp_rules_edges bind bs_usage
+           (final_usage, bind') = occAnalBind env imp_rules_edges bind bs_usage
 
 occurAnalyseExpr :: CoreExpr -> CoreExpr
         -- Do occurrence analysis, and discard occurrence info returned
@@ -120,14 +128,21 @@ Bindings
 
 \begin{code}
 occAnalBind :: OccEnv           -- The incoming OccEnv
-            -> OccEnv           -- Same, but trimmed by (binderOf bind)
             -> IdEnv IdSet      -- Mapping from FVs of imported RULE LHSs to RHS FVs
             -> CoreBind
             -> UsageDetails             -- Usage details of scope
             -> (UsageDetails,           -- Of the whole let(rec)
                 [CoreBind])
 
-occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage
+occAnalBind env imp_rules_edges (NonRec binder rhs) body_usage
+  = occAnalNonRecBind env imp_rules_edges binder rhs body_usage
+occAnalBind env imp_rules_edges (Rec pairs) body_usage
+  = occAnalRecBind env imp_rules_edges pairs body_usage
+
+-----------------
+occAnalNonRecBind :: OccEnv -> IdEnv IdSet -> Var -> CoreExpr
+                  -> UsageDetails -> (UsageDetails, [CoreBind])
+occAnalNonRecBind env imp_rules_edges binder rhs body_usage
   | isTyVar binder      -- A type let; we don't gather usage info
   = (body_usage, [NonRec binder rhs])
 
@@ -145,7 +160,10 @@ occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage
     rhs_usage4 = maybe rhs_usage3 (addIdOccs rhs_usage3) $ lookupVarEnv imp_rules_edges binder
        -- See Note [Preventing loops due to imported functions rules]
 
-occAnalBind _ env imp_rules_edges (Rec pairs) body_usage
+-----------------
+occAnalRecBind :: OccEnv -> IdEnv IdSet -> [(Var,CoreExpr)]
+               -> UsageDetails -> (UsageDetails, [CoreBind])
+occAnalRecBind env imp_rules_edges pairs body_usage
   = foldr occAnalRec (body_usage, []) sccs
         -- For a recursive group, we
         --      * occ-analyse all the RHSs
@@ -1264,7 +1282,7 @@ occAnal env (Case scrut bndr ty alts)
 
 occAnal env (Let bind body)
   = case occAnal env body                                of { (body_usage, body') ->
-    case occAnalBind env env emptyVarEnv bind body_usage of { (final_usage, new_binds) ->
+    case occAnalBind env emptyVarEnv bind body_usage of { (final_usage, new_binds) ->
        (final_usage, mkLets new_binds body') }}
 
 occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])