[commit: ghc] wip/T15002: In CSE: Look past join point lambdas (7c4e7fb)

[git at git.haskell.org]

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

On branch  : wip/T15002
Link       : http://ghc.haskell.org/trac/ghc/changeset/7c4e7fbf1a3b5dc2dfd856d257f69a99f0f2c548/ghc

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

commit 7c4e7fbf1a3b5dc2dfd856d257f69a99f0f2c548
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Apr 9 15:05:00 2018 -0400

    In CSE: Look past join point lambdas
    
    This is a more promising apporach to fix #15002. If Harbormaster and
    perf.haskell.org are happy with it, I’ll add the note explaining why
    this is needed.


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

7c4e7fbf1a3b5dc2dfd856d257f69a99f0f2c548
 compiler/simplCore/CSE.hs | 12 +++++++++---
 1 file changed, 9 insertions(+), 3 deletions(-)

diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index 865ab6a..17d8f4c 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 )
@@ -370,8 +370,11 @@ cse_bind toplevel env (in_id, in_rhs) out_id
       -- See Note [Take care with literal strings]
   = (env', (out_id, in_rhs))
 
-  | isJoinId in_id
-  = (env', (out_id, in_rhs))
+  | Just arity <- isJoinId_maybe in_id
+  = 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))
@@ -390,6 +393,7 @@ 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
@@ -411,6 +415,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 cseExpr
 noCSE :: InId -> Bool
 noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&
             not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))