[commit: ghc] wip/T14152: Exitification: Do not try to abstract over join points (46c9cb7)

[git at git.haskell.org]

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

On branch  : wip/T14152
Link       : http://ghc.haskell.org/trac/ghc/changeset/46c9cb7fe25a5cf3e1e1df9299e7afe27b66c5e3/ghc

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

commit 46c9cb7fe25a5cf3e1e1df9299e7afe27b66c5e3
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Sep 4 16:48:12 2017 +0100

    Exitification: Do not try to abstract over join points


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

46c9cb7fe25a5cf3e1e1df9299e7afe27b66c5e3
 compiler/simplCore/Exitify.hs | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs
index cc4172d..6381b14 100644
--- a/compiler/simplCore/Exitify.hs
+++ b/compiler/simplCore/Exitify.hs
@@ -106,11 +106,13 @@ exitify in_scope pairs =
         -- Do not touch a boring expression
         | is_exit, not is_interesting = return e
 
+        -- Cannot float out if local join points are used
+        | is_exit, captures_join_points = return e
+
         -- We have something to float out!
         | is_exit = do
             -- Assemble the RHS of the exit join point
-            let args = filter (`elemVarSet` fvs) captured
-                rhs = mkLams args e
+            let rhs = mkLams args e
                 ty = exprType rhs
             -- Pick a suitable name
             v <- mkExitJoinId ty (length args) captured
@@ -121,10 +123,17 @@ exitify in_scope pairs =
       where
         -- An exit expression has no recursive calls
         is_exit = disjointVarSet fvs recursive_calls
+
         -- An interesting exit expression has free variables from
         -- outside the recursive group
         is_interesting = not (isEmptyVarSet (fvs `minusVarSet` mkVarSet captured))
 
+        -- The possible arguments of this exit join point
+        args = filter (`elemVarSet` fvs) captured
+
+        -- We cannot abstract over join points
+        captures_join_points = any isJoinId args
+
         e = deAnnotate ann_e
         fvs = dVarSetToVarSet (freeVarsOf ann_e)