[commit: ghc] wip/T14152: Create isExitJoinId :: Var -> Bool (fa21c52)

[git at git.haskell.org]

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

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

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

commit fa21c524f4e068fc730b2931309fa772864f8b2a
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Aug 29 18:39:36 2017 +0100

    Create isExitJoinId :: Var -> Bool
    
    it uses the occInfo, so is only valid as long as that information is
    kept around (in the simplifier: InId, but not OutId).


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

fa21c524f4e068fc730b2931309fa772864f8b2a
 compiler/basicTypes/Id.hs        |  5 ++++-
 compiler/simplCore/SimplUtils.hs |  2 +-
 compiler/simplCore/Simplify.hs   | 11 ++++-------
 3 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index aab5569..53fcae0 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -74,7 +74,7 @@ module Id (
         DictId, isDictId, isEvVar,
 
         -- ** Join variables
-        JoinId, isJoinId, isJoinId_maybe, idJoinArity,
+        JoinId, isJoinId, isJoinId_maybe, idJoinArity, isExitJoinId,
         asJoinId, asJoinId_maybe, zapJoinId,
 
         -- ** Inline pragma stuff
@@ -495,6 +495,9 @@ isJoinId_maybe id
                 _            -> Nothing
  | otherwise = Nothing
 
+isExitJoinId :: Var -> Bool
+isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id)
+
 idDataCon :: Id -> DataCon
 -- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.
 --
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index f7be9df..bdbd6a1 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -1065,7 +1065,7 @@ preInlineUnconditionally dflags env top_lvl bndr rhs
   | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
   | not (gopt Opt_SimplPreInlining dflags)   = False
   | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
-  | isJoinId bndr, isOneOcc (idOccInfo bndr), occ_in_lam (idOccInfo bndr) = False
+  | isExitJoinId bndr                        = False
   | otherwise = case idOccInfo bndr of
                   IAmDead                    -> True -- Happens in ((\x.1) v)
                   occ at OneOcc { occ_one_br = True }
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 25244a0..edeada8 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(..), isOneOcc )
+                          RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
 import Maybes           ( isJust, fromJust, orElse, catMaybes )
 --import Unique           ( hasKey ) -- temporalily commented out. See #8326
@@ -451,8 +451,8 @@ simplJoinBind :: SimplEnv
               -> InExpr -> SimplEnv     -- The RHS and its environment
               -> SimplM SimplEnv
 simplJoinBind env is_rec cont bndr bndr1 rhs rhs_se
-  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$
-    --                           ppr rhs $$ ppr (seIdSubst rhs_se)) $
+  = -- pprTrace "simplJoinBind" ((ppr bndr <+> ppr bndr1) $$
+    --                          ppr rhs $$ ppr (seIdSubst rhs_se)) $
     do  { let rhs_env = rhs_se `setInScopeAndZapFloats` env
         ; rhs' <- simplJoinRhs rhs_env bndr rhs cont
         ; completeBind env NotTopLevel is_rec (Just cont) bndr bndr1 rhs' }
@@ -3484,10 +3484,7 @@ 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)
+  | isExitJoinId id -- Do not inline exit join points
   = return unf
   | otherwise
   = is_bottoming `seq`  -- See Note [Force bottoming field]