[commit: ghc] wip/T15002: CSE: in bind_cse, adhere to noCSE (fixes #15002) (40b0fe5)

[git at git.haskell.org]

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

On branch  : wip/T15002
Link       : http://ghc.haskell.org/trac/ghc/changeset/40b0fe5e82d8213a03abdd2f9fb7c8edacf02f47/ghc

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

commit 40b0fe5e82d8213a03abdd2f9fb7c8edacf02f47
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Apr 5 10:02:25 2018 -0400

    CSE: in bind_cse, adhere to noCSE (fixes #15002)
    
    Previously, noCSE was only checked for self-recursive bindings, and
    non-recursive join points were happily CSE’ed, breaking the join point
    invariant. By checking noCSE in all cases of cseBind/cse_bind, this can
    be prevented.
    
    Eventually CSE for join points would be desirable (#13219).
    
    Differential Revision: https://phabricator.haskell.org/D4572


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

40b0fe5e82d8213a03abdd2f9fb7c8edacf02f47
 compiler/simplCore/CSE.hs                          | 21 ++++++++++++++++++++-
 testsuite/tests/simplCore/should_compile/T15002.hs | 12 ++++++++++++
 testsuite/tests/simplCore/should_compile/all.T     |  1 +
 3 files changed, 33 insertions(+), 1 deletion(-)

diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index 8f61128..6bdf4f0 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -276,6 +276,23 @@ We could try and be careful by tracking which join points are still valid at
 each subexpression, but since join points aren't allocated or shared, there's
 less to gain by trying to CSE them.
 
+Another way how CSE for joint points is tricky is
+
+  let join foo x = (x, 42)
+      join bar x = (x, 42)
+  in … jump foo 1 … jump bar 2 …
+
+naively, CSE would turn this into
+
+  let join foo x = (x, 42)
+      join bar = foo
+  in … jump foo 1 … jump bar 2 …
+
+but now bar is a join point with join-arity one, but a right-hand side that is
+not a lambda (came up in #15002)
+
+Eventually we might want to teach CSE to handle join points (#13219)
+
 Note [CSE for recursive bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -353,6 +370,9 @@ cse_bind toplevel env (in_id, in_rhs) out_id
       -- See Note [Take care with literal strings]
   = (env', (out_id, in_rhs))
 
+  | noCSE in_id
+  = (env', (out_id, in_rhs))
+
   | otherwise
   = (env', (out_id', out_rhs))
   where
@@ -370,7 +390,6 @@ addBinding :: CSEnv                      -- Includes InId->OutId cloning
 -- Note [Type-let] in CoreSyn), in which case we can just substitute.
 addBinding env in_id out_id rhs'
   | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)
-  | noCSE in_id      = (env,                              out_id)
   | use_subst        = (extendCSSubst env in_id rhs',     out_id)
   | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)
   where
diff --git a/testsuite/tests/simplCore/should_compile/T15002.hs b/testsuite/tests/simplCore/should_compile/T15002.hs
new file mode 100644
index 0000000..a5918c5
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T15002.hs
@@ -0,0 +1,12 @@
+module T15002 where
+
+import Control.Concurrent.MVar (MVar, modifyMVar_, putMVar)
+import Data.Foldable (for_)
+
+broadcastThen :: Either [MVar a] a -> MVar (Either [MVar a] a) -> a -> IO ()
+broadcastThen finalState mv x =
+    modifyMVar_ mv $ \mx -> do
+      case mx of
+        Left ls -> do for_ ls (`putMVar` x)
+                      return finalState
+        Right _ -> return finalState
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index a521a10..016b439 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -301,3 +301,4 @@ test('T14978',
      normal,
      run_command,
      ['$MAKE -s --no-print-directory T14978'])
+test('T15002', [ req_profiling ], compile, ['-O -fprof-auto -prof'])