[commit: ghc] wip/T14152: Do not assign an unfolding to exit join points (d55e22f)

[git at git.haskell.org]

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

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

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

commit d55e22f4349830c184251b5d625f447d582aef29
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Aug 29 18:01:06 2017 +0100

    Do not assign an unfolding to exit join points
    
    to prevent them from being inlied.


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

d55e22f4349830c184251b5d625f447d582aef29
 compiler/simplCore/Simplify.hs | 28 ++++++++++++++++++++--------
 1 file changed, 20 insertions(+), 8 deletions(-)

diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 7d83be6..25244a0 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -42,7 +42,7 @@ import CoreOpt          ( pushCoTyArg, pushCoValArg
 import Rules            ( mkRuleInfo, lookupRule, getRules )
 --import TysPrim          ( intPrimTy ) -- temporalily commented out. See #8326
 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
-                          RecFlag(..) )
+                          RecFlag(..), isOneOcc )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
 import Maybes           ( isJust, fromJust, orElse, catMaybes )
 --import Unique           ( hasKey ) -- temporalily commented out. See #8326
@@ -1744,14 +1744,16 @@ exitify exitUniques pairs =
         | is_exit = do
             -- create an id for the exit path
             u <- getUnique
-            let res_ty = exprType e
-                args = filter (`elemVarSet` fvs) captured
-                args_tys = map idType args
-                ty = mkFunTys args_tys res_ty
-                v = mkSysLocal (fsLit "exit") u ty `asJoinId` length args
+            let args = filter (`elemVarSet` fvs) captured
                 rhs = mkLams args e
-                e' = mkVarApps (Var v) args
-            addExit v rhs
+                ty = exprType rhs
+                join_arity = length args
+                v = mkSysLocal (fsLit "exit") u ty `asJoinId` join_arity
+                --v' = v `setIdUnfolding` mkCoreUnfolding InlineRhs False rhs UnfNever
+                v' = v `setIdOccInfo` exit_occ_info join_arity
+
+                e' = mkVarApps (Var v') args
+            addExit v' rhs
             return e'
       where
         -- An exit expression has no recursive calls
@@ -1761,6 +1763,11 @@ exitify exitUniques pairs =
         is_interesting = not (isEmptyVarSet (fvs `minusVarSet` mkVarSet captured))
         fvs = exprFreeVars e
 
+        exit_occ_info join_arity =
+            OneOcc { occ_in_lam = True
+                   , occ_one_br = True
+                   , occ_int_cxt = False
+                   , occ_tail = AlwaysTailCalled join_arity }
 
     go captured (Case scrut bndr ty alts) = do
         alts' <- mapM (goAlt (bndr:captured)) alts
@@ -3477,6 +3484,11 @@ simplLetUnfolding :: SimplEnv-> TopLevelFlag
 simplLetUnfolding env top_lvl cont_mb id new_rhs unf
   | isStableUnfolding unf
   = simplUnfolding env top_lvl cont_mb id unf
+  -- A join point that occurs under a lambda: This means that
+  -- this join point is called from a recursive group, and we do not
+  -- want to inine them!
+  | isJoinId id, isOneOcc (idOccInfo id), occ_in_lam (idOccInfo id)
+  = return unf
   | otherwise
   = is_bottoming `seq`  -- See Note [Force bottoming field]
     do { dflags <- getDynFlags