Join-point refactoring
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 27 Apr 2017 16:04:14 +0000 (17:04 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 2 May 2017 08:00:14 +0000 (09:00 +0100)
This commit has a raft of refactorings that improve the treatment
of join points.  I wasn't aiming so much as to gain performance as
to make the code simpler.

The two big things are these:

* Make mkDupableCont work for SimplBind as well.  This is simpler than
  I thought and quite neat.  (Luke had aready done StrictArg.)  That's
  a win in its own right. But also now /all/ continuations can be made
  dup-able

* Now that all continuations can be made dup-able, I could simplify
  mkDupableCont to return just one SimplCont, instead of two.
  That really is a worthwhile simlification!  Much easier to think
  about.

Plus a bunch of smaller things:

* Remove the join-arity that had been added to seIdSubst.
  It can be done more simply by putting it in DoneEx, which
  is the only constructor that actually needs it, and now we
  don't need the unsavoury isJoinIdInEnv_maybe.

* Re-order the handling of join points in Simplify, so that we don't need
  the horrible resultTypeOfDupableCont

* Add field names for StrictBind, StrictArg; and use them

* Define simplMonad.newJoinId, and use it

* Rename the seFloats field of SimplEnv to seLetFloats

Binary sizes seem to go up slightly, but allocations generally
improve, sometimes significantly.  I don't believe the runtime numbers
are reliable enough to draw any conclusions about

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
          event          +1.1%    -12.0%     -0.2%     -0.2%     -8.7%
         fulsom          +1.9%    -11.8%    -10.0%    -10.0%     +5.3%
     last-piece          +2.3%     -1.2%     -1.2%     -1.2%     +0.0%
           mate          +0.9%     -1.4%     -0.6%     -0.7%     +0.0%
     multiplier          +1.5%     -8.3%      0.17      0.17     +0.0%
         parser          +2.0%     +1.0%      0.04      0.04     +0.0%
        parstof          +1.5%     +0.7%      0.01      0.01     +0.0%
          sched          +1.3%     -6.1%      0.03      0.03     +0.0%
         simple          +1.8%     +1.0%     +9.7%     +9.6%     +0.0%
--------------------------------------------------------------------------------
            Min          +0.5%    -12.0%    -10.0%    -10.0%     -8.7%
            Max          +3.0%     +1.0%    +14.2%    +14.2%    +50.0%
 Geometric Mean          +1.4%     -0.4%     +0.3%     +0.4%     +0.5%

There's also a tests/perf/compiler improvement of 20% allocation in
T6048.  I think it's because we now generate smaller code.

compiler/simplCore/SimplEnv.hs
compiler/simplCore/SimplMonad.hs
compiler/simplCore/SimplUtils.hs
compiler/simplCore/Simplify.hs
testsuite/tests/perf/compiler/all.T
testsuite/tests/simplCore/should_compile/T12603.stdout
testsuite/tests/simplCore/should_compile/T3234.stderr

index a1a973e..9316ec0 100644 (file)
@@ -21,7 +21,6 @@ module SimplEnv (
 
         -- * Substitution results
         SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
-        isJoinIdInEnv_maybe,
 
         -- * Simplifying 'Id' binders
         simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
@@ -31,12 +30,12 @@ module SimplEnv (
 
         -- * Floats
         Floats, emptyFloats, isEmptyFloats,
-        addNonRec, addFloats, extendFloats,
+        addNonRec, addLetFloats, addFloats, extendFloats, addFlts,
         wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
         doFloatFromRhs, getFloatBinds,
 
-        JoinFloats, emptyJoinFloats, isEmptyJoinFloats,
-        wrapJoinFloats, zapJoinFloats, restoreJoinFloats, getJoinFloatBinds,
+        JoinFloat, JoinFloats, emptyJoinFloats, isEmptyJoinFloats,
+        wrapJoinFloats, wrapJoinFloatsX, zapJoinFloats, addJoinFloats
     ) where
 
 #include "HsVersions.h"
@@ -92,11 +91,19 @@ data SimplEnv
         -- The current set of in-scope variables
         -- They are all OutVars, and all bound in this module
         seInScope   :: InScopeSet,      -- OutVars only
-                -- Includes all variables bound by seFloats
-        seFloats    :: Floats,
+                -- Includes all variables bound
+                -- by seLetFloats and seJoinFloats
+
+        -- Ordinary bindings
+        seLetFloats  :: Floats,
                 -- See Note [Simplifier floats]
+
+        -- Join points
         seJoinFloats :: JoinFloats
                 -- Handled separately; they don't go very far
+                -- We consider these to be /inside/ seLetFloats
+                -- because join points can refer to ordinary bindings,
+                -- but not vice versa
     }
 
 type StaticEnv = SimplEnv       -- Just the static part is relevant
@@ -110,33 +117,45 @@ pprSimplEnv env
           text "InScope:" <+> in_scope_vars_doc
     ]
   where
-   id_subst_doc = pprUniqFM ppr_id_subst (seIdSubst env)
-   ppr_id_subst (m_ar, sr) = arity_part <+> ppr sr
-     where arity_part = case m_ar of Just ar -> brackets $
-                                                  text "join" <+> int ar
-                                     Nothing -> empty
-
+   id_subst_doc = pprUniqFM ppr (seIdSubst env)
    in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))
                                  (vcat . map ppr_one)
    ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
              | otherwise = ppr v
 
-type SimplIdSubst = IdEnv (Maybe JoinArity, SimplSR) -- IdId |--> OutExpr
+type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
         -- See Note [Extending the Subst] in CoreSubst
-        -- See Note [Join arity in SimplIdSubst]
 
 -- | A substitution result.
 data SimplSR
-  = DoneEx OutExpr              -- Completed term
-  | DoneId OutId                -- Completed term variable
-  | ContEx TvSubstEnv           -- A suspended substitution
+  = DoneEx OutExpr (Maybe JoinArity)
+       -- If  x :-> DoneEx e ja   is in the SimplIdSubst
+       -- then replace occurrences of x by e
+       -- and  ja = Just a <=> x is a join-point of arity a
+       -- See Note [Join arity in SimplIdSubst]
+
+
+  | DoneId OutId
+       -- If  x :-> DoneId v   is in the SimplIdSubst
+       -- then replace occurrences of x by v
+       -- and  v is a join-point of arity a
+       --      <=> x is a join-point of arity a
+
+  | ContEx TvSubstEnv                 -- A suspended substitution
            CvSubstEnv
            SimplIdSubst
            InExpr
+      -- If   x :-> ContEx tv cv id e   is in the SimplISubst
+      -- then replace occurrences of x by (subst (tv,cv,id) e)
 
 instance Outputable SimplSR where
-  ppr (DoneEx e) = text "DoneEx" <+> ppr e
-  ppr (DoneId v) = text "DoneId" <+> ppr v
+  ppr (DoneId v)    = text "DoneId" <+> ppr v
+  ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
+    where
+      pp_mj = case mj of
+                Nothing -> empty
+                Just n  -> parens (int n)
+
   ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
                                 ppr (filter_env tv), ppr (filter_env id) -}]
         -- where
@@ -211,24 +230,22 @@ seIdSubst:
 
 Note [Join arity in SimplIdSubst]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have to remember which incoming variables are join points: the occurrences
+may not be marked correctly yet, and we're in change of propagating the change if
+OccurAnal makes something a join point).
 
