[commit: ghc] master: Make binds in do-blocks strict when -XStrict (#11193) (419b6c0)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/419b6c00c194ccbd3c94539c26246dc41c88ed6c/ghc

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

commit 419b6c00c194ccbd3c94539c26246dc41c88ed6c
Author: Adam Sandberg Eriksson <adam at sandbergericsson.se>
Date:   Mon Dec 14 15:03:15 2015 +0100

    Make binds in do-blocks strict when -XStrict (#11193)
    
    Previously bindings in `do` blocks were omitted. With `-XStrict`
    ```lang=hs
    do content <- action
       other_things
    ```
    should be equivalent to
    ```lang=hs
    do !content <- action
       other_things
    ```
    
    Fixes #11193.
    
    Reviewers: bgamari, austin
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1612
    
    GHC Trac Issues: #11193


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

419b6c00c194ccbd3c94539c26246dc41c88ed6c
 compiler/deSugar/Match.hs                        | 20 +++++++++++---------
 testsuite/tests/deSugar/should_run/T11193.hs     |  8 ++++++++
 testsuite/tests/deSugar/should_run/T11193.stderr |  3 +++
 testsuite/tests/deSugar/should_run/all.T         |  1 +
 4 files changed, 23 insertions(+), 9 deletions(-)

diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 6ffa25d..f551fa4 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -700,7 +700,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
   where
     mk_eqn_info vars (L _ (Match _ pats _ grhss))
       = do { dflags <- getDynFlags
-           ; let upats = map (strictify dflags) pats
+           ; let upats = map (getMaybeStrictPat dflags) pats
                  dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
            ; tm_cs <- genCaseTmCs2 mb_scr upats vars
            ; match_result <- addDictsDs dicts $  -- See Note [Type and Term Equality Propagation]
@@ -708,10 +708,6 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
                                  dsGRHSs ctxt upats grhss rhs_ty
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
 
-    strictify dflags pat =
-      let (is_strict, pat') = getUnBangedLPat dflags pat
-      in if is_strict then BangPat pat' else unLoc pat'
-
     handleWarnings = if isGenerated origin
                      then discardWarningsDs
                      else id
@@ -760,21 +756,27 @@ matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
 -- Do not warn about incomplete patterns
 -- Used for things like [ e | pat <- stuff ], where
 -- incomplete patterns are just fine
-matchSinglePat (Var var) ctx (L _ pat) ty match_result
+matchSinglePat (Var var) ctx pat ty match_result
   = do { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs
-
+       ; let pat' = getMaybeStrictPat dflags pat
        -- pattern match check warnings
-       ; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle var pat)
+       ; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle var pat')
 
        ; match [var] ty
-               [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }] }
+               [EqnInfo { eqn_pats = [pat'], eqn_rhs  = match_result }] }
 
 matchSinglePat scrut hs_ctx pat ty match_result
   = do { var <- selectSimpleMatchVarL pat
        ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
        ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
 
+getMaybeStrictPat :: DynFlags -> LPat Id -> Pat Id
+getMaybeStrictPat dflags pat =
+  let (is_strict, pat') = getUnBangedLPat dflags pat
+  in if is_strict then BangPat pat' else unLoc pat'
+
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/testsuite/tests/deSugar/should_run/T11193.hs b/testsuite/tests/deSugar/should_run/T11193.hs
new file mode 100644
index 0000000..a8759a3
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T11193.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE Strict #-}
+
+module Main where
+
+main = do
+  ~a <- return (error "don't error here!")
+  b <- return (error "error here!") -- this binding should be strict
+  print "should never reach here"
diff --git a/testsuite/tests/deSugar/should_run/T11193.stderr b/testsuite/tests/deSugar/should_run/T11193.stderr
new file mode 100644
index 0000000..50e427c
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T11193.stderr
@@ -0,0 +1,3 @@
+T11193: error here!
+CallStack (from ImplicitParams):
+  error, called at T11193.hs:7:16 in main:Main
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index cc21ed7..9f50ea6 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -52,3 +52,4 @@ test('T10215', normal, compile_and_run, [''])
 test('DsStrictData', normal, compile_and_run, [''])
 test('DsStrict', normal, compile_and_run, [''])
 test('DsStrictLet', normal, compile_and_run, ['-O'])
+test('T11193', exit_code(1), compile_and_run, [''])