[commit: ghc] ghc-8.0: Fix a bug in ApplicativeDo (#11612) (e3020f2)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/e3020f26e322e0fcbc7ea2403479d6a734578bc8/ghc

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

commit e3020f26e322e0fcbc7ea2403479d6a734578bc8
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Sat Feb 20 07:23:37 2016 +0000

    Fix a bug in ApplicativeDo (#11612)
    
    In some cases ApplicativeDo would miss some opportunities, due to a
    wrong calculation of free variables in RnExpr.segments.
    
    (cherry picked from commit 3259bf658662e7052ae91de2fa27baae8c84b7fa)


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

e3020f26e322e0fcbc7ea2403479d6a734578bc8
 compiler/rename/RnExpr.hs         | 27 +++++++++++++++++++++------
 testsuite/tests/ado/ado001.hs     | 12 ++++++++++++
 testsuite/tests/ado/ado001.stdout |  1 +
 3 files changed, 34 insertions(+), 6 deletions(-)

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 616f259..9d1200a 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -1549,24 +1549,36 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
           _otherwise -> (seg,all_lets) : rest
       where
         rest = merge segs
-        all_lets = all (not . isBindStmt . fst) seg
+        all_lets = all (isLetStmt . fst) seg
 
+    -- walk splits the statement sequence into segments, traversing
+    -- the sequence from the back to the front, and keeping track of
+    -- the set of free variables of the current segment.  Whenever
+    -- this set of free variables is empty, we have a complete segment.
+    walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]]
     walk [] = []
     walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
-      where (seg,rest) = chunter (fvs `intersectNameSet` allvars) stmts
+      where (seg,rest) = chunter fvs' stmts
+            (_, fvs') = stmtRefs stmt fvs
 
     chunter _ [] = ([], [])
     chunter vars ((stmt,fvs) : rest)
        | not (isEmptyNameSet vars)
        = ((stmt,fvs) : chunk, rest')
        where (chunk,rest') = chunter vars' rest
-             evars = fvs `intersectNameSet` allvars
-             pvars = mkNameSet (collectStmtBinders (unLoc stmt))
+             (pvars, evars) = stmtRefs stmt fvs
              vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
     chunter _ rest = ([], rest)
 
-    isBindStmt (L _ BindStmt{}) = True
-    isBindStmt _ = False
+    stmtRefs stmt fvs
+      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
+      | otherwise      = (pvars, fvs')
+      where fvs' = fvs `intersectNameSet` allvars
+            pvars = mkNameSet (collectStmtBinders (unLoc stmt))
+
+isLetStmt :: LStmt a b -> Bool
+isLetStmt (L _ LetStmt{}) = True
+isLetStmt _ = False
 
 -- | Find a "good" place to insert a bind in an indivisible segment.
 -- This is the only place where we use heuristics.  The current
@@ -1576,6 +1588,9 @@ splitSegment
   :: [(ExprLStmt Name, FreeVars)]
   -> ( [(ExprLStmt Name, FreeVars)]
      , [(ExprLStmt Name, FreeVars)] )
+splitSegment [one,two] = ([one],[two])
+  -- there is no choice when there are only two statements; this just saves
+  -- some work in a common case.
 splitSegment stmts
   | Just (lets,binds,rest) <- slurpIndependentStmts stmts
   =  if not (null lets)
diff --git a/testsuite/tests/ado/ado001.hs b/testsuite/tests/ado/ado001.hs
index 9f8f8da..e452cdd 100644
--- a/testsuite/tests/ado/ado001.hs
+++ b/testsuite/tests/ado/ado001.hs
@@ -109,6 +109,17 @@ test10 = do
   x5 <- e
   return (const () (x3,x4,x5))
 
+-- (a | b)
+-- This demonstrated a bug in RnExpr.segments (#11612)
+test11 :: M ()
+test11 = do
+  x1 <- a
+  let x2 = x1
+  x3 <- b
+  let x4 = c
+      x5 = x4
+  return (const () (x1,x2,x3,x4))
+
 main = mapM_ run
  [ test1
  , test2
@@ -120,6 +131,7 @@ main = mapM_ run
  , test8
  , test9
  , test10
+ , test11
  ]
 
 -- Testing code, prints out the structure of a monad/applicative expression
diff --git a/testsuite/tests/ado/ado001.stdout b/testsuite/tests/ado/ado001.stdout
index 93e300c..f7c48ca 100644
--- a/testsuite/tests/ado/ado001.stdout
+++ b/testsuite/tests/ado/ado001.stdout
@@ -8,3 +8,4 @@ a; (b | (c; (d; (e | (f; g)))))
 a; ((b | c) | d)
 ((a | (b; c)) | d) | e
 ((a | b); (c | d)) | e
+a | b