-We have to remember which incoming variables are join points (the occurrences
-may not be marked correctly yet; we're in change of propagating the change if
-OccurAnal makes something a join point). Normally the in-scope set is where we
-keep the latest information, but the in-scope set tracks only OutVars; if a
-binding is unconditionally inlined, it never makes it into the in-scope set,
-and we need to know at the occurrence site that the variable is a join point so
-that we know to drop the context. Thus we remember which join points we're
-substituting. Clumsily, finding whether an InVar is a join variable may require
-looking in both the substitution *and* the in-scope set (see
-'isJoinIdInEnv_maybe').
--}
+Normally the in-scope set is where we keep the latest information, but
+the in-scope set tracks only OutVars; if a binding is unconditionally
+inlined (via DoneEx), it never makes it into the in-scope set, and we
+need to know at the occurrence site that the variable is a join point
+so that we know to drop the context. Thus we remember which join
+points we're substituting. -}
 
 mkSimplEnv :: SimplifierMode -> SimplEnv
 mkSimplEnv mode
   = SimplEnv { seMode = mode
              , seInScope = init_in_scope
-             , seFloats = emptyFloats
+             , seLetFloats = emptyFloats
              , seJoinFloats = emptyJoinFloats
              , seTvSubst = emptyVarEnv
              , seCvSubst = emptyVarEnv
@@ -272,7 +289,7 @@ updMode upd env = env { seMode = upd (seMode env) }
 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
   = ASSERT2( isId var && not (isCoVar var), ppr var )
-    env { seIdSubst = extendVarEnv subst var (isJoinId_maybe var, res) }
+    env { seIdSubst = extendVarEnv subst var res }
 
 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res
@@ -295,23 +312,16 @@ setInScopeAndZapFloats :: SimplEnv -> SimplEnv -> SimplEnv
 -- Set the in-scope set, and *zap* the floats
 setInScopeAndZapFloats env env_with_scope
   = env { seInScope    = seInScope env_with_scope,
-          seFloats     = emptyFloats,
+          seLetFloats  = emptyFloats,
           seJoinFloats = emptyJoinFloats }
 
 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
 -- Set the in-scope set *and* the floats
 setFloats env env_with_floats
   = env { seInScope    = seInScope env_with_floats,
-          seFloats     = seFloats  env_with_floats,
+          seLetFloats  = seLetFloats  env_with_floats,
           seJoinFloats = seJoinFloats env_with_floats }
 
-restoreJoinFloats :: SimplEnv -> SimplEnv -> SimplEnv
--- Put back floats previously zapped
--- Unlike 'setFloats', does *not* update the in-scope set, since the right-hand
--- env is assumed to be *older*
-restoreJoinFloats env old_env
-  = env { seJoinFloats = seJoinFloats old_env }
-
 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
         -- The new Ids are guaranteed to be freshly allocated
 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
@@ -371,7 +381,8 @@ Can't happen:
 data Floats = Floats (OrdList OutBind) FloatFlag
         -- See Note [Simplifier floats]
 
-type JoinFloats = OrdList OutBind
+type JoinFloat  = OutBind
+type JoinFloats = OrdList JoinFloat
 
 data FloatFlag
   = FltLifted   -- All bindings are lifted and lazy *or*
@@ -406,7 +417,7 @@ andFF FltLifted  flt        = flt
 
 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 -- If you change this function look also at FloatIn.noFloatFromRhs
-doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
+doFloatFromRhs lvl rec str rhs (SimplEnv {seLetFloats = Floats fs ff})
   =  not (isNilOL fs) && want_to_float && can_float
   where
      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
@@ -459,44 +470,62 @@ addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 -- The latter is important; the binder may already be in the
 -- in-scope set (although it might also have been created with newId)
 -- but it may now have more IdInfo
-addNonRec env id rhs
-  = id `seq`   -- This seq forces the Id, and hence its IdInfo,
-               -- and hence any inner substitutions
-    env { seFloats = floats',
-          seJoinFloats = jfloats',
-          seInScope = extendInScopeSet (seInScope env) id }
+addNonRec env@(SimplEnv { seLetFloats  = floats
+                        , seJoinFloats = jfloats
+                        , seInScope = in_scope })
+          id rhs
+  | isJoinId id  -- This test incidentally forces the Id, and hence
+                 -- its IdInfo, and hence any inner substitutions
+  = env { seInScope    = in_scope'
+        , seLetFloats  = floats
+        , seJoinFloats = jfloats' }
+  | otherwise
+  = env { seInScope    = in_scope'
+        , seLetFloats  = floats'
+        , seJoinFloats = jfloats }
   where
-    bind = NonRec id rhs
-
-    floats'  | isJoinId id = seFloats env
-             | otherwise   = seFloats env `addFlts` unitFloat bind
-    jfloats' | isJoinId id = seJoinFloats env `addJoinFlts` unitJoinFloat bind
-             | otherwise   = seJoinFloats env
+    bind      = NonRec id rhs
+    in_scope' = extendInScopeSet in_scope id
+    floats'   = floats  `addFlts`     unitFloat     bind
+    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind
 
 extendFloats :: SimplEnv -> OutBind -> SimplEnv
--- Add these bindings to the floats, and extend the in-scope env too
-extendFloats env bind
-  = ASSERT(all (not . isJoinId) (bindersOf bind))
-    env { seFloats  = floats',
-          seJoinFloats = jfloats',
-          seInScope = extendInScopeSetList (seInScope env) bndrs }
+-- Add this binding to the floats, and extend the in-scope env too
+extendFloats env@(SimplEnv { seLetFloats  = floats
+                           , seJoinFloats = jfloats
+                           , seInScope = in_scope })
+             bind
+  | isJoinBind bind
+  = env { seInScope    = in_scope'
+        , seLetFloats  = floats
+        , seJoinFloats = jfloats' }
+  | otherwise
+  = env { seInScope    = in_scope'
+        , seLetFloats  = floats'
+        , seJoinFloats = jfloats }
   where
     bndrs = bindersOf bind
 
-    floats'  | isJoinBind bind = seFloats env
-             | otherwise       = seFloats env `addFlts` unitFloat bind
-    jfloats' | isJoinBind bind = seJoinFloats env `addJoinFlts`
-                                   unitJoinFloat bind
-             | otherwise       = seJoinFloats env
+    in_scope' = extendInScopeSetList in_scope bndrs
+    floats'   = floats  `addFlts`     unitFloat bind
+    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind
+
+addLetFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Add the let-floats for env2 to env1;
+-- *plus* the in-scope set for env2, which is bigger
+-- than that for env1
+addLetFloats env1 env2
+  = env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2
+         , seInScope   = seInScope env2 }
 
 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
--- Add the floats for env2 to env1;
+-- Add both let-floats and join-floats for env2 to env1;
 -- *plus* the in-scope set for env2, which is bigger
 -- than that for env1
 addFloats env1 env2
-  = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
-          seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2,
-          seInScope = seInScope env2 }
+  = env1 { seLetFloats  = seLetFloats env1 `addFlts` seLetFloats env2
+         , seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2
+         , seInScope    = seInScope env2 }
 
 addFlts :: Floats -> Floats -> Floats
 addFlts (Floats bs1 l1) (Floats bs2 l2)
@@ -506,21 +535,25 @@ addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
 addJoinFlts = appOL
 
 zapFloats :: SimplEnv -> SimplEnv
-zapFloats env = env { seFloats = emptyFloats
+zapFloats env = env { seLetFloats  = emptyFloats
                     , seJoinFloats = emptyJoinFloats }
 
 zapJoinFloats :: SimplEnv -> SimplEnv
 zapJoinFloats env = env { seJoinFloats = emptyJoinFloats }
 
+addJoinFloats :: SimplEnv -> JoinFloats -> SimplEnv
+addJoinFloats env@(SimplEnv { seJoinFloats = fb1 }) fb2
+  = env { seJoinFloats = fb1 `addJoinFlts` fb2 }
+
 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
 -- Flattens the floats from env2 into a single Rec group,
 -- prepends the floats from env1, and puts the result back in env2
 -- This is all very specific to the way recursive bindings are
 -- handled; see Simplify.simplRecBind
-addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff
+addRecFloats env1 env2@(SimplEnv {seLetFloats  = Floats bs ff
                                  ,seJoinFloats = jbs })
   = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
-    env2 {seFloats = seFloats env1 `addFlts` floats'
+    env2 {seLetFloats = seLetFloats env1 `addFlts` floats'
          ,seJoinFloats = seJoinFloats env1 `addJoinFlts` jfloats'}
   where
     floats'  | isNilOL bs  = emptyFloats
@@ -531,35 +564,39 @@ addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff
 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
 -- Wrap the floats around the expression; they should all
 -- satisfy the let/app invariant, so mkLets should do the job just fine
-wrapFloats env@(SimplEnv {seFloats = Floats bs _}) body
-  = foldrOL Let (wrapJoinFloats env body) bs
-      -- Note: Always safe to put the joins on the inside since the values
-      -- can't refer to them
-
-wrapJoinFloats :: SimplEnv -> OutExpr -> OutExpr
-wrapJoinFloats (SimplEnv {seJoinFloats = jbs}) body
-  = foldrOL Let body jbs
+wrapFloats (SimplEnv { seLetFloats  = Floats bs _
+                     , seJoinFloats = jbs }) body
+  = foldrOL Let (wrapJoinFloats jbs body) bs
+     -- Note: Always safe to put the joins on the inside
+     -- since the values can't refer to them
+
+wrapJoinFloatsX :: SimplEnv -> OutExpr -> (SimplEnv, OutExpr)
+-- Wrap the seJoinFloats of the env around the expression,
+-- and take them out of the SimplEnv
+wrapJoinFloatsX env@(SimplEnv { seJoinFloats = jbs }) body
+  = (zapJoinFloats env, wrapJoinFloats jbs body)
+
+wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
+-- Wrap the seJoinFloats of the env around the expression,
+-- and take them out of the SimplEnv
+wrapJoinFloats join_floats body
+  = foldrOL Let body join_floats
 
 getFloatBinds :: SimplEnv -> [CoreBind]
-getFloatBinds env@(SimplEnv {seFloats = Floats bs _})
-  = fromOL bs ++ getJoinFloatBinds env
-
-getJoinFloatBinds :: SimplEnv -> [CoreBind]
-getJoinFloatBinds (SimplEnv {seJoinFloats = jbs})
-  = fromOL jbs
+getFloatBinds (SimplEnv {seLetFloats = Floats bs _, seJoinFloats = jbs})
+  = fromOL bs ++ fromOL jbs
 
 isEmptyFloats :: SimplEnv -> Bool
-isEmptyFloats env@(SimplEnv {seFloats = Floats bs _})
+isEmptyFloats env@(SimplEnv {seLetFloats = Floats bs _})
   = isNilOL bs && isEmptyJoinFloats env
 
 isEmptyJoinFloats :: SimplEnv -> Bool
 isEmptyJoinFloats (SimplEnv {seJoinFloats = jbs})
   = isNilOL jbs
 
-mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
-mapFloats env@SimplEnv { seFloats = Floats fs ff, seJoinFloats = jfs } fun
-   = env { seFloats = Floats (mapOL app fs) ff
-         , seJoinFloats = mapOL app jfs }
+mapFloats :: Floats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> Floats
+mapFloats (Floats fs ff) fun
+   = Floats (mapOL app fs) ff
    where
     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
     app (Rec bs)     = Rec (map fun bs)
@@ -586,24 +623,15 @@ find that it has been substituted by b.  (Or conceivably cloned.)
 substId :: SimplEnv -> InId -> SimplSR
 -- Returns DoneEx only on a non-Var expression
 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
-  = case snd <$> lookupVarEnv ids v of  -- Note [Global Ids in the substitution]
+  = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]
         Nothing               -> DoneId (refineFromInScope in_scope v)
         Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)
-        Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v)
         Just res              -> res    -- DoneEx non-var, or ContEx
 
         -- Get the most up-to-date thing from the in-scope set
         -- Even though it isn't in the substitution, it may be in
         -- the in-scope set with better IdInfo
 
-isJoinIdInEnv_maybe :: SimplEnv -> InId -> Maybe JoinArity
-isJoinIdInEnv_maybe (SimplEnv { seInScope = inScope, seIdSubst = ids }) v
-  | not (isLocalId v)                         = Nothing
-  | Just (m_ar, _) <- lookupVarEnv ids v      = m_ar
-  | Just v'        <- lookupInScope inScope v = isJoinId_maybe v'
-  | otherwise                                 = WARN( True , ppr v )
-                                                isJoinId_maybe v
-
 refineFromInScope :: InScopeSet -> Var -> Var
 refineFromInScope in_scope v
   | isLocalId v = case lookupInScope in_scope v of
@@ -616,7 +644,7 @@ lookupRecBndr :: SimplEnv -> InId -> OutId
 -- but where we have not yet done its RHS
 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
   = case lookupVarEnv ids v of
-        Just (_, DoneId v) -> v
+        Just (DoneId v) -> v
         Just _ -> pprPanic "lookupRecBndr" (ppr v)
         Nothing -> refineFromInScope in_scope v
 
@@ -731,8 +759,7 @@ substNonCoVarIdBndr new_res_ty
         -- or there's some useful occurrence information
         -- See the notes with substTyVarBndr for the delSubstEnv
     new_subst | new_id /= old_id
-              = extendVarEnv id_subst old_id
-                             (isJoinId_maybe new_id, DoneId new_id)
+              = extendVarEnv id_subst old_id (DoneId new_id)
               | otherwise
               = delVarEnv id_subst old_id
 
index 074d13b..8f20637 100644 (file)
@@ -11,7 +11,7 @@ module SimplMonad (
         getSimplRules, getFamEnvs,
 
         -- Unique supply
-        MonadUnique(..), newId,
+        MonadUnique(..), newId, newJoinId,
 
         -- Counting
         SimplCount, tick, freeTick, checkedTick,
@@ -19,8 +19,11 @@ module SimplMonad (
         plusSimplCount, isZeroSimplCount
     ) where
 
+import Var              ( Var, isTyVar, mkLocalVar )
+import Name             ( mkSystemVarName )
 import Id               ( Id, mkSysLocalOrCoVar )
-import Type             ( Type )
+import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo )
+import Type             ( Type, mkLamTypes )
 import FamInstEnv       ( FamInstEnv )
 import CoreSyn          ( RuleEnv(..) )
 import UniqSupply
@@ -177,6 +180,19 @@ newId :: FastString -> Type -> SimplM Id
 newId fs ty = do uniq <- getUniqueM
                  return (mkSysLocalOrCoVar fs uniq ty)
 
+newJoinId :: [Var] -> Type -> SimplM Id
+newJoinId bndrs body_ty
+  = do { uniq <- getUniqueM
+       ; let name       = mkSystemVarName uniq (fsLit "$j")
+             join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]
+             arity      = length (filter (not . isTyVar) bndrs)
+             join_arity = length bndrs
+             details    = JoinId join_arity
+             id_info    = vanillaIdInfo `setArityInfo` arity
+--                                        `setOccInfo` strongLoopBreaker
+
+       ; return (mkLocalVar details name join_id_ty id_info) }
+
 {-
 ************************************************************************
 *                                                                      *
index db75428..e6e660b 100644 (file)
@@ -54,7 +54,6 @@ import SimplMonad
 import Type     hiding( substTy )
 import Coercion hiding( substCo )
 import DataCon          ( dataConWorkId, isNullaryRepDataCon )
-import VarEnv
 import VarSet
 import BasicTypes
 import Util
@@ -96,7 +95,7 @@ Key points:
 -}
 
 data SimplCont
