[commit: ghc] ghc-8.4: CSE: Walk past join point lambdas (#15002) (4edcef7)

[git at git.haskell.org]

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

On branch  : ghc-8.4
Link       : http://ghc.haskell.org/trac/ghc/changeset/4edcef7814704c594e8152ce01abad61159c5d39/ghc

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

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

    CSE: Walk past join point lambdas (#15002)
    
    As the CSE transformation traverses the syntax tree, it needs to go past
    the lambdas of a join point, and only look for CSE opportunities inside,
    as a join point’s lambdas must be preserved. Simple fix; comes with a
    Note and a test case.
    
    Thanks to Ryan Scott for an excellently minimized test case, and for
    bisecting GHC.
    
    Differential Revision: https://phabricator.haskell.org/D4572
    
    (cherry picked from commit ae0cff0a1834d8b041b06d0e1ab6ce969aac44c8)


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

4edcef7814704c594e8152ce01abad61159c5d39
 compiler/simplCore/CSE.hs                          | 34 ++++++++++++++++++++--
 testsuite/tests/simplCore/should_compile/T15002.hs | 12 ++++++++
 testsuite/tests/simplCore/should_compile/all.T     |  1 +
 3 files changed, 45 insertions(+), 2 deletions(-)

diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index c5958a4..055c68d 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -17,7 +17,7 @@ import Var              ( Var )
 import VarEnv           ( elemInScopeSet, mkInScopeSet )
 import Id               ( Id, idType, idInlineActivation, isDeadBinder
                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
-                        , isJoinId )
+                        , isJoinId, isJoinId_maybe )
 import CoreUtils        ( mkAltExpr, eqExpr
                         , exprIsTickedString
                         , stripTicksE, stripTicksT, mkTicks )
@@ -274,7 +274,28 @@ compiling ppHtml in Haddock.Backends.Xhtml).
 
 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.
+less to gain by trying to CSE them. (#13219)
+
+Note [Don’t tryForCSE the RHS of a Join Point]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 that claims arity one, but its right-hand side
+is not a lambda, breaking the join-point invariant (this was #15002).
+
+Therefore, `cse_bind` will zoom past the lambdas of a join point (using
+`collectNBinders`) and resume searching for CSE opportunities only in the body
+of the join point.
 
 Note [CSE for recursive bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -353,6 +374,13 @@ cse_bind toplevel env (in_id, in_rhs) out_id
       -- See Note [Take care with literal strings]
   = (env', (out_id, in_rhs))
 
+  | Just arity <- isJoinId_maybe in_id
+      -- See Note [Don’t tryForCSE the RHS of a Join Point]
+  = let (params, in_body) = collectNBinders arity in_rhs
+        (env', params') = addBinders env params
+        out_body = tryForCSE env' in_body
+    in (env, (out_id, mkLams params' out_body))
+
   | otherwise
   = (env', (out_id', out_rhs))
   where
@@ -392,6 +420,8 @@ addBinding env in_id out_id rhs'
                    Var {} -> True
                    _      -> False
 
+-- | Given a binder `let x = e`, this function
+-- determines whether we should add `e -> x` to the cs_map
 noCSE :: InId -> Bool
 noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&
             not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
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 e68f49c..c4b2f30 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -295,3 +295,4 @@ test('T14152a', [ only_ways(['optasm']), check_errmsg(r'dead code') ], compile,
 test('T13990', normal, compile, ['-dcore-lint -O'])
 test('T14650', normal, compile, ['-O2'])
 test('T14959', normal, compile, ['-O'])
+test('T15002', [ req_profiling ], compile, ['-O -fprof-auto -prof'])