[commit: ghc] ghc-8.2: Prevent ApplicativeDo from applying to strict pattern matches (#13875) (97aa533)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/97aa533fd8bcbd8e42b3358e8a07423ad2a2d01f/ghc

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

commit 97aa533fd8bcbd8e42b3358e8a07423ad2a2d01f
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Thu Jun 29 19:39:45 2017 -0400

    Prevent ApplicativeDo from applying to strict pattern matches (#13875)
    
    Test Plan:
    * New unit tests
    * validate
    
    Reviewers: dfeuer, simonpj, niteria, bgamari, austin, erikd
    
    Reviewed By: dfeuer
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #13875
    
    Differential Revision: https://phabricator.haskell.org/D3681
    
    (cherry picked from commit 1ef4156e45dcb258f6ef05cfb909547b8e3beb0f)


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

97aa533fd8bcbd8e42b3358e8a07423ad2a2d01f
 compiler/rename/RnExpr.hs         | 62 +++++++++++++++++++++++++++++++++++----
 testsuite/tests/ado/T13875.hs     | 36 +++++++++++++++++++++++
 testsuite/tests/ado/ado001.hs     | 10 +++++++
 testsuite/tests/ado/ado001.stdout |  1 +
 testsuite/tests/ado/all.T         |  1 +
 5 files changed, 104 insertions(+), 6 deletions(-)

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index fe3d308..001bc46 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -1622,12 +1622,8 @@ stmtTreeToStmts
 -- the bind form, which would give rise to a Monad constraint.
 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
                 tail _tail_fvs
-  | isIrrefutableHsPat pat, (False,tail') <- needJoin monad_names tail
-    -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
-    --          to know which types have only one constructor.  So only
-    --          tuples come out as irrefutable; other single-constructor
-    --          types, and newtypes, will not.  See the code for
-    --          isIrrefuatableHsPat
+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
+  -- See Note [ApplicativeDo and strict patterns]
   = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
 
 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
@@ -1702,6 +1698,8 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
     chunter _ [] = ([], [])
     chunter vars ((stmt,fvs) : rest)
        | not (isEmptyNameSet vars)
+       || isStrictPatternBind stmt
+           -- See Note [ApplicativeDo and strict patterns]
        = ((stmt,fvs) : chunk, rest')
        where (chunk,rest') = chunter vars' rest
              (pvars, evars) = stmtRefs stmt fvs
@@ -1714,6 +1712,58 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
       where fvs' = fvs `intersectNameSet` allvars
             pvars = mkNameSet (collectStmtBinders (unLoc stmt))
 
+    isStrictPatternBind :: ExprLStmt Name -> Bool
+    isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat
+    isStrictPatternBind _ = False
+
+{-
+Note [ApplicativeDo and strict patterns]
+
+A strict pattern match is really a dependency.  For example,
+
+do
+  (x,y) <- A
+  z <- B
+  return C
+
+The pattern (_,_) must be matched strictly before we do B.  If we
+allowed this to be transformed into
+
+  (\(x,y) -> \z -> C) <$> A <*> B
+
+then it could be lazier than the standard desuraging using >>=.  See #13875
+for more examples.
+
+Thus, whenever we have a strict pattern match, we treat it as a
+dependency between that statement and the following one.  The
+dependency prevents those two statements from being performed "in
+parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
+can do with the rest of the statements in the same "do" expression.
+-}
+
+isStrictPattern :: LPat id -> Bool
+isStrictPattern (L _ pat) =
+  case pat of
+    WildPat{} -> False
+    VarPat{}  -> False
+    LazyPat{} -> False
+    AsPat _ p -> isStrictPattern p
+    ParPat p  -> isStrictPattern p
+    ViewPat _ p _ -> isStrictPattern p
+    SigPatIn p _ -> isStrictPattern p
+    SigPatOut p _ -> isStrictPattern p
+    BangPat{} -> True
+    TuplePat{} -> True
+    SumPat{} -> True
+    PArrPat{} -> True
+    ConPatIn{} -> True
+    ConPatOut{} -> True
+    LitPat{} -> True
+    NPat{} -> True
+    NPlusKPat{} -> True
+    SplicePat{} -> True
+    _otherwise -> panic "isStrictPattern"
+
 isLetStmt :: LStmt a b -> Bool
 isLetStmt (L _ LetStmt{}) = True
 isLetStmt _ = False
diff --git a/testsuite/tests/ado/T13875.hs b/testsuite/tests/ado/T13875.hs
new file mode 100644
index 0000000..df35331
--- /dev/null
+++ b/testsuite/tests/ado/T13875.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE ApplicativeDo #-}
+module Main where
+
+import Control.Exception
+import Control.Monad
+import Data.Maybe
+import System.Exit
+
+test0 :: Maybe ()
+test0 = do
+  () <- Just undefined
+  () <- Just undefined
+  return ()
+
+test1 :: Maybe ()
+test1 = do
+  (_,_) <- Just undefined
+  return ()
+
+test2 :: Maybe (Int,Int)
+test2 = do
+  x <- return 1
+  () <- Just undefined
+  y <- return 2
+  return (x,y)
+
+main = do
+  b <- (print (isJust test0) >> return True)
+   `catch` \ErrorCall{} -> return False
+  when b $ die "failed0"
+  b <- (print (isJust test1) >> return True)
+   `catch` \ErrorCall{} -> return False
+  when b $ die "failed1"
+  b <- (print (isJust test2) >> return True)
+   `catch` \ErrorCall{} -> return False
+  when b $ die "failed2"
diff --git a/testsuite/tests/ado/ado001.hs b/testsuite/tests/ado/ado001.hs
index e452cdd..0d466c5 100644
--- a/testsuite/tests/ado/ado001.hs
+++ b/testsuite/tests/ado/ado001.hs
@@ -120,6 +120,15 @@ test11 = do
       x5 = x4
   return (const () (x1,x2,x3,x4))
 
+-- (a | (b ; c))
+-- The strict pattern match forces (b;c), but a can still be parallel (#13875)
+test12 :: M ()
+test12 = do
+  x1 <- a
+  () <- b
+  x2 <- c
+  return (const () (x1,x2))
+
 main = mapM_ run
  [ test1
  , test2
@@ -132,6 +141,7 @@ main = mapM_ run
  , test9
  , test10
  , test11
+ , test12
  ]
 
 -- 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 f7c48ca..365860f 100644
--- a/testsuite/tests/ado/ado001.stdout
+++ b/testsuite/tests/ado/ado001.stdout
@@ -9,3 +9,4 @@ a; ((b | c) | d)
 ((a | (b; c)) | d) | e
 ((a | b); (c | d)) | e
 a | b
+a | (b; c)
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index 6a1b4ec..a738c7a 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -9,3 +9,4 @@ test('T11607', normal, compile_and_run, [''])
 test('ado-optimal', normal, compile_and_run, [''])
 test('T12490', normal, compile, [''])
 test('T13242', normal, compile, [''])
+test('T13875', normal, compile_and_run, [''])