-  = Stop                -- An empty context, or <hole>
+  = Stop                -- Stop[e] = e
         OutType         -- Type of the <hole>
         CallCtxt        -- Tells if there is something interesting about
                         --          the context, and hence the inliner
@@ -107,43 +106,48 @@ data SimplCont
                         -- Never ValAppCxt (use ApplyToVal instead)
                         -- or CaseCtxt (use Select instead)
 
-  | CastIt            -- <hole> `cast` co
+  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]
         OutCoercion             -- The coercion simplified
                                 -- Invariant: never an identity coercion
         SimplCont
 
-  | ApplyToVal {        -- <hole> arg
-        sc_dup  :: DupFlag,          -- See Note [DupFlag invariants]
-        sc_arg  :: InExpr,           -- The argument,
-        sc_env  :: StaticEnv,        --     and its static env
-        sc_cont :: SimplCont }
-
-  | ApplyToTy {         -- <hole> ty
-        sc_arg_ty  :: OutType,     -- Argument type
-        sc_hole_ty :: OutType,     -- Type of the function, presumably (forall a. blah)
-                                   -- See Note [The hole type in ApplyToTy]
-        sc_cont    :: SimplCont }
-
-  | Select {           -- case <hole> of alts
-        sc_dup  :: DupFlag,                 -- See Note [DupFlag invariants]
-        sc_bndr :: InId,                    -- case binder
-        sc_alts :: [InAlt],                 -- Alternatives
-        sc_env  ::  StaticEnv,              --   and their static environment
-        sc_cont :: SimplCont }
+  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]
+      { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]
+      , sc_arg  :: InExpr       -- The argument,
+      , sc_env  :: StaticEnv    --     and its static env
+      , sc_cont :: SimplCont }
+
+  | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]
+      { sc_arg_ty  :: OutType     -- Argument type
+      , sc_hole_ty :: OutType     -- Type of the function, presumably (forall a. blah)
+                                  -- See Note [The hole type in ApplyToTy]
+      , sc_cont    :: SimplCont }
+
+  | Select             -- (Select alts K)[e] = K[ case e of alts ]
+      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]
+      , sc_bndr :: InId           -- case binder
+      , sc_alts :: [InAlt]        -- Alternatives
+      , sc_env  :: StaticEnv      --   and their static environment
+      , sc_cont :: SimplCont }
 
   -- The two strict forms have no DupFlag, because we never duplicate them
-  | StrictBind                  -- (\x* \xs. e) <hole>
-        InId [InBndr]           -- let x* = <hole> in e
-        InExpr StaticEnv        --      is a special case
-        SimplCont
-
-  | StrictArg           -- f e1 ..en <hole>
-        ArgInfo         -- Specifies f, e1..en, Whether f has rules, etc
-                        --     plus strictness flags for *further* args
-        CallCtxt        -- Whether *this* argument position is interesting
-        SimplCont
-
-  | TickIt
+  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]
+                        --       or, equivalently,  = K[ (\x xs.b) e ]
+      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]
+      , sc_bndr  :: InId
+      , sc_bndrs :: [InBndr]
+      , sc_body  :: InExpr
+      , sc_env   :: StaticEnv
+      , sc_cont  :: SimplCont }
+
+  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]
+      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup
+      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc
+                               --     plus strictness flags for *further* args
+      , sc_cci  :: CallCtxt    -- Whether *this* argument position is interesting
+      , sc_cont :: SimplCont }
+
+  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]
         (Tickish Id)    -- Tick tickish <hole>
         SimplCont
 
@@ -186,8 +190,10 @@ instance Outputable SimplCont where
   ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
     = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)
                                         $$ ppr cont
-  ppr (StrictBind b _ _ _ cont)       = (text "StrictBind" <+> ppr b) $$ ppr cont
-  ppr (StrictArg ai _ cont)           = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont
+  ppr (StrictBind { sc_bndr = b, sc_cont = cont })
+    = (text "StrictBind" <+> ppr b) $$ ppr cont
+  ppr (StrictArg { sc_fun = ai, sc_cont = cont })
+    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont
   ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
     = (text "Select" <+> ppr dup <+> ppr bndr) $$
        ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
@@ -344,6 +350,7 @@ contIsDupable (Stop {})                         = True
 contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k
 contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]
 contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...
+contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...
 contIsDupable (CastIt _ k)                      = contIsDupable k
 contIsDupable _                                 = False
 
@@ -359,8 +366,8 @@ contIsTrivial _                                                 = False
 contResultType :: SimplCont -> OutType
 contResultType (Stop ty _)                  = ty
 contResultType (CastIt _ k)                 = contResultType k
-contResultType (StrictBind _ _ _ _ k)       = contResultType k
-contResultType (StrictArg _ _ k)            = contResultType k
+contResultType (StrictBind { sc_cont = k }) = contResultType k
+contResultType (StrictArg { sc_cont = k })  = contResultType k
 contResultType (Select { sc_cont = k })     = contResultType k
 contResultType (ApplyToTy  { sc_cont = k }) = contResultType k
 contResultType (ApplyToVal { sc_cont = k }) = contResultType k
@@ -370,8 +377,9 @@ contHoleType :: SimplCont -> OutType
 contHoleType (Stop ty _)                      = ty
 contHoleType (TickIt _ k)                     = contHoleType k
 contHoleType (CastIt co _)                    = pFst (coercionKind co)
-contHoleType (StrictBind b _ _ se _)          = substTy se (idType b)
-contHoleType (StrictArg ai _ _)               = funArgTy (ai_type ai)
+contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
+  = perhapsSubstTy dup se (idType b)
+contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)
 contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]
 contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })
   = mkFunTy (perhapsSubstTy dup se (exprType e))
@@ -552,13 +560,12 @@ interestingCallContext cont
         -- motivation to inline. See Note [Cast then apply]
         -- in CoreUnfold
 
-    interesting (StrictArg _ BoringCtxt _)  = RhsCtxt
-    interesting (StrictArg _ cci _)         = cci
-    interesting (StrictBind {})             = BoringCtxt
-    interesting (Stop _ cci)                = cci
-    interesting (TickIt _ k)                = interesting k
-    interesting (ApplyToTy { sc_cont = k }) = interesting k
-    interesting (CastIt _ k)                = interesting k
+    interesting (StrictArg { sc_cci = cci }) = cci
+    interesting (StrictBind {})              = BoringCtxt
+    interesting (Stop _ cci)                 = cci
+    interesting (TickIt _ k)                 = interesting k
+    interesting (ApplyToTy { sc_cont = k })  = interesting k
+    interesting (CastIt _ k)                 = interesting k
         -- If this call is the arg of a strict function, the context
         -- is a bit interesting.  If we inline here, we may get useful
         -- evaluation information to avoid repeated evals: e.g.
@@ -600,14 +607,14 @@ interestingArgContext rules call_cont
   where
     enclosing_fn_has_rules = go call_cont
 
-    go (Select {})         = False
-    go (ApplyToVal {})     = False  -- Shouldn't really happen
-    go (ApplyToTy  {})     = False  -- Ditto
-    go (StrictArg _ cci _) = interesting cci
-    go (StrictBind {})     = False      -- ??
-    go (CastIt _ c)        = go c
-    go (Stop _ cci)        = interesting cci
-    go (TickIt _ c)        = go c
+    go (Select {})                  = False
+    go (ApplyToVal {})              = False  -- Shouldn't really happen
+    go (ApplyToTy  {})              = False  -- Ditto
+    go (StrictArg { sc_cci = cci }) = interesting cci
+    go (StrictBind {})              = False      -- ??
+    go (CastIt _ c)                 = go c
+    go (Stop _ cci)                 = interesting cci
+    go (TickIt _ c)                 = go c
 
     interesting RuleArgCtxt = True
     interesting _           = False
@@ -650,12 +657,10 @@ interestingArg env e = go env 0 e
   where
     -- n is # value args to which the expression is applied
     go env n (Var v)
-       | SimplEnv { seIdSubst = ids, seInScope = in_scope } <- env
-       = case snd <$> lookupVarEnv ids v of
-           Nothing                     -> go_var n (refineFromInScope in_scope v)
-           Just (DoneId v')            -> go_var n (refineFromInScope in_scope v')
-           Just (DoneEx e)             -> go (zapSubstEnv env)             n e
-           Just (ContEx tvs cvs ids e) -> go (setSubstEnv env tvs cvs ids) n e
+       = case substId env v of
+           DoneId v'            -> go_var n v'
+           DoneEx e _           -> go (zapSubstEnv env)             n e
+           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e
 
     go _   _ (Lit {})          = ValueArg
     go _   _ (Type _)          = TrivArg
index 9bfdd1e..1c5534f 100644 (file)
@@ -43,7 +43,7 @@ import Rules            ( mkRuleInfo, lookupRule, getRules )
 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
                           RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
-import Maybes           ( isJust, fromJust, orElse )
+import Maybes           ( isJust, fromJust, orElse, catMaybes )
 --import Unique           ( hasKey ) -- temporalily commented out. See #8326
 import Control.Monad
 import Outputable
@@ -289,7 +289,7 @@ simplRecBind env0 top_lvl mb_cont pairs0
   = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
         ; env1 <- go (zapFloats env_with_info) triples
         ; return (env0 `addRecFloats` env1) }
-        -- addFloats adds the floats from env1,
+        -- addRecFloats adds the floats from env1,
         -- _and_ updates env0 with the in-scope set from env1
   where
     add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
@@ -354,6 +354,7 @@ Nota bene:
 simplBind :: SimplEnv
           -> TopLevelFlag -> RecFlag -> Maybe SimplCont
           -> InId -> OutId      -- Binder, both pre-and post simpl
+                                -- Can be a JoinId
                                 -- The OutId has IdInfo, except arity, unfolding
                                 -- Ids only, no TyVars
           -> InExpr -> SimplEnv -- The RHS and its environment
@@ -369,10 +370,12 @@ simplBind env top_lvl is_rec mb_cont bndr bndr1 rhs rhs_se
 simplLazyBind :: SimplEnv
               -> TopLevelFlag -> RecFlag
               -> InId -> OutId          -- Binder, both pre-and post simpl
+                                        -- Not a JoinId
                                         -- The OutId has IdInfo, except arity, unfolding
                                         -- Ids only, no TyVars
               -> InExpr -> SimplEnv     -- The RHS and its environment
               -> SimplM SimplEnv
+-- Precondition: not a JoinId
 -- Precondition: rhs obeys the let/app invariant
 -- NOT used for JoinIds
 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
@@ -400,14 +403,15 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                 -- See Note [Floating and type abstraction] in SimplUtils
 
         -- Simplify the RHS
-        ; let   rhs_cont = mkRhsStop (substTy body_env (exprType body))
+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
         ; (body_env0, body0) <- simplExprF body_env body rhs_cont
-        ; let body1     = wrapJoinFloats body_env0 body0
-              body_env1 = body_env0 `restoreJoinFloats` body_env
+        ; let (body_env1, body1) = wrapJoinFloatsX body_env0 body0
 
         -- ANF-ise a constructor or PAP rhs
         ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
 
+        -- We need body_env2 for its let-floats (only);
+        -- we've dealt with its join-floats, which are now empty
         ; (env', rhs')
             <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
                 then                            -- No floating, revert to body1
@@ -416,7 +420,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
 
                 else if null tvs then           -- Simple floating
                      do { tick LetFloatFromLet
-                        ; return (addFloats env body_env2, body2) }
+                        ; return (addLetFloats env body_env2, body2) }
 
                 else                            -- Do type-abstraction first
                      do { tick LetFloatFromLet
@@ -439,8 +443,6 @@ simplJoinBind env is_rec cont bndr bndr1 rhs rhs_se
   = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$
     --                           ppr rhs $$ ppr (seIdSubst rhs_se)) $
     do  { let rhs_env = rhs_se `setInScopeAndZapFloats` env
-
-        -- Simplify the RHS
         ; rhs' <- simplJoinRhs rhs_env bndr rhs cont
         ; completeBind env NotTopLevel is_rec (Just cont) bndr bndr1 rhs' }
 
@@ -450,12 +452,13 @@ notably in knownCon.  It uses case-binding where necessary.
 -}
 
 simplNonRecX :: SimplEnv
-             -> InId            -- Old binder
+             -> InId            -- Old binder; not a JoinId
              -> OutExpr         -- Simplified RHS
              -> SimplM SimplEnv
 -- Precondition: rhs satisfies the let/app invariant
 simplNonRecX env bndr new_rhs
-  | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+  | ASSERT2( not (isJoinId bndr), ppr bndr )
+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
   = return env    --  Here c is dead, and we avoid creating
                   --   the binding c = (a,b)
 
@@ -469,20 +472,21 @@ simplNonRecX env bndr new_rhs
 
 completeNonRecX :: TopLevelFlag -> SimplEnv
                 -> Bool
-                -> InId                 -- Old binder
+                -> InId                 -- Old binder; not a JoinId
                 -> OutId                -- New binder
                 -> OutExpr              -- Simplified RHS
-                -> SimplM SimplEnv
+                -> SimplM SimplEnv      -- The new binding extends the seLetFloats
+                                        -- of the resulting SimpleEnv
 -- Precondition: rhs satisfies the let/app invariant
 --               See Note [CoreSyn let/app invariant] in CoreSyn
 
 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
-  = ASSERT(not (isJoinId new_bndr))
+  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )
     do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
         ; (env2, rhs2) <-
                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
                 then do { tick LetFloatFromLet
-                        ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
+                        ; return (addLetFloats env env1, rhs1) }   -- Add the floats to the main env
                 else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
         ; completeBind env2 NotTopLevel NonRecursive Nothing
                        old_bndr new_bndr rhs2 }
@@ -542,7 +546,7 @@ simplify BIG True; maybe good things happen.  That is why
       (see Note [Trying rewrite rules])
 
 Note [prepareRhs]
-~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~
 prepareRhs takes a putative RHS, checks whether it's a PAP or
 constructor application and, if so, converts it to ANF, so that the
 resulting thing can be inlined more easily.  Thus
@@ -560,6 +564,7 @@ That's what the 'go' loop in prepareRhs does
 -}
 
 prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
+-- See Note [prepareRhs]
 -- Adds new floats to the env iff that allows us to return a good RHS
 -- See Note [prepareRhs]
 prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
@@ -602,11 +607,14 @@ prepareRhs top_lvl env0 id rhs0
         | tickishScoped t == NoScope
         = do { (is_exp, env', rhs') <- go n_val_args env rhs
              ; return (is_exp, env', Tick t rhs') }
+
         -- On the other hand, for scoping ticks we need to be able to
         -- copy them on the floats, which in turn is only allowed if
         -- we can obtain non-counting ticks.
         | (not (tickishCounts t) || tickishCanSplit t)
         = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs
+                    -- env' has the extra let-bindings from
+                    -- the makeTrivial calls in 'go'; no join floats
              ; let tickIt (id, expr)
                        -- we have to take care not to tick top-level literal
                        -- strings. See Note [CoreSyn top-level string literals].
@@ -614,8 +622,9 @@ prepareRhs top_lvl env0 id rhs0
                      = (id, expr)
                      | otherwise
                      = (id, mkTick (mkNoCount t) expr)
-                   floats' = seFloats $ env `addFloats` mapFloats env' tickIt
-             ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') }
+                   floats' = seLetFloats env `addFlts`
+                             mapFloats (seLetFloats env') tickIt
+             ; return (is_exp, env' { seLetFloats = floats' }, Tick t rhs') }
 
     go _ env other
         = return (False, env, other)
@@ -696,6 +705,7 @@ makeTrivialWithInfo top_lvl env context info expr
   || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
                                                 --   See Note [Cannot trivialise]
   = return (env, expr)
+
   | otherwise           -- See Note [Take care] below
   = do  { uniq <- getUniqueM
         ; let name = mkSystemVarName uniq context
@@ -786,6 +796,7 @@ completeBind :: SimplEnv
 --      * by extending the substitution (e.g. let x = y in ...)
 --      * or by adding to the floats in the envt
 --
+-- Binder /can/ be a JoinId
 -- Precondition: rhs obeys the let/app invariant
 completeBind env top_lvl is_rec mb_cont old_bndr new_bndr new_rhs
  | isCoVar old_bndr
@@ -817,7 +828,8 @@ completeBind env top_lvl is_rec mb_cont old_bndr new_bndr new_rhs
 
                         -- Inline and discard the binding
         then do  { tick (PostInlineUnconditionally old_bndr)
-                 ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
+                 ; return (extendIdSubst env old_bndr
+                              (DoneEx final_rhs (isJoinId_maybe new_bndr))) }
                 -- Use the substitution to make quite, quite sure that the
                 -- substitution will happen, since we are going to discard the binding
         else
@@ -1021,11 +1033,11 @@ simplExprC :: SimplEnv
            -> SimplM OutExpr
         -- Simplify an expression, given a continuation
 simplExprC env expr cont
-  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $
     do  { (env', expr') <- simplExprF (zapFloats env) expr cont
         ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
           -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
-          -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $
           return (wrapFloats env' expr') }
 
 --------------------------------------------------
@@ -1035,15 +1047,15 @@ simplExprF :: SimplEnv
            -> SimplM (SimplEnv, OutExpr)
 
 simplExprF env e cont
-  = -- pprTrace "simplExprF" (vcat
---      [ ppr e
---      , text "cont =" <+> ppr cont
---      , text "inscope =" <+> ppr (seInScope env)
---      , text "tvsubst =" <+> ppr (seTvSubst env)
---      , text "idsubst =" <+> ppr (seIdSubst env)
---      , text "cvsubst =" <+> ppr (seCvSubst env)
---      {- , ppr (seFloats env) -}
---      ]) $
+  = {- pprTrace "simplExprF" (vcat
+      [ ppr e
+      , text "cont =" <+> ppr cont
+      , text "inscope =" <+> ppr (seInScope env)
+      , text "tvsubst =" <+> ppr (seTvSubst env)
+      , text "idsubst =" <+> ppr (seIdSubst env)
+      , text "cvsubst =" <+> ppr (seCvSubst env)
+      {- , ppr (seLetFloats env) -}
+      ]) $ -}
     simplExprF1 env e cont
 
 simplExprF1 :: SimplEnv -> InExpr -> SimplCont
@@ -1104,9 +1116,16 @@ simplExprF1 env expr@(Lam {}) cont
           | otherwise = zapLamIdInfo b
 
 simplExprF1 env (Case scrut bndr _ alts) cont
+  | sm_case_case (getMode env)
   = simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr
                                  , sc_alts = alts
                                  , sc_env = env, sc_cont = cont })
+  | otherwise
+  = do { (env', scrut') <- simplExprF (zapFloats env) scrut $
+                           mkBoringStop (substTy env (idType bndr))
+       ; let scrut'' = wrapJoinFloats (seJoinFloats env') scrut'
+             env''   = env `addLetFloats` env'
+       ; rebuildCase env'' scrut'' bndr alts cont }
 
 simplExprF1 env (Let (Rec pairs) body) cont
   = simplRecE env pairs body cont
@@ -1276,12 +1295,10 @@ simplTick env tickish expr cont
 
   no_floating_past_tick =
     do { let (inc,outc) = splitCont cont
-       ; (env', expr') <- simplExprF (zapFloats env) expr inc
-       ; let tickish' = simplTickish env tickish
-       ; (env'', expr'') <- rebuild (zapFloats env')
-                                    (wrapFloats env' expr')
-                                    (TickIt tickish' outc)
-       ; return (addFloats env env'', expr'')
+       ; (env1, expr1) <- simplExprF (zapFloats env) expr inc
+       ; let expr2    = wrapFloats env1 expr1
+             tickish' = simplTickish env tickish
+       ; rebuild env (mkTick tickish' expr2) outc
        }
 
 -- Alternative version that wraps outgoing floats with the tick.  This
@@ -1317,8 +1334,8 @@ simplTick env tickish expr cont
     where (inc,outc) = splitCont c
   splitCont other = (mkBoringStop (contHoleType other), other)
 
-  getDoneId (DoneId id) = id
-  getDoneId (DoneEx e = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
+  getDoneId (DoneId id)  = id
+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
   getDoneId other = pprPanic "getDoneId" (ppr other)
 
 -- Note [case-of-scc-of-case]
@@ -1374,25 +1391,23 @@ rebuild env expr cont
       Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
         -> rebuildCase (se `setFloats` env) expr bndr alts cont
 
-      StrictArg info _ cont         -> rebuildCall env (info `addValArgTo` expr) cont
-      StrictBind b bs body se cont  -> do { env' <- simplNonRecX (se `setFloats` env) b expr
-                                               -- expr satisfies let/app since it started life
-                                               -- in a call to simplNonRecE
-                                          ; simplLam env' bs body cont }
+      StrictArg { sc_fun = fun, sc_cont = cont }
+        -> rebuildCall env (fun `addValArgTo` expr) cont
+      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
+                 , sc_env = se, sc_cont = cont }
+        -> do { env' <- simplNonRecX (se `setFloats` env) b expr
+                             -- expr satisfies let/app since it started life
+                             -- in a call to simplNonRecE
+              ; simplLam env' bs body cont }
 
       ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}
         -> rebuild env (App expr (Type ty)) cont
 
       ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}
         -- See Note [Avoid redundant simplification]
-        | isSimplified dup_flag
-        -> rebuild env (App expr arg) cont
-
-        | otherwise
-        -> do { arg' <- simplExpr (se `setInScopeAndZapFloats` env) arg
+        -> do { (_, _, arg') <- simplArg env dup_flag se arg
               ; rebuild env (App expr arg') cont }
 
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1560,6 +1575,10 @@ simplNonRecE :: SimplEnv
 --  * non-top-level non-recursive lets in expressions
 --  * beta reduction
 --
+-- simplNonRec env b (rhs, rhs_se) (bs, body) k
+--   = let env in
+--     cont< let b = rhs_se(rhs) in \bs.body >
+--
 -- It deals with strict bindings, via the StrictBind continuation,
 -- which may abort the whole process
 --
@@ -1580,29 +1599,29 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
                  ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
                   simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
 
+           -- Deal with join points
+           | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
+           -> ASSERT( null bndrs )  -- Must be a let-binding;
+                                    -- join points are never lambda-bound
+              do { (env1, cont') <- prepareJoinCont env cont
+
+                   -- We push cont_dup into the join RHS and the body;
+                   -- and wrap cont_nodup around the whole thing
+                 ; let res_ty = contResultType cont'
+                 ; (env2, bndr1) <- simplNonRecJoinBndr env1 res_ty bndr'
+                 ; (env3, bndr2) <- addBndrRules env2 bndr' bndr1
+                 ; env4 <- simplJoinBind env3 NonRecursive cont'
+                                         bndr' bndr2 rhs' rhs_se
+                 ; simplExprF env4 body cont' }
+
+           -- Deal with strict bindings
            | isStrictId bndr          -- Includes coercions
+           , sm_case_case (getMode env)
            -> simplExprF (rhs_se `setFloats` env) rhs
-                         (StrictBind bndr bndrs body env cont)
-
-           | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
-           -> do { let cont_dup_res_ty = resultTypeOfDupableCont (getMode env)
-                                           [bndr'] cont
-                 ; (env1, bndr1) <- simplNonRecJoinBndr env
-                                                        cont_dup_res_ty bndr'
-                 ; (env2, bndr2) <- addBndrRules env1 bndr' bndr1
-                 ; (env3, cont_dup, cont_nodup)
-                     <- prepareLetCont (zapJoinFloats env2) [bndr'] cont
-                 ; MASSERT2(cont_dup_res_ty `eqType` contResultType cont_dup,
-                     ppr cont_dup_res_ty $$ blankLine $$
-                     ppr cont $$ blankLine $$
-                     ppr cont_dup $$ blankLine $$
-                     ppr cont_nodup)
-                 ; env4 <- simplJoinBind env3 NonRecursive cont_dup bndr' bndr2
-                                         rhs' rhs_se
-                 ; (env5, expr) <- simplLam env4 bndrs body cont_dup
-                 ; rebuild (env5 `restoreJoinFloats` env2)
-                           (wrapJoinFloats env5 expr) cont_nodup }
+                         (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
+                                     , sc_env = env, sc_cont = cont, sc_dup = NoDup })
 
+           -- Deal with lazy bindings
            | otherwise
            -> ASSERT( not (isTyVar bndr) )
               do { (env1, bndr1) <- simplNonRecBndr env bndr
@@ -1621,23 +1640,15 @@ simplRecE :: SimplEnv
 --  * non-top-level recursive lets in expressions
 simplRecE env pairs body cont
   | Just pairs' <- joinPointBindings_maybe pairs
-  = do  { let bndrs' = map fst pairs'
-              cont_dup_res_ty = resultTypeOfDupableCont (getMode env)
-                                                        bndrs' cont
-        ; env1 <- simplRecJoinBndrs env cont_dup_res_ty bndrs'
+  = do  { (env1, cont') <- prepareJoinCont env cont
+        ; let bndrs' = map fst pairs'
+              res_ty = contResultType cont
+        ; env2 <- simplRecJoinBndrs env1 res_ty bndrs'
                 -- NB: bndrs' don't have unfoldings or rules
                 -- We add them as we go down
-        ; (env2, cont_dup, cont_nodup) <- prepareLetCont (zapJoinFloats env1)
-                                                         bndrs' cont
-        ; MASSERT2(cont_dup_res_ty `eqType` contResultType cont_dup,
-            ppr cont_dup_res_ty $$ blankLine $$
-            ppr cont $$ blankLine $$
-            ppr cont_dup $$ blankLine $$
-            ppr cont_nodup)
-        ; env3 <- simplRecBind env2 NotTopLevel (Just cont_dup) pairs'
-        ; (env4, expr) <- simplExprF env3 body cont_dup
-        ; rebuild (env4 `restoreJoinFloats` env1)
-                  (wrapJoinFloats env4 expr) cont_nodup }
+        ; env3 <- simplRecBind env2 NotTopLevel (Just cont') pairs'
+        ; simplExprF env3 body cont' }
+
   | otherwise
   = do  { let bndrs = map fst pairs
         ; MASSERT(all (not . isJoinId) bndrs)
@@ -1647,7 +1658,6 @@ simplRecE env pairs body cont
         ; env2 <- simplRecBind env1 NotTopLevel Nothing pairs
         ; simplExprF env2 body cont }
 
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1663,18 +1673,19 @@ simplVar env var
   | isCoVar var = return (Coercion (substCoVar env var))
   | otherwise
   = case substId env var of
-        DoneId var1          -> return (Var var1)
-        DoneEx e             -> return e
         ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
+        DoneId var1          -> return (Var var1)
+        DoneEx e _           -> return e
 
 simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
 simplIdF env var cont
   = case substId env var of
-        DoneEx e             -> simplExprF (zapSubstEnv env) e trimmed_cont
         ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
-                                  -- Don't trim; haven't already simplified
-                                  -- the join, so the cont was never copied
-        DoneId var1          -> completeCall env var1 trimmed_cont
+                                  -- Don't trim; haven't already simplified e,
+                                  -- so the cont is not embodied in e
+
+        DoneId var1      -> completeCall env var1 (trim_cont (isJoinId_maybe var1))
+        DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trim_cont mb_join)
                 -- Note [zapSubstEnv]
                 -- The template is already simplified, so don't re-substitute.
                 -- This is VITAL.  Consider
@@ -1685,22 +1696,20 @@ simplIdF env var cont
                 -- Then when we inline y, we must *not* replace x by x' in
                 -- the inlined copy!!
   where
-    trimmed_cont | Just arity <- isJoinIdInEnv_maybe env var
-                 = trim_cont arity cont
-                 | otherwise
-                 = cont
+    trim_cont (Just arity) = trim arity cont
+    trim_cont Nothing      = cont
 
     -- Drop outer context from join point invocation
     -- Note [Case-of-case and join points]
-    trim_cont 0 cont@(Stop {})
+    trim 0 cont@(Stop {})
       = cont
-    trim_cont 0 cont
+    trim 0 cont
       = mkBoringStop (contResultType cont)
-    trim_cont n cont@(ApplyToVal { sc_cont = k })
-      = cont { sc_cont = trim_cont (n-1) k }
-    trim_cont n cont@(ApplyToTy { sc_cont = k })
-      = cont { sc_cont = trim_cont (n-1) k } -- join arity counts types!
-    trim_cont _ cont
+    trim n cont@(ApplyToVal { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k }
+    trim n cont@(ApplyToTy { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!
+    trim _ cont
       = pprPanic "completeCall" $ ppr var $$ ppr cont
 
 ---------------------------------------------------------
@@ -1805,9 +1814,11 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
   = rebuildCall env (addValArgTo info' arg) cont
 
   | str                 -- Strict argument
+  , sm_case_case (getMode env)
   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
     simplExprF (arg_se `setFloats` env) arg
-               (StrictArg info' cci_strict cont)
+               (StrictArg { sc_fun = info', sc_cci = cci_strict
+                          , sc_dup = Simplified, sc_cont = cont })
                 -- Note [Shadowing]
 
   | otherwise                           -- Lazy argument
@@ -2422,14 +2433,13 @@ rebuildCase env scrut case_bndr alts cont
 reallyRebuildCase env scrut case_bndr alts cont
   = do  {       -- Prepare the continuation;
                 -- The new subst_env is in place
-          (env', dup_cont, nodup_cont) <- prepareCaseCont (zapJoinFloats env)
-                                                          alts cont
+          (env, alt_cont, wrap_cont) <- prepareCaseCont env alts cont
 
         -- Simplify the alternatives
-        ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
+        ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts alt_cont
 
         ; dflags <- getDynFlags
-        ; let alts_ty' = contResultType dup_cont
+        ; let alts_ty' = contResultType alt_cont
         -- See Note [Avoiding space leaks in OutType]
         ; case_expr <- seqType alts_ty' `seq`
                        mkCase dflags scrut' case_bndr' alts_ty' alts'
@@ -2437,8 +2447,7 @@ reallyRebuildCase env scrut case_bndr alts cont
         -- Notice that rebuild gets the in-scope set from env', not alt_env
         -- (which in any case is only build in simplAlts)
         -- The case binder *not* scope over the whole returned case-expression
-        ; rebuild (env' `restoreJoinFloats` env)
-                  (wrapJoinFloats env' case_expr) nodup_cont }
+        ; rebuild env case_expr wrap_cont }
 
 {-
 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
@@ -2558,7 +2567,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
   | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
   = do { case_bndr2 <- newId (fsLit "nt") ty2
-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
               env2 = extendIdSubst env case_bndr rhs
         ; return (env2, scrut `Cast` co, case_bndr2) }
 
@@ -2792,7 +2801,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
        -- a new con-app from the args
     bind_case_bndr env
       | isDeadBinder bndr   = return env
-      | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))
+      | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut Nothing))
       | otherwise           = do { dc_args <- mapM (simplVar env) bs
                                          -- dc_ty_args are aready OutTypes,
                                          -- but bs are InBndrs
@@ -2820,15 +2829,37 @@ missingAlt env case_bndr _ cont
 \subsection{Duplicating continuations}
 *                                                                      *
 ************************************************************************
+
+Consider
+  let x* = case e of { True -> e1; False -> e2 }
+  in b
+where x* is a strict binding.  Then mkDupableCont will be given
+the continuation
+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop
+and will split it into
+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop
+   join floats:  $j1 = e1, $j2 = e2
+   non_dupable:  let x* = [] in b; stop
+
+Putting this back togeher would give
+   let x* = let { $j1 = e1; $j2 = e2 } in
+            case e of { True -> $j1; False -> $j2 }
+   in b
+(Of course we only do this if 'e' wants to duplicate that continuation.)
+Note how important it is that the new join points wrap around the
+inner expression, and not around the whole thing.
+
+In contrast, any let-bindings introduced by mkDupableCont can wrap
+around the entire thing.
 -}
 
-prepareCaseCont :: SimplEnv
-                -> [InAlt] -> SimplCont
+
+prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont
                 -> SimplM (SimplEnv,
-                           SimplCont,   -- Dupable part
-                           SimplCont)   -- Non-dupable part
+                           SimplCont,  -- For the alternatives
+                           SimplCont)  -- Wraps the entire case
 -- We are considering
---     K[case _ of { p1 -> r1; ...; pn -> rn }]
+--     K[ case _ of { p1 -> r1; ...; pn -> rn } ]
 -- where K is some enclosing continuation for the case
 -- Goal: split K into two pieces Kdup,Knodup so that
 --       a) Kdup can be duplicated
@@ -2848,18 +2879,13 @@ prepareCaseCont :: SimplEnv
 -- When case-of-case is off, just make the entire continuation non-dupable
 
 prepareCaseCont env alts cont
-  | not (sm_case_case (getMode env))
-  = return (env, mkBoringStop (contHoleType cont), cont)
   | not (altsWouldDup alts)
   = return (env, cont, mkBoringStop (contResultType cont))
   | otherwise
-  = mkDupableCont env cont
+  = do { (env', cont') <- mkDupableCont env cont
+       ; return (env', cont', mkBoringStop (contResultType cont)) }
 
-prepareLetCont :: SimplEnv
-               -> [InBndr] -> SimplCont
-               -> SimplM (SimplEnv,
-                          SimplCont,   -- Dupable part
-                          SimplCont)   -- Non-dupable part
+prepareJoinCont :: SimplEnv -> SimplCont -> SimplM (SimplEnv, SimplCont)
 
 -- Similar to prepareCaseCont, only for
 --     K[let { j1 = r1; ...; jn -> rn } in _]
@@ -2874,42 +2900,9 @@ prepareLetCont :: SimplEnv
 --     case (case e of { A -> jump j 1; ... }) of { B -> ... },
 -- and the reference to j is invalid.
 
-prepareLetCont env bndrs cont
-  | not (isJoinId (head bndrs))
-  = return (env, cont, mkBoringStop (contResultType cont))
-  | not (sm_case_case (getMode env))
-  = return (env, mkBoringStop (contHoleType cont), cont)
-  | otherwise
+prepareJoinCont env cont
   = mkDupableCont env cont
 
--- Predict the result type of the dupable cont returned by prepareLetCont (= the
--- hole type of the non-dupable part). Ugly, but sadly necessary so that we can
--- know what the new type of a recursive join point will be before we start
--- simplifying it.
-resultTypeOfDupableCont :: SimplifierMode
-                        -> [InBndr]
-                        -> SimplCont
-                        -> OutType   -- INVARIANT: Result type of dupable cont
-                                     -- returned by prepareLetCont
--- IMPORTANT: This must be kept in sync with mkDupableCont!
-resultTypeOfDupableCont mode bndrs cont
-  | not (any isJoinId bndrs)   = contResultType cont
-  | not (sm_case_case mode)    = contHoleType   cont
-  | otherwise                  = go cont
-  where
-    go cont | contIsDupable cont = contResultType cont
-    go (Stop {}) = panic "typeOfDupableCont" -- Handled by previous eqn
-    go (CastIt _  cont)     = go cont
-    go cont@(TickIt {})     = contHoleType cont
-    go cont@(StrictBind {}) = contHoleType cont
-    go (StrictArg _ _ cont) = go cont
-    go cont@(ApplyToTy  {}) = go (sc_cont cont)
-    go cont@(ApplyToVal {}) = go (sc_cont cont)
-    go (Select { sc_alts = alts, sc_cont = cont })
-      | not (sm_case_case mode) = contHoleType cont
-      | not (altsWouldDup alts) = contResultType cont
-      | otherwise               = go cont
-
 altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
 altsWouldDup []  = False        -- See Note [Bottom alternatives]
 altsWouldDup [_] = False
@@ -2930,57 +2923,95 @@ will disappear immediately.  This is more direct than creating
 join points and inlining them away.  See Trac #4930.
 -}
 
+-------------------------
 mkDupableCont :: SimplEnv -> SimplCont
-              -> SimplM (SimplEnv, SimplCont, SimplCont)
-
+              -> SimplM ( SimplEnv    -- Incoming SimplEnv augmented with
+                                      --   extra let/join-floats and in-scope variables
+                        , SimplCont)  -- dup_cont: duplicable continuation
 mkDupableCont env cont
+  = mk_dupable_cont env cont
+
+-------------------------
+mk_dupable_cont :: SimplEnv -> SimplCont
+                -> SimplM (SimplEnv, SimplCont)
+mk_dupable_cont env cont
   | contIsDupable cont
-  = return (env, cont, mkBoringStop (contResultType cont))
+  = return (env, cont)
 
-mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
+mk_dupable_cont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
 
-mkDupableCont env (CastIt ty cont)
-  = do  { (env', dup, nodup) <- mkDupableCont env cont
-        ; return (env', CastIt ty dup, nodup) }
+mk_dupable_cont env (CastIt ty cont)
+  = do  { (env', cont') <- mk_dupable_cont env cont
+        ; return (env', CastIt ty cont') }
 
 -- Duplicating ticks for now, not sure if this is good or not
-mkDupableCont env cont@(TickIt{})
-  = return (env, mkBoringStop (contHoleType cont), cont)
-
-mkDupableCont env cont@(StrictBind {})
-  =  return (env, mkBoringStop (contHoleType cont), cont)
-        -- See Note [Duplicating StrictBind]
-
-mkDupableCont env (StrictArg info cci cont)
+mk_dupable_cont env (TickIt t cont)
+  = do  { (env', cont') <- mk_dupable_cont env cont
+        ; return (env', TickIt t cont') }
+
+mk_dupable_cont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
+                                , sc_body = body, sc_env = se, sc_cont = cont})
+  -- See Note [Duplicating StrictBind]
+  = do { let sb_env = se `setInScopeAndZapFloats` env
+       ; (sb_env1, bndr') <- simplBinder sb_env bndr
+       ; (sb_env', join_inner) <- simplLam sb_env1 bndrs body cont
+          -- No need to use mk_dupable_cont before simplLam; we
+          -- use cont once here, and then share the result if necessary
+       ; let join_body = wrapFloats sb_env' join_inner
+             res_ty    = contResultType cont
+       ; dflags <- getDynFlags
+       ; (env2, body2)
+            <- if exprIsDupable dflags join_body
+               then return (env, join_body)
+               else do { join_bndr <- newJoinId [bndr'] res_ty
+                       ; let join_call = App (Var join_bndr) (Var bndr')
+                             join_rhs  = Lam (setOneShotLambda bndr') join_body
+                       ; return (addNonRec env join_bndr join_rhs, join_call) }
+       ; return ( env2
+                , StrictBind { sc_bndr = bndr', sc_bndrs = []
+                             , sc_body = body2
+                             , sc_env  = zapSubstEnv se
+                             , sc_dup  = OkToDup
+                             , sc_cont = mkBoringStop res_ty } ) }
+
+mk_dupable_cont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })
         -- See Note [Duplicating StrictArg]
-  = do { (env', dup, nodup) <- mkDupableCont env cont
-       ; (env'', args')     <- mapAccumLM makeTrivialArg env' (ai_args info)
-       ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
-
-mkDupableCont env cont@(ApplyToTy { sc_cont = tail })
-  = do  { (env', dup_cont, nodup_cont) <- mkDupableCont env tail
-        ; return (env', cont { sc_cont = dup_cont }, nodup_cont ) }
-
-mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se, sc_cont = cont })
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+  = do { (env', cont')  <- mk_dupable_cont env cont
+       ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info)
+       ; return (env'', StrictArg { sc_fun = info { ai_args = args' }
+                                  , sc_cci = cci
+                                  , sc_cont = cont'
+                                  , sc_dup = OkToDup} ) }
+
+mk_dupable_cont env (ApplyToTy { sc_cont = cont
+                               , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
+  = do  { (env', cont') <- mk_dupable_cont env cont
+        ; return (env', ApplyToTy { sc_cont = cont'
+                                  , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
+
+mk_dupable_cont env (ApplyToVal { sc_arg = arg, sc_dup = dup
+                                , sc_env = se, sc_cont = cont })
   =     -- e.g.         [...hole...] (...arg...)
         --      ==>
         --              let a = ...arg...
         --              in [...hole...] a
-    do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+    do  { (env', cont') <- mk_dupable_cont env cont
         ; (_, se', arg') <- simplArg env' dup se arg
         ; (env'', arg'') <- makeTrivial NotTopLevel env' (fsLit "karg") arg'
-        ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = se'
-                                    , sc_dup = OkToDup, sc_cont = dup_cont }
-        ; return (env'', app_cont, nodup_cont) }
+        ; return (env'', ApplyToVal { sc_arg = arg'', sc_env = se'
+                                    , sc_dup = OkToDup, sc_cont = cont' }) }
 
-mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
-                          , sc_env = se, sc_cont = cont })
+mk_dupable_cont env (Select { sc_bndr = case_bndr, sc_alts = alts
+                            , sc_env = se, sc_cont = cont })
   =     -- e.g.         (case [...hole...] of { pi -> ei })
         --      ===>
         --              let ji = \xij -> ei
         --              in case [...hole...] of { pi -> ji xij }
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
     do  { tick (CaseOfCase case_bndr)
-        ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
+        ; (env', alt_cont, wrap_cont) <- prepareCaseCont env alts cont
                 -- NB: We call prepareCaseCont here.  If there is only one
                 -- alternative, then dup_cont may be big, but that's ok
                 -- because we push it into the single alternative, and then
@@ -2991,7 +3022,7 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
         ; let alt_env = se `setInScopeAndZapFloats` env'
 
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
-        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts
         -- Safe to say that there are no handled-cons for the DEFAULT case
                 -- NB: simplBinder does not zap deadness occ-info, so
                 -- a dead case_bndr' will still advertise its deadness
@@ -3004,36 +3035,30 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
         -- NB: we don't use alt_env further; it has the substEnv for
         --     the alternatives, and we don't want that
 
-        ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
+        ; (join_binds, alts'') <- mkDupableAlts case_bndr' alts'
+        ; let env'' = foldl (\env (j,r) -> addNonRec env j r) env' join_binds
+
         ; return (env'',  -- Note [Duplicated env]
-                  Select { sc_dup = OkToDup
+                  Select { sc_dup  = OkToDup
                          , sc_bndr = case_bndr', sc_alts = alts''
-                         , sc_env = zapSubstEnv env''
-                         , sc_cont = mkBoringStop (contHoleType nodup_cont) },
-                  nodup_cont) }
+                         , sc_env  = zapSubstEnv env''
+                         , sc_cont = wrap_cont } ) }
 
+mkDupableAlts :: OutId -> [OutAlt] -> SimplM ([(JoinId, OutExpr)], [OutAlt])
+mkDupableAlts case_bndr' the_alts
+  = do { dflags <- getDynFlags
+       ; (mb_join_floats, dup_alts)
+             <- mapAndUnzipM (mkDupableAlt dflags case_bndr') the_alts
+       ; return (catMaybes mb_join_floats, dup_alts) }
 
-mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
-              -> SimplM (SimplEnv, [InAlt])
--- Absorbs the continuation into the new alternatives
+mkDupableAlt :: DynFlags -> OutId -> OutAlt
+             -> SimplM (Maybe (JoinId,OutExpr), OutAlt)
+mkDupableAlt dflags case_bndr (con, bndrs', rhs')
+  | exprIsDupable dflags rhs'  -- Note [Small alternative rhs]
+  = return (Nothing, (con, bndrs', rhs'))
 
-mkDupableAlts env case_bndr' the_alts
-  = go env the_alts
-  where
-    go env0 [] = return (env0, [])
-    go env0 (alt:alts)
-        = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
-             ; (env2, alts') <- go env1 alts
-             ; return (env2, alt' : alts' ) }
-
-mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
-              -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
-mkDupableAlt env case_bndr (con, bndrs', rhs') = do
-  dflags <- getDynFlags
-  if exprIsDupable dflags rhs'  -- Note [Small alternative rhs]
-   then return (env, (con, bndrs', rhs'))
-   else
-    do  { let rhs_ty'  = exprType rhs'
+  | otherwise
+  = do  { let rhs_ty'  = exprType rhs'
               scrut_ty = idType case_bndr
               case_bndr_w_unf
                 = case con of
@@ -3058,29 +3083,24 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
                   | isTyVar bndr = True -- Abstract over all type variables just in case
                   | otherwise    = not (isDeadBinder bndr)
                         -- The deadness info on the new Ids is preserved by simplBinders
-              final_args    -- Note [Join point abstraction]
-                = varsToCoreExprs final_bndrs'
+              final_args = varsToCoreExprs final_bndrs'
+                           -- Note [Join point abstraction]
 
-        ; join_bndr <- newId (fsLit "$j") (mkLamTypes final_bndrs' rhs_ty')
-                -- Note [Funky mkLamTypes]
-
-        ; let   -- We make the lambdas into one-shot-lambdas.  The
+                -- We make the lambdas into one-shot-lambdas.  The
                 -- join point is sure to be applied at most once, and doing so
                 -- prevents the body of the join point being floated out by
                 -- the full laziness pass
-                really_final_bndrs     = map one_shot final_bndrs'
-                one_shot v | isId v    = setOneShotLambda v
-                           | otherwise = v
-                join_rhs   = mkLams really_final_bndrs rhs'
-                arity      = length (filter (not . isTyVar) final_bndrs')
-                join_arity = length final_bndrs'
-                final_join_bndr = (join_bndr `setIdArity` arity)
-                                    `asJoinId` join_arity
-                join_call  = mkApps (Var final_join_bndr) final_args
-                final_join_bind = NonRec final_join_bndr join_rhs
-
-        ; env' <- addPolyBind NotTopLevel env final_join_bind
-        ; return (env', (con, bndrs', join_call)) }
+              really_final_bndrs     = map one_shot final_bndrs'
+              one_shot v | isId v    = setOneShotLambda v
+                         | otherwise = v
+              join_rhs   = mkLams really_final_bndrs rhs'
+
+        ; join_bndr <- newJoinId final_bndrs' rhs_ty'
+
+        ; let join_call = mkApps (Var join_bndr) final_args
+              alt'      = (con, bndrs', join_call)
+
+        ; return (Just (join_bndr, join_rhs), alt') }
                 -- See Note [Duplicated env]
 
 {-
@@ -3105,7 +3125,7 @@ The simplifier will find
 So we'll call mkDupableCont on
    Select [I# a -> I# a] (StrictBind body Stop)
 There is just one alternative in the first Select, so we want to
-simplify the rhs (I# a) with continuation (StricgtBind body Stop)
+simplify the rhs (I# a) with continuation (StrictBind body Stop)
 Supposing that body is big, we end up with
           let $j a = <let x = I# a in body>
           in case v of { pn -> case rn of
@@ -3200,13 +3220,79 @@ type variables as well as term variables.
         case (case e of ...) of
             C t xs::[t] -> j t xs
 
-Note [Join point abstraction]
+Note [Duplicating StrictArg]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We make a StrictArg duplicable simply by making all its
+stored-up arguments (in sc_fun) trivial, by let-binding
+them.  Thus:
+        f E [..hole..]
+        ==>     let a = E
+                in f a [..hole..]
+Now if the thing in the hole is a case expression (which is when
+we'll call mkDupableCont), we'll push the function call into the
+branches, which is what we want.  Now RULES for f may fire, and
+call-pattern specialisation.  Here's an example from Trac #3116
+     go (n+1) (case l of
+                 1  -> bs'
+                 _  -> Chunk p fpc (o+1) (l-1) bs')
+If we can push the call for 'go' inside the case, we get
+call-pattern specialisation for 'go', which is *crucial* for
+this program.
 
-NB: This note is now historical. Now that "join point" is not a fuzzy concept
-but a formal syntactic construct (as distinguished by the JoinId constructor of
-IdDetails), each of these concerns is handled separately, with no need for a
-vestigial extra argument.
+Here is the (&&) example:
+        && E (case x of { T -> F; F -> T })
+  ==>   let a = E in
+        case x of { T -> && a F; F -> && a T }
+Much better!
+
+Notice that
+  * Arguments to f *after* the strict one are handled by
+    the ApplyToVal case of mkDupableCont.  Eg
+        f [..hole..] E
+
+  * We can only do the let-binding of E because the function
+    part of a StrictArg continuation is an explicit syntax
+    tree.  In earlier versions we represented it as a function
+    (CoreExpr -> CoreEpxr) which we couldn't take apart.
+
+Historical aide: previously we did this (where E is a
+big argument:
+        f E [..hole..]
+        ==>     let $j = \a -> f E a
+                in $j [..hole..]
+
+But this is terrible! Here's an example:
+        && E (case x of { T -> F; F -> T })
+Now, && is strict so we end up simplifying the case with
+an ArgOf continuation.  If we let-bind it, we get
+        let $j = \v -> && E v
+        in simplExpr (case x of { T -> F; F -> T })
+                     (ArgOf (\r -> $j r)
+And after simplifying more we get
+        let $j = \v -> && E v
+        in case x of { T -> $j F; F -> $j T }
+Which is a Very Bad Thing
+
+
+Note [Duplicating StrictBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We make a StrictBind duplicable in a very similar way to
+that for case expressions.  After all,
+   let x* = e in b   is similar to    case e of x -> b
+
+So we potentially make a join-point for the body, thus:
+   let x = [] in b   ==>   join j x = b
+                           in let x = [] in j x
+
+
+Note [Join point abstraction]  Historical note
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: This note is now historical, describing how (in the past) we used
+to add a void argument to nullary join points.  But now that "join
+point" is not a fuzzy concept but a formal syntactic construct (as
+distinguished by the JoinId constructor of IdDetails), each of these
+concerns is handled separately, with no need for a vestigial extra
+argument.
 
 Join points always have at least one value argument,
 for several reasons
@@ -3253,69 +3339,6 @@ case_bndr to all the join points if it's used in *any* RHS,
 because we don't know its usage in each RHS separately
 
 
-Note [Duplicating StrictArg]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The original plan had (where E is a big argument)
-e.g.    f E [..hole..]
-        ==>     let $j = \a -> f E a
-                in $j [..hole..]
-
-But this is terrible! Here's an example:
-        && E (case x of { T -> F; F -> T })
-Now, && is strict so we end up simplifying the case with
-
-an ArgOf continuation.  If we let-bind it, we get
-        let $j = \v -> && E v
-        in simplExpr (case x of { T -> F; F -> T })
-                     (ArgOf (\r -> $j r)
-And after simplifying more we get
-        let $j = \v -> && E v
-        in case x of { T -> $j F; F -> $j T }
-Which is a Very Bad Thing
-
-What we do now is this
-        f E [..hole..]
-        ==>     let a = E
-                in f a [..hole..]
-Now if the thing in the hole is a case expression (which is when
-we'll call mkDupableCont), we'll push the function call into the
-branches, which is what we want.  Now RULES for f may fire, and
-call-pattern specialisation.  Here's an example from Trac #3116
-     go (n+1) (case l of
-                 1  -> bs'
-                 _  -> Chunk p fpc (o+1) (l-1) bs')
-If we can push the call for 'go' inside the case, we get
-call-pattern specialisation for 'go', which is *crucial* for
-this program.
-
-Here is the (&&) example:
-        && E (case x of { T -> F; F -> T })
-  ==>   let a = E in
-        case x of { T -> && a F; F -> && a T }
-Much better!
-
-Notice that
-  * Arguments to f *after* the strict one are handled by
-    the ApplyToVal case of mkDupableCont.  Eg
-        f [..hole..] E
-
-  * We can only do the let-binding of E because the function
-    part of a StrictArg continuation is an explicit syntax
-    tree.  In earlier versions we represented it as a function
-    (CoreExpr -> CoreEpxr) which we couldn't take apart.
-
-Do *not* duplicate StrictBind and StritArg continuations.  We gain
-nothing by propagating them into the expressions, and we do lose a
-lot.
-
-The desire not to duplicate is the entire reason that
-mkDupableCont returns a pair of continuations.
-
-Note [Duplicating StrictBind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Unlike StrictArg, there doesn't seem anything to gain from
-duplicating a StrictBind continuation, so we don't.
-
 
 ************************************************************************
 *                                                                      *
index 361f533..4ee88d1 100644 (file)
@@ -699,7 +699,7 @@ test('T6048',
             # 2014-12-01: 49987836 (x86 Windows)
             # 2016-04-06: 55701280 (x86/Linux, 64-bit machine)
 
-           (wordsize(64), 115714216, 10)])
+           (wordsize(64), 90996312, 10)])
              # 2012-09-18  97247032 amd64/Linux
              # 2014-01-16 108578664 amd64/Linux (unknown, likely foldl-via-foldr)
              # 2014-01-18  95960720 amd64/Linux Call Arity improvements
@@ -712,6 +712,7 @@ test('T6048',
              # 2016-03-11 108225624 amd64/Linux unknown reason sadly; likely gradual creep.
              # 2016-11-25  94327392 amd64/Linux Back down again hooray; still not sure why
              # 2017-02-17 115715592 amd64/Linux Type-indexed Typeable
+             # 2017-04-28 90996312 Join point refactoring
       ],
       compile,[''])
 
index 57a2a24..277aa18 100644 (file)
@@ -1 +1 @@
-  = case GHC.Real.$wf1 2# 8# of ww4 { __DEFAULT -> GHC.Types.I# ww4 }
+lvl = case GHC.Real.$wf1 2# 8# of v { __DEFAULT -> GHC.Types.I# v }
index 7c464db..0e5dc17 100644 (file)
@@ -13,8 +13,6 @@
 Total ticks:     55
 
 18 PreInlineUnconditionally
-  1 c
-  1 n
   1 g
   1 xs
   1 ys
@@ -28,6 +26,8 @@ Total ticks:     55
   1 k
   1 z
   1 g
+  1 c
+  1 n
   1 lvl
   1 lvl
   1 lvl
@@ -42,9 +42,6 @@ Total ticks:     55
 5 LetFloatFromLet 5
 25 BetaReduction
   1 a
-  1 c
-  1 n
-  1 a
   1 g
   1 a
   1 xs
@@ -66,6 +63,9 @@ Total ticks:     55
   1 k
   1 z
   1 g
+  1 a
+  1 c
+  1 n
 10 SimplifierDone 10