GitLab

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

77b48b37

by sheaf at 2026-03-01T06:30:28-05:00

Clean up join points, casts & ticks

This commit shores up the logic dealing with casts and ticks occurring
in between a join point binding and a jump.

Fixes #26642 #26929 #26693
Makes progress on #14610 #26157 #26422

Changes:

  - Remove 'GHC.Types.Tickish.TickishScoping' in favour of simpler
    predicates 'tickishHasNoScope'/'tickishHasSoftScope', as things were
    before commit 993975d3. This makes the code easier to read and
    document (fewer indirections).

  - Introduce 'canCollectArgsThroughTick' for consistent handling of
    ticks around PrimOps and other 'Id's that cannot be eta-reduced.
    See overhauled Note [Ticks and mandatory eta expansion].

  - New Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt that explains
    robustness of JoinId vs fragility of TailCallInfo.

  - Allow casts/non-soft-scoped ticks to occur in between a join point
    binder and a jump, but only in Core Prep.
    See Note [Join points, casts, and ticks] and
    Note [Join points, casts, and ticks... in Core Prep]
    in GHC.Core.Opt.Simplify.Iteration.

    Also update Core Lint to account for this.
    See Note [Linting join points with casts or ticks] in GHC.Core.Lint.

  - Update 'GHC.Core.Utils.mergeCaseAlts' to avoid pushing a cast in
    between a join point binding and its jumps. This fixes #26642.
    See the new (MC5) and (MC6) in Note [Merge Nested Cases].

  - Update float out to properly handle source note ticks. They are now
    properly floated out instead of being discarded.
    This increases the number of ticks in certain tests with -g.

Test cases: T26642 and TrickyJoins.

Metric increase due to more source note ticks with -g:

-------------------------
Metric Increase:
    libdir
    size_hello_artifact
    size_hello_unicode
-------------------------

21 changed files:

compiler/GHC/Cmm/Node.hs
compiler/GHC/Core.hs
compiler/GHC/Core/Lint.hs
compiler/GHC/Core/Opt/Arity.hs
compiler/GHC/Core/Opt/FloatIn.hs
compiler/GHC/Core/Opt/FloatOut.hs
compiler/GHC/Core/Opt/OccurAnal.hs
compiler/GHC/Core/Opt/Simplify/Iteration.hs
compiler/GHC/Core/SimpleOpt.hs
compiler/GHC/Core/Utils.hs
compiler/GHC/CoreToStg/Prep.hs
compiler/GHC/Driver/Config/Core/Lint.hs
compiler/GHC/Iface/Tidy.hs
compiler/GHC/StgToCmm/Expr.hs
compiler/GHC/Types/Basic.hs
compiler/GHC/Types/Id/Info.hs
compiler/GHC/Types/Tickish.hs
testsuite/tests/codeGen/should_compile/debug.stdout
+ testsuite/tests/simplCore/should_compile/T26642.hs
+ testsuite/tests/simplCore/should_compile/TrickyJoins.hs
testsuite/tests/simplCore/should_compile/all.T

Changes:

compiler/GHC/Cmm/Node.hs

@@ -819,8 +819,8 @@ data CmmTickScope
    | SubScope !U.Unique CmmTickScope
      -- ^ Constructs a new sub-scope to an existing scope. This allows
 -    -- us to translate Core-style scoping rules (see @tickishScoped@)
 -    -- into the Cmm world. Suppose the following code:
 +    -- us to translate Core-style scoping rules (see Note [Scoping ticks and counting ticks]
 +    -- in GHC.Types.Tickish) into the Cmm world. Suppose the following code:
      --
      --   tick<1> case ... of
      --             A -> tick<2> ...

compiler/GHC/Core.hs

@@ -1035,6 +1035,143 @@ tail position: A cast changes the type, but the type must be the same. But
  operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for
  ideas how to fix this.
 +Note [Join points, casts, and ticks]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +Point (1) of Note [Invariants on join points] says that a join point
 +must always be tail called.  But what precisely does "tail called" mean
 +in the presence of (a) casts and (b) ticks?
++
 +Example (CAST)
 +  let j x = rhs in
 +  case y of { True -> j 1 |> co; False -> j 2 }
++
 +Example (TICK)
 +  let j x = rhs in
 +  case y of { True -> <tick t> (j 1); False -> j 2 }
++
 +Answer: in Core:
++
 +  (JCT1) A tail call cannot be under a cast.
++
 +    Thus, in (CAST), `j` is not a join point.
++
 +  (JCT2) A tail call cannot be under a cost-centre-scoped tick.
++
 +    Thus, in  (TICK), `j` is a join point only if tick `t` has soft scope
 +    (as per Note [Scoping ticks and counting ticks] in GHC.Tickish).
++
 +The Big Reason for these choices is that the Simplifier moves the continuation
 +into the RHS of a join point, as explained in Note [Join points and case-of-case]
 +in GHC.Core.Opt.Simplify.Iteration:
++
 +   K[ join j x = rhs in body ]  -->  join j x = K[rhs] in K[body]
++
 +and K then evaporates when it encounters the tail call:
++
 +   K[jump j v]  -->  jump j v
++
 +These transformations:
 +  * Are ill-typed if the tail is under a cast, hence (JCT1)
 +  * Change cost semantics if the tick has cost-centre scope, hence (JCT2)
++
 +The occurrence analyser is careful not to treat an occurrence as a tail call if
 +it falls under (JCT1) or (JCT2), by using 'markAllNonTail'.
++
 +However, during /code generation/ the key thing about a join point is that
 +  * The binding does no allocation
 +  * A tail call can be implemented by "adjust stack pointer and jump".
++
 +This code-gen strategy works fine even if the "tail call" occurs under
 +/arbitrary/ ticks and casts.  Hence:
++
 +(JCT3) In CorePrep, the occurrence analyser is called with a special flag that
 +   /does/ treat `j` as tail-called in Example (CAST) and Example (TICK).
 +   Core Prep then uses 'joinPointBinding_maybe', which turns always-tail-called
 +   let bindings into join points, thus recovering join-point-hood.
++
 +See also Note [Linting join points with casts or ticks] in GHC.Core.Lint.
++
 +Examples
 +========
++
 +  Join point jumps under ticks (#14242, #26157, #26642, #26693)
 +  ============================
 +  In #26693 we had:
++
 +    join { j :: Bool -> Int -> IO (); j _ = guts }
 +    in case b of
 +      False -> scc<foo> jump j True
 +      True  ->          jump j False
++
 +  If we try to push the application to an argument 'arg :: Int' into this
 +  expression, we first get:
++
 +    join { j :: Bool -> IO (); j _ = guts arg ] }
 +    in case b of
 +      False -> (scc<foo> jump j True) arg
 +      True  ->           jump j False arg
++
 +  We then rely on 'trimJoinCont' to remove the argument. In this case, this fails
 +  for the first branch, because 'trimJoinCont' doesn't look through profiling
 +  ticks. Were we to address this, it's still not clear what code we would want to
 +  end up with, as we don't want to misattribute profiling costs.
 +  We could plausibly transform to the following:
++
 +    join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] }
 +    in case b of
 +      False -> jump j <foo> True
 +      True  -> jump j null  False
++
 +  where `setSCC#` is a new primop that would set the current cost centre pointer
 +  (or no-op if the given pointer is null). However:
 +    - this primop doesn't exist today,
 +    - it requires adding an argument to the join point (hence changing its arity)
++
 +  Note that soft scope ticks are floated out by the simplifier (see the
 +  'tickishHasSoftScope' guard in 'GHC.Core.Opt.Simplify.Iteration.simplTick'),
 +  so don't suffer from the same problem.
++
 +  Join point jumps under casts (#14610, #21716, #26422)
 +  ============================
 +  Consider:
++
 +    newtype Age = MkAge Int   -- axAge :: Age ~ Int
 +    f :: Int -> ...
++
 +    f (join j :: Bool -> Age
 +            j x = (rhs1 :: Age)
 +       in case v of
 +           Just x  -> ((j x) |> axAge) :: Int
 +           Nothing -> rhs2)
++
 +  If we try to use the case of case transformation to push 'f' inwards, we would
 +  get:
++
 +     join j' x = f (rhs1 :: Age)
 +     in case v of
 +        Just x  -> (j' x |> axAge)
 +        Nothing -> f rhs2
++
 +  which is utterly bogus, as we are now passing an argument of type 'Age' to
 +  'f', which expects an 'Int'.
++
 +  The alternative would be to implement a transformation of the form
++
 +      join { j x = blah }
 +      in case e of
 +        False -> j True  |> co1
 +        True  -> j False |> co2
++
 +    ====>
++
 +      join { j x co = blah |> co }
 +      in case e of
 +        False -> j True  co1
 +        True  -> j False co2
++
 +  by adding a coercion argument to the join point. We don't do this currently.
++
++
  Note [Strict fields in Core]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  In Core, evaluating a data constructor worker evaluates its strict fields.

compiler/GHC/Core/Lint.hs

@@ -106,6 +106,7 @@ import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty )
  import Data.Maybe
  import Data.IntMap.Strict ( IntMap )
  import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )
 +import GHC.Types.Unique.Map
  {-
  Note [Core Lint guarantee]
@@ -914,8 +915,8 @@ lintCoreExpr (Lit lit)
         ; return (literalType lit, zeroUE) }
  lintCoreExpr (Cast expr co)
 -  = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr)
 -            -- markAllJoinsBad: see Note [Join points and casts]
 +  = do { (expr_ty, ue) <- markAllJoinsUnderCast (lintCoreExpr expr)
 +            -- markAllJoinsUnderCast: see Note [Linting join points with casts or ticks]
         ; lintCoercion co
         ; lintRole co Representational (coercionRole co)
@@ -929,14 +930,7 @@ lintCoreExpr (Tick tickish expr)
    = do { case tickish of
             Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0
             _                  -> return ()
 -       ; markAllJoinsBadIf block_joins $ lintCoreExpr expr }
 -  where
 -    block_joins = not (tickish `tickishScopesLike` SoftScope)
 -      -- TODO Consider whether this is the correct rule. It is consistent with
 -      -- the simplifier's behaviour - cost-centre-scoped ticks become part of
 -      -- the continuation, and thus they behave like part of an evaluation
 -      -- context, but soft-scoped and non-scoped ticks simply wrap the result
 -      -- (see Simplify.simplTick).
 +       ; markAllJoinsUnderTick tickish $ lintCoreExpr expr }
  lintCoreExpr (Let (NonRec tv (Type ty)) body)
    | isTyVar tv
@@ -1017,22 +1011,16 @@ lintCoreExpr e@(App _ _)
         ; return app_pair}
    where
 -    skipTick t = case collectFunSimple e of
 -      (Var v) -> etaExpansionTick v t
 -      _ -> tickishFloatable t
 -    (fun, args, _source_ticks) = collectArgsTicks skipTick e
 -      -- We must look through source ticks to avoid #21152, for example:
 -      --
 -      -- reallyUnsafePtrEquality
 -      --   = \ @a ->
 -      --       (src<loc> reallyUnsafePtrEquality#)
 -      --         @Lifted @a @Lifted @a
 +    skipTick t =
 +      case collectFunSimple e of
 +        Var v -> canCollectArgsThroughTick v t
 +        _ -> tickishFloatable t
 +    (fun, args, _ticks) = collectArgsTicks skipTick e
 +      -- We must look through ticks, otherwise we may fail to spot a
 +      -- saturated application. We use 'canCollectArgsThroughTicks', which is
 +      -- the same predicate that Core Prep uses.
        --
 -      -- To do this, we use `collectArgsTicks tickishFloatable` to match
 -      -- the eta expansion behaviour, as per Note [Eta expansion and source notes]
 -      -- in GHC.Core.Opt.Arity.
 -      -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.
 -      -- See Note [Ticks and mandatory eta expansion]
 +      -- See Note [Ticks and mandatory eta expansion] in GHC.CoreToStg.Prep.
  lintCoreExpr (Lam var expr)
    = markAllJoinsBad $
@@ -1131,7 +1119,7 @@ checkDeadIdOcc id
  ------------------
  lintJoinBndrType :: OutType -- Type of the body
                   -> OutId   -- Possibly a join Id
 -                -> LintM ()
 +                 -> LintM ()
  -- Checks that the return type of a join Id matches the body
  -- E.g. join j x = rhs in body
  --      The type of 'rhs' must be the same as the type of 'body'
@@ -1139,13 +1127,29 @@ lintJoinBndrType body_ty bndr
    | JoinPoint arity <- idJoinPointHood bndr
    , let bndr_ty = idType bndr
    , (bndrs, res) <- splitPiTys bndr_ty
 -  = do let msg =
 -             hang (text "Join point returns different type than body")
 -                2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
 -                        , text "Join arity:" <+> ppr arity
 -                        , text "Body type:" <+> ppr body_ty ])
 -       checkL (length bndrs >= arity) msg
 -       ensureEqTys body_ty (mkPiTys (drop arity bndrs) res) msg
 +  = do let
 +          ty_msg =
 +            hang (text "Join point returns different type than body")
 +              2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
 +                      , text "Join arity:" <+> ppr arity
 +                      , text "Body type:" <+> ppr body_ty ])
 +          arity_msg =
 +            hang (text "Join point is not saturated")
 +              2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
 +                      , text "Join arity:" <+> ppr arity
 +                      , text "Arguments:" <+> ppr bndrs ])
++
 +       mb_join_info <- lookupJoinId bndr
 +       case mb_join_info of
 +         Nothing ->
 +          pprPanic "lintJoinBndrType: valid join marked bad" (ppr bndr)
 +         Just (_, occ_info) -> do
 +           checkL (length bndrs >= arity) arity_msg
++
 +           -- See Note [Linting join points with casts or ticks] for why
 +           -- we skip this check if there is an intervening cast.
 +           unless (occ_info == JoinOccUnderCast) $
 +             ensureEqTys body_ty (mkPiTys (drop arity bndrs) res) ty_msg
    | otherwise
    = return ()
@@ -1156,11 +1160,11 @@ checkJoinOcc var n_args
    | JoinPoint join_arity_occ <- idJoinPointHood var
    = do { mb_join_arity_bndr <- lookupJoinId var
         ; case mb_join_arity_bndr of {
 -           NotJoinPoint -> do { join_set <- getValidJoins
 -                              ; addErrL (text "join set " <+> ppr join_set $$
 -                                invalidJoinOcc var) } ;
 +           Nothing -> do { valid_joins <- getValidJoins
 +                         ; addErrL (text "valid joins:" <+> ppr valid_joins $$
 +                           invalidJoinOcc var) } ;
 -           JoinPoint join_arity_bndr ->
 +           Just (join_arity_bndr, _join_occ) ->
      do { checkL (join_arity_bndr == join_arity_occ) $
             -- Arity differs at binding site and occurrence
@@ -1333,39 +1337,34 @@ checkLinearity body_ue lam_var =
        return body_ue'
      Nothing    -> return body_ue -- A type variable
 -{- Note [Join points and casts]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -You might think that this should be OK:
 -   join j x = rhs
 -   in (case e of
 -          A   -> alt1
 -          B x -> (jump j x) |> co)
 +{- Note [Linting join points with casts or ticks]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +As per Note [Join points, casts, and ticks] in GHC.Core, we have to be careful
 +when a cast or tick occurs in between a join point binding and a corresponding
 +join point occurrence.
 -You might think that, since the cast is ultimately erased, the jump to
 -`j` should still be OK as a join point.  But no!  See #21716. Suppose
 +Generally speaking:
 -  newtype Age = MkAge Int   -- axAge :: Age ~ Int
 -  f :: Int -> ...           -- f strict in it's first argument
 +  - The simplifier cannot handle intervening casts or non-soft-scope ticks, so
 +    we must check for that to avoid producing invalid Core.
 +  - However, as per (JCT3), Core Prep **can** produce join points with
 +    intervening casts or non-soft-scope ticks, which means we must expect them.
 -and consider the expression
 +Casts present an additional challenge. Consider for example:
 -  f (join j :: Bool -> Age
 -          j x = (rhs1 :: Age)
 -     in case v of
 -         Just x  -> (j x |> axAge :: Int)
 -         Nothing -> rhs2)
 +    join { j :: Bool -> Age; j x = (blah :: Age) }
 +    in case e of
 +      False -> j True |> (co1 :: Age ~ Int)
 +      True  -> other :: Int
 -Then, if the Simplifier pushes the strict call into the join points
 -and alternatives we'll get
 +It is **not** the case that the type of 'blah' is the same as the type of
 +the body of the join point binding! Indeed:
 -   join j' x = f (rhs1 :: Age)
 -   in case v of
 -      Just x  -> j' x |> axAge
 -      Nothing -> f rhs2
 +  - RHS of the join-point binding: blah :: Age
 +  - The body of the join point has type Int.
 -Utterly bogus.  `f` expects an `Int` and we are giving it an `Age`.
 -No no no.  Casts destroy the tail-call property.  Henc markAllJoinsBad
 -in the (Cast expr co) case of lintCoreExpr.
 +So we skip the 'exprType(join_rhs) == exprType(join_body)' check when casts
 +occur in between.
  Note [No alternatives lint check]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2977,9 +2976,10 @@ data LintEnv
                      --    type variables, and coercion variables)
                      -- Used at an occurrence of the InVar
 -       , le_joins :: IdSet     -- Join points in scope that are valid
 -                               -- A subset of the InScopeSet in le_subst
 -                               -- See Note [Join points]
 +       , le_joins :: UniqMap Id JoinOcc
 +           -- ^ Join points in scope that are valid
 +           -- A subset of the InScopeSet in le_subst
 +           -- See Note [Join points]
         , le_ue_aliases :: NameEnv UsageEnv
               -- See Note [Linting linearity]
@@ -2999,6 +2999,7 @@ data LintFlags
         , lf_check_linearity :: Bool    -- ^ See Note [Linting linearity]
         , lf_check_fixed_rep :: Bool    -- ^ See Note [Checking for representation polymorphism]
         , lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals]
 +       , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks]
+     }
  -- See Note [Checking StaticPtrs]
@@ -3307,6 +3308,20 @@ data LintLocInfo
    | InCo   Coercion     -- Inside a coercion
    | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom
 +-- | Does this join point 'Id' occur inside a cast?
 +--
 +-- See Note [Linting join points with casts or ticks].
 +data JoinOcc
 +  -- | A normal occurrence of a 'JoinId'.
 +  = NormalJoinOcc
 +  -- | An occurrence of a 'JoinId' with an intervening cast between the
 +  -- join point binder definition and the jump.
 +  | JoinOccUnderCast
 +  deriving stock Eq
 +instance Outputable JoinOcc where
 +  ppr NormalJoinOcc = text "Normal"
 +  ppr JoinOccUnderCast = text "UnderCast"
++
  data LintConfig = LintConfig
    { l_diagOpts   :: !DiagOpts         -- ^ Diagnostics opts
    , l_platform   :: !Platform         -- ^ Target platform
@@ -3328,7 +3343,7 @@ initL cfg m
      env = LE { le_flags   = l_flags cfg
               , le_subst   = mkEmptySubst (mkInScopeSetList vars)
               , le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ]
 -             , le_joins   = emptyVarSet
 +             , le_joins   = emptyUniqMap
               , le_loc     = []
               , le_ue_aliases = emptyNameEnv
               , le_platform = l_platform cfg
@@ -3428,11 +3443,11 @@ addInScopeId in_id out_ty thing_inside
      in unLintM (thing_inside out_id) env' errs
    where
 -    add env@(LE { le_in_vars = id_vars, le_joins = join_set
 +    add env@(LE { le_in_vars = id_vars, le_joins = valid_joins
                  , le_ue_aliases = aliases, le_subst = subst })
        = (out_id, env1)
        where
 -        env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' }
 +        env1 = env { le_in_vars = in_vars', le_joins = valid_joins', le_ue_aliases = aliases' }
          in_vars' = extendVarEnv id_vars in_id (in_id, out_ty)
          aliases' = delFromNameEnv aliases (idName in_id)
@@ -3446,9 +3461,9 @@ addInScopeId in_id out_ty thing_inside
          out_id | isEmptyTCvSubst subst = in_id
                 | otherwise             = setIdType in_id out_ty
 -        join_set'
 -          | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity
 -          | otherwise       = delVarSet    join_set in_id -- Remove any existing binding
 +        valid_joins'
 +          | isJoinId out_id = addToUniqMap   valid_joins in_id NormalJoinOcc -- Overwrite with new arity
 +          | otherwise       = delFromUniqMap valid_joins in_id -- Remove any existing binding
  addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a
  -- This function clones to avoid shadowing of TyCoVars
@@ -3485,13 +3500,35 @@ extendTvSubstL tv ty m
  markAllJoinsBad :: LintM a -> LintM a
  markAllJoinsBad m
 -  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs
 +  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyUniqMap }) errs
++
 +-- | Mark all join points as occurring under a tick.
 +--
 +-- See Note [Linting join points with casts or ticks].
 +markAllJoinsUnderTick :: CoreTickish -> LintM a -> LintM a
 +markAllJoinsUnderTick tick m
 +  = LintM $ \ env errs ->
 +    let env' = if tickishHasSoftScope tick || lf_allow_weak_joins (le_flags env)
 +               then env
 +               else env { le_joins = emptyUniqMap }
 +    in unLintM m env' errs
++
 +-- | Mark all join points as occurring under a cast.
 +--
 +-- See Note [Linting join points with casts or ticks].
 +markAllJoinsUnderCast :: LintM a -> LintM a
 +markAllJoinsUnderCast m
 +  = LintM $ \ env errs ->
 +    let !env' = if lf_allow_weak_joins (le_flags env)
 +                then env { le_joins = fmap (const JoinOccUnderCast) (le_joins env) }
 +                else env { le_joins = emptyUniqMap }
 +    in unLintM m env' errs
  markAllJoinsBadIf :: Bool -> LintM a -> LintM a
  markAllJoinsBadIf True  m = markAllJoinsBad m
  markAllJoinsBadIf False m = m
 -getValidJoins :: LintM IdSet
 +getValidJoins :: LintM (UniqMap Id JoinOcc)
  getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))
  getSubst :: LintM Subst
@@ -3552,14 +3589,14 @@ lintVarOcc v_occ
        | otherwise
        = return ()
 -lookupJoinId :: Id -> LintM JoinPointHood
 +lookupJoinId :: Id -> LintM (Maybe (JoinArity, JoinOcc))
  -- Look up an Id which should be a join point, valid here
  -- If so, return its arity, if not return Nothing
  lookupJoinId id
 -  = do { join_set <- getValidJoins
 -       ; case lookupVarSet join_set id of
 -            Just id' -> return (idJoinPointHood id')
 -            Nothing  -> return NotJoinPoint }
 +  = do { valid_joins <- getValidJoins
 +       ; case lookupUniqMap valid_joins id of
 +            Just join_occ -> return $ Just (idJoinArity id, join_occ)
 +            Nothing       -> return Nothing }
  addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a
  addAliasUE id ue thing_inside = LintM $ \ env errs ->

compiler/GHC/Core/Opt/Arity.hs

@@ -90,7 +90,6 @@ import GHC.Utils.Misc
  import Data.List.NonEmpty ( nonEmpty )
  import qualified Data.List.NonEmpty as NE
 -import Data.Maybe( isJust )
  {-
  ************************************************************************
@@ -2835,21 +2834,6 @@ tryEtaReduce rec_ids bndrs body eval_sd
      ok_arg _ _ _ _ = Nothing
 --- | Can we eta-reduce the given function
 --- See Note [Eta reduction soundness], criteria (B), (J), and (W).
 -cantEtaReduceFun :: Id -> Bool
 -cantEtaReduceFun fun
 -  =    hasNoBinding fun -- (B)
 -       -- Don't undersaturate functions with no binding.
+-
 -    ||  isJoinId fun    -- (J)
 -       -- Don't undersaturate join points.
 -       -- See Note [Invariants on join points] in GHC.Core, and #20599
+-
 -    || (isJust (idCbvMarks_maybe fun)) -- (W)
 -       -- Don't undersaturate StrictWorkerIds.
 -       -- See Note [CBV Function Ids: overview] in GHC.Types.Id.Info.
+-
  {- *********************************************************************
  *                                                                      *

compiler/GHC/Core/Opt/FloatIn.hs

@@ -375,7 +375,7 @@ We don't float lets inwards past an SCC.
  -}
  fiExpr platform to_drop (_, AnnTick tickish expr)
 -  | tickish `tickishScopesLike` SoftScope
 +  | tickishHasSoftScope tickish
    = Tick tickish (fiExpr platform to_drop expr)
    | otherwise -- Wimp out for now - we could push values in

compiler/GHC/Core/Opt/FloatOut.hs

@@ -365,25 +365,28 @@ floatExpr lam@(Lam (TB _ lam_spec) _)
      (add_to_stats fs floats, floats, mkLams bndrs body') }
  floatExpr (Tick tickish expr)
 -  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
 +  -- If possible, float out past the tick
 +  | let float_out_of_tick
 +          -- See Note [Floating past breakpoints]
 +          | Breakpoint{} <- tickish
 +          = True
 +          | otherwise
 +          -- We can float code out of non-scoped ticks
 +          = tickishHasNoScope tickish
 +  , float_out_of_tick
    = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
      (fs, floating_defns, Tick tickish expr') }
 -  | not (tickishCounts tickish) || tickishCanSplit tickish
 -  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
 -    let -- Annotate bindings floated outwards past an scc expression
 -        -- with the cc.  We mark that cc as "duplicated", though.
 -        annotated_defns = wrapTick (mkNoCount tickish) floating_defns
 +  -- We can't move code out of the tick
 +  | otherwise
 +  = assert (not (tickishCounts tickish) || tickishCanSplit tickish) $
 +    case (floatExpr expr)    of { (fs, floating_defns, expr') ->
 +        -- Wrap floated code with the correct tick scope, but using 'mkNoCount'
 +        -- to ensure we don't duplicate counters.
 +    let annotated_defns = wrapTick (mkNoCount tickish) floating_defns
      in
      (fs, annotated_defns, Tick tickish expr') }
 -  -- See Note [Floating past breakpoints]
 -  | Breakpoint{} <- tickish
 -  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
 -    (fs, floating_defns, Tick tickish expr') }
+-
 -  | otherwise
 -  = pprPanic "floatExpr tick" (ppr tickish)
  floatExpr (Cast expr co)
    = case (floatExpr expr) of { (fs, floating_defns, expr') ->
@@ -661,7 +664,8 @@ partitionByLevel (Level major minor) (FB tops defns)
  wrapTick :: CoreTickish -> FloatBinds -> FloatBinds
  wrapTick t (FB tops defns)
 -  = FB (mapBag wrap_bind tops)
 +  = assert (not $ tickishCounts t) $
 +    FB (mapBag wrap_bind tops)
         (M.map (M.map wrap_defns) defns)
    where
      wrap_defns = mapBag wrap_one
@@ -672,10 +676,13 @@ wrapTick t (FB tops defns)
      wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)
      wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
 -    maybe_tick e | exprIsHNF e = tickHNFArgs t e
 -                 | otherwise   = mkTick t e
 -      -- we don't need to wrap a tick around an HNF when we float it
 -      -- outside a tick: that is an invariant of the tick semantics
 +    maybe_tick
 +      -- We don't need to wrap an SCC tick around HNFs that we floated out of
 +      -- the SCC, as that is an invariant of the semantics for SCCs.
        -- Conversely, inlining of HNFs inside an SCC is allowed, and
        -- indeed the HNF we're floating here might well be inlined back
        -- again, and we don't want to end up with duplicate ticks.
 +      | tickishPlace t == PlaceCostCentre
 +      = mkTickNoHNF t
 +      | otherwise
 +      = mkTick t

compiler/GHC/Core/Opt/OccurAnal.hs

@@ -27,7 +27,7 @@ core expression with (hopefully) improved usage information.
  module GHC.Core.Opt.OccurAnal (
      occurAnalysePgm,
 -    occurAnalyseExpr,
 +    occurAnalyseExpr, occurAnalyseExpr_Prep,
      zapLambdaBndrs
    ) where
@@ -85,6 +85,15 @@ occurAnalyseExpr expr = expr'
    where
      WUD _ expr' = occAnal initOccEnv expr
 +-- | A version of 'occurAnalyseExpr' suitable for CorePrep.
 +--
 +-- Different from 'occurAnalyseExpr' due to (JCT3)
 +-- in Note [Join points, casts, and ticks] in GHC.Core.
 +occurAnalyseExpr_Prep :: CoreExpr -> CoreExpr
 +occurAnalyseExpr_Prep expr = expr'
 +  where
 +    WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr
++
  occurAnalysePgm :: Module         -- Used only in debug output
                  -> (Id -> Bool)         -- Active unfoldings
                  -> (ActivationGhc -> Bool) -- Active rules
@@ -2300,12 +2309,8 @@ occ_anal_lam_tail env (Cast expr co)
                      Var {} | isRhsEnv env -> markAllMany usage1
                      _ -> usage1
 -         -- usage3: you might think this was not necessary, because of
 -         -- the markAllNonTail in adjustTailUsage; but not so!  For a
 -         -- join point, adjustTailUsage doesn't do this; yet if there is
 -         -- a cast, we must!  Also: why markAllNonTail?  See
 -         -- GHC.Core.Lint: Note Note [Join points and casts]
 -         usage3 = markAllNonTail usage2
 +         -- usage3: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core.
 +         usage3 = markAllNonTail_CastOrTick env usage2
      in WUD usage3 (Cast expr' co)
@@ -2587,42 +2592,39 @@ But it is not necessary to gather CoVars from the types of other binders.
  -}
  occAnal env (Tick tickish body)
 -  = WUD usage' (Tick tickish body')
 +  = WUD usage2 (Tick tickish body')
    where
      WUD usage body' = occAnal env body
 -    usage'
 -      | tickish `tickishScopesLike` SoftScope
 -      = usage  -- For soft-scoped ticks (including SourceNotes) we don't want
 -               -- to lose join-point-hood, so we don't mess with `usage` (#24078)
 +    usage1
 +      -- We don't want to lose join-point-hood. We can move soft-scoped ticks
 +      -- out of the way, so don't mess with `usage` (#24078).
 +      | tickishHasSoftScope tickish
 +      = usage
 -      -- For a non-soft tick scope, we can inline lambdas only, so we
 -      -- abandon tail calls, and do markAllInsideLam too: usage_lam
 +      -- Otherwise, we can inline lambdas only, so use 'markAllInsideLam'.
 +      | otherwise
 +      = markAllNonTail_CastOrTick env $ markAllInsideLam usage
 +        -- markAllNonTail_CastOrTick: abandon tail calls.
 +        -- See (JCT2) in Note [Join points, casts, and ticks] in GHC.Core.
 +    usage2
        | Breakpoint _ _ ids <- tickish
        = -- Never substitute for any of the Ids in a Breakpoint
 -        addManyOccs usage_lam (mkVarSet ids)
 +        addManyOccs usage1 (mkVarSet ids)
        | otherwise
 -      = usage_lam
+-
 -    usage_lam = markAllNonTail (markAllInsideLam usage)
+-
 -    -- TODO There may be ways to make ticks and join points play
 -    -- nicer together, but right now there are problems:
 -    --   let j x = ... in tick<t> (j 1)
 -    -- Making j a join point may cause the simplifier to drop t
 -    -- (if the tick is put into the continuation). So we don't
 -    -- count j 1 as a tail call.
 -    -- See #14242.
 +      = usage1
  occAnal env (Cast expr co)
 -  = let  (WUD usage expr') = occAnal env expr
 -         usage1 = addManyOccs usage (coVarsOfCo co)
 -             -- usage2: see Note [Gather occurrences of coercion variables]
 -         usage2 = markAllNonTail usage1
 -             -- usage3: calls inside expr aren't tail calls any more
 -    in WUD usage2 (Cast expr' co)
 +  = let
 +      WUD usage expr' = occAnal env expr
 +      -- usage1: see Note [Gather occurrences of coercion variables]
 +      usage1 = addManyOccs usage (coVarsOfCo co)
 +      -- usage2: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core.
 +      usage2 = markAllNonTail_CastOrTick env usage1
 +    in
 +      WUD usage2 (Cast expr' co)
  occAnal env app@(App _ _)
    = occAnalApp env (collectArgsTicks tickishFloatable app)
@@ -2936,6 +2938,11 @@ data OccEnv
             , occ_rule_act   :: ActivationGhc -> Bool  -- Which rules are active
               -- See Note [Finding rule RHS free vars]
 +           , occ_allow_weak_joins :: !Bool
 +              -- ^ Allow a join point jump to occur inside casts or profiling ticks?
 +              --
 +              -- See (JCT3) in Note [Join points, casts, and ticks] in GHC.Core.Opt.
++
             -- See Note [The binder-swap substitution]
             -- If  x :-> (y, co)  is in the env,
             -- then please replace x by (y |> mco)
@@ -3003,6 +3010,8 @@ initOccEnv
             , occ_unf_act   = \_ -> True
             , occ_rule_act  = \_ -> True
 +           , occ_allow_weak_joins = False
++
             , occ_join_points = emptyVarEnv
             , occ_bs_env = emptyVarEnv
             , occ_bs_rng = emptyVarSet
@@ -3026,6 +3035,15 @@ setScrutCtxt !env alts
       -- non-default alternative.  That in turn influences
       -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!
 +-- | Mark occurrences under a cast/non-soft-scope tick as non-tail-called,
 +-- except if 'occ_allow_weak_joins = True'.
 +--
 +-- See Note [Join points, casts, and ticks] in GHC.Core.
 +markAllNonTail_CastOrTick :: OccEnv -> UsageDetails -> UsageDetails
 +markAllNonTail_CastOrTick env =
 +  markAllNonTailIf
 +    (not $ occ_allow_weak_joins env)
++
  {- Note [The OccEnv for a right hand side]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  How do we create the OccEnv for a RHS (in mkRhsOccEnv)?
@@ -4075,7 +4093,10 @@ okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool
      -- See Note [Invariants on join points]; invariants cited by number below.
      -- Invariant 2 is always satisfiable by the simplifier by eta expansion.
  okForJoinPoint lvl bndr tail_call_info
 -  | isJoinId bndr        -- A current join point should still be one!
 +  -- A current join point should still be one!
 +  --
 +  -- See Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt.
 +  | isJoinId bndr
    = warnPprTrace lost_join "Lost join point" lost_join_doc $
      True
    | valid_join

compiler/GHC/Core/Opt/Simplify/Iteration.hs

@@ -814,9 +814,9 @@ prepareRhs env top_lvl occ rhs0
          = return (emptyLetFloats, Var fun)
      anfise (Tick t rhs)
 -        -- We want to be able to float bindings past this
 -        -- tick. Non-scoping ticks don't care.
 -        | tickishScoped t == NoScope
 +        -- We want to be able to float bindings past this tick.
 +        -- Non-scoping ticks don't care.
 +        | tickishHasNoScope t
          = do { (floats, rhs') <- anfise rhs
               ; return (floats, Tick t rhs') }
@@ -1413,7 +1413,7 @@ simplTick env tickish expr cont
    -- bottom, then rebuildCall will discard the continuation.
  --------------------------
 ---  | tickishScoped tickish && not (tickishCounts tickish)
 +--  | not (tickishHasNoScope tickish) && not (tickishCounts tickish)
  --  = simplExprF env expr (TickIt tickish cont)
  -- XXX: we cannot do this, because the simplifier assumes that
  -- the context can be pushed into a case with a single branch. e.g.
@@ -1425,12 +1425,11 @@ simplTick env tickish expr cont
  -- simplifier iterations that necessary in some cases.
  --------------------------
 -  -- For unscoped or soft-scoped ticks, we are allowed to float in new
 -  -- cost, so we simply push the continuation inside the tick.  This
 -  -- has the effect of moving the tick to the outside of a case or
 -  -- application context, allowing the normal case and application
 -  -- optimisations to fire.
 -  | tickish `tickishScopesLike` SoftScope
 +  -- For soft-scoped ticks, we are allowed to float in new cost, so we simply
 +  -- push the continuation inside the tick.  This has the effect of moving the
 +  -- tick to the outside of a case or application context, allowing the normal
 +  -- 'case' and 'application' optimisations to fire.
 +  | tickishHasSoftScope tickish
    = do { (floats, expr') <- simplExprF env expr cont
         ; return (floats, mkTick tickish expr')
+        }
@@ -1459,14 +1458,14 @@ simplTick env tickish expr cont
        _other -> Nothing
     where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)
           movable t      = not (tickishCounts t) ||
 -                          t `tickishScopesLike` NoScope ||
 +                          tickishHasNoScope t ||
                            tickishCanSplit t
           tickScrut e    = foldr mkTick e ticks
           -- Alternatives get annotated with all ticks that scope in some way,
           -- but we don't want to count entries.
           tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)
           ts_scope         = map mkNoCount $
 -                            filter (not . (`tickishScopesLike` NoScope)) ticks
 +                            filter (not . tickishHasNoScope) ticks
    no_floating_past_tick =
      do { let (inc,outc) = splitCont cont
@@ -2180,16 +2179,15 @@ evaluation context E):
  As is evident from the example, there are two components to this behavior:
 -  1. When entering the RHS of a join point, copy the context inside.
 -  2. When a join point is invoked, discard the outer context.
 +  (wrapJoinCont) When entering the RHS of a join point, copy the context inside.
 +  (trimJoinCont) When a join point is invoked, discard the outer context.
  We need to be very careful here to remain consistent---neither part is
  optional!
 -We need do make the continuation E duplicable (since we are duplicating it)
 +We need to make the continuation E duplicable (since we are duplicating it)
  with mkDupableCont.
+-
  Note [Join points with -fno-case-of-case]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Supose case-of-case is switched off, and we are simplifying
@@ -2213,7 +2211,8 @@ case-of-case we may then end up with this totally bogus result
  This would be OK in the language of the paper, but not in GHC: j is no longer
  a join point.  We can only do the "push continuation into the RHS of the
  join point j" if we also push the continuation right down to the /jumps/ to
 -j, so that it can evaporate there.  If we are doing case-of-case, we'll get to
 +j, so that it can evaporate there (trimJoinCont). Then, if we are doing
 +case-of-case, we'll get to:
      join x = case <j-rhs> of <outer-alts> in
      case y of
@@ -3656,9 +3655,11 @@ addBinderUnfolding env bndr unf
    = modifyInScope env (bndr `setIdUnfolding` unf)
  zapBndrOccInfo :: Bool -> Id -> Id
 --- Consider  case e of b { (a,b) -> ... }
 --- Then if we bind b to (a,b) in "...", and b is not dead,
 --- then we must zap the deadness info on a,b
 +-- ^ Consider:
 +-- > case e of e' { (a,b) -> rhs }
 +--
 +-- We bind @e'@ to @(a,b)@ in @rhs@. If @e'@ is not dead,
 +-- then we must zap the deadness info on @a@ and @b@.
  zapBndrOccInfo keep_occ_info pat_id
    | keep_occ_info = pat_id
    | otherwise     = zapIdOccInfo pat_id

compiler/GHC/Core/SimpleOpt.hs

@@ -437,7 +437,7 @@ simple_app env e@(Lam {}) []
  simple_app env (Tick t e) as
    -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
 -  | t `tickishScopesLike` SoftScope
 +  | tickishHasSoftScope t
    = mkTick t $ simple_app env e as
  -- (let x = e in b) a1 .. an  =>  let x = e in (b a1 .. an)
@@ -1059,23 +1059,33 @@ and again its arity increases (#15517)
  -}
 --- | Returns Just (bndr,rhs) if the binding is a join point:
 --- If it's a JoinId, just return it
 --- If it's not yet a JoinId but is always tail-called,
 ---    make it into a JoinId and return it.
 +-- | Returns @Just (bndr, rhs)@ if the binding is a join point, or can be made
 +-- into a join poin. Returns @Nothing@ otherwise.
 +--
 +--   - If the input binder is a 'JoinId', just return it;
 +--   - if it's not yet a 'JoinId' but is always tail-called,
 +--     make it into a 'JoinId' and return that.
 +--
  -- In the latter case, eta-expand the RHS if necessary, to make the
 --- lambdas explicit, as is required for join points
 +-- lambdas explicit, as is required for join points.
 +--
 +-- Precondition: the 'TailCallInfo' of the 'InBndr' is conservative:
  --
 --- Precondition: the InBndr has been occurrence-analysed,
 ---               so its OccInfo is valid
 +--  - if it says 'AlwaysTailCalled', it is definitely always tail called,
 +--  - if it says 'NoTailCallInfo', then we're not sure.
 +--
 +-- See Note [JoinId vs TailCallInfo].
  joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
  joinPointBinding_maybe bndr rhs
    | not (isId bndr)
    = Nothing
 +  -- Being a JoinId is robust: preserve that. See Note [JoinId vs TailCallInfo].
    | isJoinId bndr
    = Just (bndr, rhs)
 +  -- If the 'TailCallInfo' of 'bndr' says 'AlwaysTailCalled', then we know for
 +  -- sure that it can be made into a join point.
    | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
    , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
    , let str_sig   = idDmdSig bndr
@@ -1091,6 +1101,48 @@ joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
  joinPointBindings_maybe bndrs
    = mapM (uncurry joinPointBinding_maybe) bndrs
 +{- Note [JoinId vs TailCallInfo]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +* Occurrence information is /fundamentally fragile/; that is, it may
 +  be invalidated by the Simplifier.
 +  Example 1:
 +      \y -> let x = y in ...x..x...
 +    Here `y` is marked "occurs exactly once" but, after inlining `x`,
 +    `y` now occurs many times.
 +  Example 2:
 +     f (let h x = ... in case y of { True -> h 1; False -> h 2 })
 +  Here `h` is tail-called; but if `f` is strict we could transform to
 +     let h x = ... in
 +     case y of { True -> f (h 1); False -> f (h 2) }
 +  Now `h` is not tail called any more.
++
 +  Exception: Dead things (with no occurrences) usually stay dead.
 +  There are exceptions e.g.
 +      case x of y { (a,b) -> case y of (p,q) -> p }
 +  Here `a` and `b` look dead, but we may well transform to
 +      case x of y { (a,b) -> a }
++
 +  Because occurrence info is fragile, we recompute occurrence info
 +  (including tail call info) before each run of the Simplifier.
++
 +  Whenever the simplifier performs a transformation that **might** invalidate
 +  occurrence information, it calls 'zapFragileIdInfo'. This sets the
 +  'TailCallInfo' to 'NoTailCallInfo' (among other things).
++
 +* Being a JoinId is /robust/, and is rigorously maintained by the
 +  Simplifier.  In Example 2 above, if `h` was marked as a JoinId,
 +  that transformation would not have happened.  Instead we'd have
 +  transformed to
 +     let h x = f (...) in
 +     case y of { True -> h 1; False -> h 2 }
++
 +  The Simplifier takes an Id whose occurrences are marked as
 +  `AlwaysTailCalled` and turns it into robust `JoinId`. This is
 +  done by `joinPointBinding_maybe`.
++
 +  There is one exception: float-out, the only caller of 'zapJoinId'.
 +  See Note [Zapping JoinId when floating].
 +-}
  {- *********************************************************************
  *                                                                      *

compiler/GHC/Core/Utils.hs

@@ -34,7 +34,8 @@ module GHC.Core.Utils (
          exprIsTickedString, exprIsTickedString_maybe,
          exprIsTopLevelBindable,
          exprIsUnaryClassFun, isUnaryClassId,
 -        altsAreExhaustive, etaExpansionTick,
 +        altsAreExhaustive,
 +        canCollectArgsThroughTick, cantEtaReduceFun,
          -- * Equality
          cheapEqExpr, cheapEqExpr', diffBinds,
@@ -680,7 +681,7 @@ mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
  mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    | Just (joins, inner_alts) <- go deflt_rhs
    , Just aux_binds <- mk_aux_binds joins
 -  = Just ( aux_binds ++ joins, mergeAlts outer_alts inner_alts )
 +  = Just (aux_binds ++ joins, mergeAlts outer_alts inner_alts )
                  -- NB: mergeAlts gives priority to the left
                  --      case x of
                  --        A -> e1
@@ -727,7 +728,7 @@ mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
        , Just tc  <- tyConAppTyCon_maybe type_arg
        , Just (dc1:dcs) <- tyConDataCons_maybe tc   -- At least one data constructor
        , dcs `lengthAtMost` 3  -- Arbitrary
 -      = return ( [], mk_alts dc1 dcs)
 +      = return ([], mk_alts dc1 dcs)
        where
          mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc
          mk_rhs dc = Var (dataConWorkId dc)
@@ -748,11 +749,16 @@ mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
        | otherwise
        = Nothing
 -    -- We don't want ticks to get in the way; just push them inwards.
 -    -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#)
 +    -- Push ticks **inwards** (when possible).
 +    -- See (MC5) in Note [Merge Nested Cases].
      go (Tick t body)
 -      = do { (joins, alts) <- go body
 -           ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) }
 +      = do { (joins, alts) <- go body -- (MC4): any join points inside are floated out of the tick.
++
 +             -- Abort if this would put a non-soft-scope tick in between
 +             -- a join point binding and its jumps. See (MC6).
 +           ; guard $ null joins || tickishHasSoftScope t
 +           ; return (joins, [Alt con bs (mkTick t rhs) | Alt con bs rhs <- alts])
 +           }
      go _ = Nothing
@@ -974,12 +980,74 @@ Wrinkles
        So `mergeCaseAlts` floats out any join points. It doesn't float out
        non-join-points unless the /outer/ case has just one alternative; doing
 -      so would risk more allocation
 +      so would risk more allocation.
++
 +      Note also that `mergeCaseAlts` floats join points out of ticks, for which
 +      we need to be extra careful; see (MC6).
        Floating out join points isn't entirely straightforward.
        See Note [Floating join points out of DEFAULT alternatives]
 -(MC5) See Note [Cascading case merge]
 +(MC5) We want to move ticks out of the way if possible, to prevent them from
 +      inhibiting optimisation. For example, say we have:
++
 +        case expensive of r {
 +          C1 -> rhs1; -- happy path
 +          _  -> scctick<doEdgeCase> (case r of { C2 -> rhs2; C3 -> rhs3 })
 +        }
++
 +      In this situation, we push the "doEdgeCase" tick **inwards** and proceed
 +      to merge cases, like so:
++
 +        case expensive of
 +          C1 -> rhs1
 +          C2 -> scctick<doEdgeCase> rhs2
 +          C3 -> scctick<doEdgeCase> rhs3
++
 +      This preserves the tick semantics (see Note [Scoping ticks and counting ticks]
 +      in GHC.Types.Tickish), because this transformation:
++
 +        1. preserves counts,
 +        2. does not move cost in or out of the tick scope.
++
 +      (1) is clear: we will tick 'doEdgeCase' exactly in the C2/C3 alternatives,
 +      and we won't otherwise.
 +      For (2), recall that case is strict in Core. We already evaluated 'expensive',
 +      so re-scrutinising 'r' is free.
++
 +      This means that, perhaps surprisingly, this transformation is valid for
 +      **all** ticks, including non-floatable ones.
++
 +      In contrast, we would not want to move the tick outwards, because this:
++
 +        - will lead to additional counting of 'doEdgeCase' in the 'C1' (happy path) case,
 +        - risks attributing the cost of evaluating 'expensive' to 'doEdgeCase'.
++
 +(MC6) There is a dangerous interaction between (MC4) and (MC5), which can lead
 +      to invalid Core (as reported in #26642, #26929). Suppose we have:
++
 +        case f x of r ->
 +          scctick<foo>
 +            join j y = rhs in
 +            case r of { C1 -> j 1; C2 -> bar }
++
 +      If we naively carried out (MC4) and (MC5) together, this would result in:
++
 +        join j y = rhs in
 +          case f x of
 +            C1 -> scctick<foo> (j 1)
 +            C2 -> scctick<foo> bar
++
 +      This has moved the tick in between the join point binding 'j' and the
 +      join point jump, which is invalid as per Note [Join points, casts, and ticks]
 +      in GHC.Core. The simplifier cannot deal with such Core, resulting in #26642.
++
 +      The solution: abort whenever we would position a non-soft-scope tick
 +      inside a join point in this manner.
 +      An alternative would be to float the tick outwards, but as we saw in (MC5)
 +      this risks a grave misattribution of profiling costs, so we don't do that.
++
 +(MC7) See Note [Cascading case merge]
  See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils
@@ -2076,14 +2144,31 @@ altsAreExhaustive (Alt con1 _ _ : alts)
        -- we behave conservatively here -- I don't think it's important
        -- enough to deserve special treatment
 --- | Should we look past this tick when eta-expanding the given function?
 +-- | Should we look past this tick when collecting arguments
 +-- for the given function?
  --
  -- See Note [Ticks and mandatory eta expansion]
 --- Takes the function we are applying as argument.
 -etaExpansionTick :: Id -> GenTickish pass -> Bool
 -etaExpansionTick id t
 -  = hasNoBinding id &&
 -    ( tickishFloatable t || isProfTick t )
 +canCollectArgsThroughTick
 +  :: Id -- ^ function at the head of the application
 +  -> GenTickish pass -- ^ tick we want to collect arguments past
 +  -> Bool
 +canCollectArgsThroughTick id t
 +  = tickishFloatable t || cantEtaReduceFun id
++
 +-- | Can we eta-reduce the given function?
 +-- See Note [Eta reduction soundness], criteria (B), (J), and (W).
 +cantEtaReduceFun :: Id -> Bool
 +cantEtaReduceFun fun
 +  =    hasNoBinding fun -- (B)
 +       -- Don't undersaturate functions with no binding.
++
 +    || isJoinId fun    -- (J)
 +       -- Don't undersaturate join points.
 +       -- See Note [Invariants on join points] in GHC.Core, and #20599
++
 +    || isJust (idCbvMarks_maybe fun) -- (W)
 +       -- Don't undersaturate StrictWorkerIds.
 +       -- See Note [CBV Function Ids: overview] in GHC.Types.Id.Info.
  {- Note [exprOkForSpeculation and type classes]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/GHC/CoreToStg/Prep.hs

@@ -39,7 +39,8 @@ import GHC.Core.Type
  import GHC.Core.Coercion
  import GHC.Core.TyCon
  import GHC.Core.DataCon
 -import GHC.Core.Opt.OccurAnal
 +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr_Prep )
 +import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe )
  import GHC.Data.Maybe
  import GHC.Data.OrdList
@@ -575,7 +576,18 @@ cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
                     Maybe CoreBind) -- Just bind' <=> returned new bind; no float
                                     -- Nothing <=> added bind' to floats instead
  cpeBind top_lvl env (NonRec bndr rhs)
 -  | not (isJoinId bndr)
 +  -- A join point.
 +  -- NB: use 'joinPointBinding_maybe' instead of 'isJoinId' as per the plan
 +  -- described in (JCT3) in Note [Join points, casts, and ticks].
 +  | Just (bndr, rhs) <- joinPointBinding_maybe bndr rhs
 +  = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point; see Note [Join points and floating]
 +    do { (_, bndr1) <- cpCloneBndr env bndr
 +       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
 +       ; return (extendCorePrepEnv env bndr bndr2,
 +                 emptyFloats,
 +                 Just (NonRec bndr2 rhs1)) }
++
 +  | otherwise
    = do { (env1, bndr1) <- cpCloneBndr env bndr
         ; let dmd = idDemandInfo bndr
               lev = typeLevity (idType bndr)
@@ -594,16 +606,23 @@ cpeBind top_lvl env (NonRec bndr rhs)
         ; return (env2, floats1, Nothing) }
 -  | otherwise -- A join point; see Note [Join points and floating]
 -  = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point
 -    do { (_, bndr1) <- cpCloneBndr env bndr
 -       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
 -       ; return (extendCorePrepEnv env bndr bndr2,
 -                 emptyFloats,
 -                 Just (NonRec bndr2 rhs1)) }
+-
  cpeBind top_lvl env (Rec pairs)
 -  | not (isJoinId (head bndrs))
 +  -- A recursive join point.
 +  -- NB: use 'joinPointBindings_maybe' instead of 'isJoinId' as per the plan
 +  -- described in (JCT3) in Note [Join points, casts, and ticks].
 +  | Just pairs <- joinPointBindings_maybe pairs
 +  , let (bndrs, rhss) = unzip pairs
 +  = do { (env, bndrs1) <- cpCloneBndrs env bndrs
 +       ; let env' = enterRecGroupRHSs env bndrs1
 +       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
++
 +       ; let bndrs2 = map fst pairs1
 +       -- use env below, so that we reset cpe_rec_ids
 +       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
 +                 emptyFloats,
 +                 Just (Rec pairs1)) }
 +  | otherwise
 +  , let (bndrs, rhss) = unzip pairs
    = do { (env, bndrs1) <- cpCloneBndrs env bndrs
         ; let env' = enterRecGroupRHSs env bndrs1
         ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env')
@@ -626,19 +645,9 @@ cpeBind top_lvl env (Rec pairs)
                             (Float (Rec all_pairs) LetBound TopLvlFloatable),
                   Nothing) }
 -  | otherwise -- See Note [Join points and floating]
 -  = do { (env, bndrs1) <- cpCloneBndrs env bndrs
 -       ; let env' = enterRecGroupRHSs env bndrs1
 -       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
+-
 -       ; let bndrs2 = map fst pairs1
 -       -- use env below, so that we reset cpe_rec_ids
 -       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
 -                 emptyFloats,
 -                 Just (Rec pairs1)) }
    where
 -    (bndrs, rhss) = unzip pairs
+-
 +    -- See Note [Join points and floating]
 +    --
      -- Flatten all the floats, and the current
      -- group into a single giant Rec
      add_float (Float bind bound _) prs2
@@ -653,7 +662,6 @@ cpeBind top_lvl env (Rec pairs)
            Rec prs1 -> prs1 ++ prs2
      add_float f _ = pprPanic "cpeBind" (ppr f)
+-
  ---------------
  cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
          -> CorePrepEnv -> OutId -> CoreExpr
@@ -661,7 +669,7 @@ cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
  -- Used for all bindings
  -- The binder is already cloned, hence an OutId
  cpePair top_lvl is_rec dmd lev env0 bndr rhs
 -  = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair
 +  = assert (isNothing $ joinPointBinding_maybe bndr rhs) $ -- those should use cpeJoinPair
      do { (floats1, rhs1) <- cpeRhsE env rhs
         -- See if we are allowed to float this stuff out of the RHS
@@ -926,7 +934,7 @@ rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)
  -- Remove top level lambdas by let-binding
  rhsToBody env (Tick t expr)
 -  | tickishScoped t == NoScope  -- only float out of non-scoped annotations
 +  | tickishHasNoScope t -- only float out of non-scoped annotations
    = do { (floats, expr') <- rhsToBody env expr
         ; return (floats, mkTick t expr') }
@@ -984,43 +992,74 @@ instance Outputable ArgInfo where
  {- Note [Ticks and mandatory eta expansion]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -Something like
 -    `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`
 -caused a compiler panic in #20938. Why did this happen?
 -The simplifier will eta-reduce the rhs giving us a partial
 -application of tagToEnum#. The tick is then pushed inside the
 -type argument. That is we get
 -    `(Tick<foo> tagToEnum#) @Bool`
 +We must look through ticks when they get in the way of seeing the arguments to
 +'Id's that cannot be eta-reduced.
++
 +For example, we may have
++
 +  myReallyUnsafePtrEquality
 +      = \ @a x y ->
 +          (src<loc> reallyUnsafePtrEquality#)
 +            @Lifted @a @Lifted @a x y
++
 +If we don't move the SourceNote out of the way, this looks like an unsaturated
 +occurrence of the PrimOp "reallyUnsafePtrEquality#", which we cannot generate
 +code for.
++
 +Moreover, we must also move out non-floatable ticks. Case in point: #20938,
 +of the form:
++
 +    foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool
++
 +If we don't look past the tick "foo", the simplifier will eta-reduce the RHS,
 +giving us a partial application of 'tagToEnum#'. The tick is then pushed inside
 +the type argument, resulting in:
++
 +    (Tick<foo> tagToEnum#) @Bool
++
  CorePrep would go on to see a undersaturated tagToEnum# application
 -and eta expand the expression under the tick. Giving us:
 +and eta-expand the expression under the tick. Giving us:
++
      (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool
 -Suddenly tagToEnum# is applied to a polymorphic type and the code generator
++
 +Suddenly, 'tagToEnum#' is applied to a polymorphic type and the code generator
  panics as it needs a concrete type to determine the representation.
 -The problem in my eyes was that the tick covers a partial application
 -of a primop. There is no clear semantic for such a construct as we can't
 -partially apply a primop since they do not have bindings.
 -We fix this by expanding the scope of such ticks slightly to cover the body
 -of the eta-expanded expression.
+-
 -We do this by:
 -* Checking if an application is headed by a primOpish thing.
 -* If so we collect floatable ticks and usually but also profiling ticks
 -  along with regular arguments.
 -* When rebuilding the application we check if any profiling ticks appear
 -  before the primop is fully saturated.
 -* If the primop isn't fully satured we eta expand the primop application
 -  and scope the tick to scope over the body of the saturated expression.
+-
 -Going back to #20938 this means starting with
 -    `(Tick<foo> tagToEnum#) @Bool`
 -we check if the function head is a primop (yes). This means we collect the
 -profiling tick like if it was floatable. Giving us
 -    (tagToEnum#, [CpeTick foo, CpeApp @Bool]).
 +The problem was that the tick covered a partial application of a primop.
 +There is no clear semantic for such a construct: we can't partially apply a
 +primop, since primops do not have bindings.
++
 +To fix this, we expand the scope of ticks slightly to cover the body
 +of the eta-expanded expression, even when the tick isn't normally floatable.
++
 +This is achieved by using 'GHC.Core.Utils.canCollectArgsThroughTick', which
 +responds 'True' in the following two situations:
++
 +  - The tick is floatable (i.e. satisfies 'tickishFloatable'), meaning that it
 +    is OK to float it out slightly, moving in more code under it.
 +    See also Note [Eta expansion and source notes] in GHC.Core.Opt.Arity.
 +  - The tick is around an application that is headed by an 'Id' that cannot be
 +    undersaturated, such as a PrimOp (see 'GHC.Core.Utils.cantEtaReduceFun').
++
 +This solves #20938. Indeed, starting with
++
 +    (scctick<foo> tagToEnum#) @Bool
++
 +we see that the head of the application is 'tagToEnum#', which is a PrimOp and
 +thus satisfies 'hasNoBinding = True'. As a result, we collect the profiling tick
 +as if it was floatable, resulting in
++
 +    (tagToEnum#, [CpeTick foo, CpeApp @Bool])
++
  cpe_app filters out the tick as a underscoped tick on the expression
 -`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the
 -body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
 +`tagToEnum# @Bool`. During eta-expansion, we put that tick back onto the
 +body of the eta-expansion lambda, resulting in
++
 +  \x -> scctick<foo> (tagToEnum# @Bool x)
++
 +which is unproblematic.
  -}
++
  cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
  -- May return a CpeRhs (instead of CpeApp) because of saturating primops
  cpeApp top_env expr
@@ -1045,15 +1084,14 @@ cpeApp top_env expr
          go (Cast fun co)      as
              = go fun (AICast co : as)
          go (Tick tickish fun) as
 -            -- Profiling ticks are slightly less strict so we expand their scope
 -            -- if they cover partial applications of things like primOps.
 -            -- See Note [Ticks and mandatory eta expansion]
 -            -- Here we look inside `fun` before we make the final decision about
 -            -- floating the tick which isn't optimal for perf. But this only makes
 -            -- a difference if we have a non-floatable tick which is somewhat rare.
 +            -- Try to move a tick out of the way, if:
 +            --   - the tick can be floated out of the way ('tickishFloatable'), or
 +            --   - the tick must be moved out of the way because it stands in between
 +            --     an 'Id' that must be saturated and some of its arguments;
 +            --     see Note [Ticks and mandatory eta expansion].
              | Var vh <- head
 -            , Var head' <- lookupCorePrepEnv top_env vh
 -            , etaExpansionTick head' tickish
 +            , Just head' <- getIdFromTrivialExpr_maybe (lookupCorePrepEnv top_env vh)
 +            , canCollectArgsThroughTick head' tickish
              = (head,as')
              where
                (head,as') = go fun (AITick tickish : as)
@@ -1130,7 +1168,10 @@ cpeApp top_env expr
                   hd = getIdFromTrivialExpr_maybe e2
                   -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
                   min_arity = case hd of
 -                   Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing
 +                   Just v_hd ->
 +                     if cantEtaReduceFun v_hd
 +                     then Just $! idArity v_hd
 +                     else Nothing
                     Nothing -> Nothing
            --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))
             ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
@@ -2293,8 +2334,8 @@ deFloatTop floats
      get b _  = pprPanic "deFloatTop" (ppr b)
      -- See Note [Dead code in CorePrep]
 -    get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)
 -    get_bind (Rec xes)    = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
 +    get_bind (NonRec x e) = NonRec x (occurAnalyseExpr_Prep e)
 +    get_bind (Rec xes)    = Rec [(x, occurAnalyseExpr_Prep e) | (x, e) <- xes]
  ---------------------------------------------------------------------------

compiler/GHC/Driver/Config/Core/Lint.hs

@@ -115,7 +115,8 @@ perPassFlags dflags pass
                 , lf_check_inline_loop_breakers = check_lbs
                 , lf_check_static_ptrs          = check_static_ptrs
                 , lf_check_linearity            = check_linearity
 -               , lf_check_rubbish_lits         = check_rubbish }
 +               , lf_check_rubbish_lits         = check_rubbish
 +               , lf_allow_weak_joins           = allow_weak_joins }
    where
      -- See Note [Checking for global Ids]
      check_globals = case pass of
@@ -152,6 +153,11 @@ perPassFlags dflags pass
                        CorePrep -> True
                        _        -> False
 +    -- See Note [Linting join points with casts or ticks] in GHC.Core.Lint
 +    allow_weak_joins = case pass of
 +                      CorePrep -> True
 +                      _        -> False
++
  initLintConfig :: DynFlags -> [Var] -> LintConfig
  initLintConfig dflags vars =LintConfig
    { l_diagOpts = initDiagOpts dflags
@@ -168,4 +174,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False
                               , lf_report_unsat_syns = True
                               , lf_check_fixed_rep = True
                               , lf_check_rubbish_lits = True
 +                             , lf_allow_weak_joins = False
+                              }

compiler/GHC/Iface/Tidy.hs

@@ -1272,7 +1272,7 @@ tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
      is_external = isExternalName name
      --------- OccInfo ------------
 -    robust_occ_info = zapFragileOcc (occInfo idinfo)
 +    robust_occ_info = zapFragileOccInfo (occInfo idinfo)
      -- It's important to keep loop-breaker information
      -- when we are doing -fexpose-all-unfoldings

compiler/GHC/StgToCmm/Expr.hs

@@ -1273,5 +1273,5 @@ cgTick tick
             ProfNote   cc t p -> emitSetCCC cc t p
             HpcTick    m n    -> emit (mkTickBox platform m n)
             SourceNote s n    -> emitTick $ SourceNote s n
 -           _other            -> return () -- ignore
 +           Breakpoint {}     -> return () -- ignore
+        }

compiler/GHC/Types/Basic.hs

@@ -66,7 +66,7 @@ module GHC.Types.Basic (
          noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
          bestOneShot, worstOneShot,
 -        OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
 +        OccInfo(..), noOccInfo, seqOccInfo, zapFragileOccInfo, isOneOcc,
          isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
          isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
@@ -980,10 +980,13 @@ isOneOcc :: OccInfo -> Bool
  isOneOcc (OneOcc {}) = True
  isOneOcc _           = False
 -zapFragileOcc :: OccInfo -> OccInfo
 --- Keep only the most robust data: deadness, loop-breaker-hood
 -zapFragileOcc (OneOcc {}) = noOccInfo
 -zapFragileOcc occ         = zapOccTailCallInfo occ
 +-- | Keep only the most robust occurrence info: deadness, loop-breaker-hood.
 +--
 +-- In particular, it zaps 'TailCallInfo': see Note [JoinId vs TailCallInfo]
 +-- in 'GHC.Core.Opt.Simplify.Env'.
 +zapFragileOccInfo :: OccInfo -> OccInfo
 +zapFragileOccInfo (OneOcc {}) = noOccInfo
 +zapFragileOccInfo occ         = zapOccTailCallInfo occ
  instance Outputable OccInfo where
    -- only used for debugging; never parsed.  KSW 1999-07

compiler/GHC/Types/Id/Info.hs

@@ -914,14 +914,15 @@ zapUsedOnceInfo info
                    , demandInfo     = zapUsedOnceDemand (demandInfo     info) }
  zapFragileInfo :: IdInfo -> Maybe IdInfo
 --- ^ Zap info that depends on free variables
 +-- ^ Zap fragile 'IdInfo', such as info that depends on free variables
 +-- or fragile occurrence info (see 'zapFragileOccInfo').
  zapFragileInfo info@(IdInfo { occInfo = occ, realUnfoldingInfo = unf })
    = new_unf `seq`  -- The unfolding field is not (currently) strict, so we
                     -- force it here to avoid a (zapFragileUnfolding unf) thunk
                     -- which might leak space
      Just (info `setRuleInfo` emptyRuleInfo
                 `setUnfoldingInfo` new_unf
 -               `setOccInfo`       zapFragileOcc occ)
 +               `setOccInfo`       zapFragileOccInfo occ)
    where
      new_unf = zapFragileUnfolding unf

compiler/GHC/Types/Tickish.hs

@@ -6,9 +6,8 @@ module GHC.Types.Tickish (
    CoreTickish, StgTickish, CmmTickish,
    XTickishId,
    tickishCounts,
 -  TickishScoping(..),
 -  tickishScoped,
 -  tickishScopesLike,
 +  tickishHasNoScope,
 +  tickishHasSoftScope,
    tickishFloatable,
    tickishCanSplit,
    mkNoCount,
@@ -206,103 +205,177 @@ instance Binary BreakpointId where
  --------------------------------------------------------------------------------
 --- | A "counting tick" (where tickishCounts is True) is one that
 +-- | A "counting tick" (for which 'tickishCounts' is True) is one that
  -- counts evaluations in some way.  We cannot discard a counting tick,
 --- and the compiler should preserve the number of counting ticks as
 +-- and the compiler should preserve the number of counting ticks (as
 +-- far as possible).
  --
 ---
 --- However, we still allow the simplifier to increase or decrease
 --- sharing, so in practice the actual number of ticks may vary, except
 +-- See Note [Counting ticks]
  tickishCounts :: GenTickish pass -> Bool
 -tickishCounts :: GenTickish pass -> Bool
 -tickishCounts n@ProfNote{} = profNoteCount n
 -tickishCounts HpcTick{}    = True
 -tickishCounts Breakpoint{} = True
 -tickishCounts _            = False
+-
+-
 --- | Specifies the scoping behaviour of ticks. This governs the
 --- behaviour of ticks that care about the covered code and the cost
 --- associated with it. Important for ticks relating to profiling.
 -data TickishScoping =
 -    -- | No scoping: The tick does not care about what code it
 -    -- covers. Transformations can freely move code inside as well as
 -    -- outside without any additional annotation obligations
 -    NoScope
+-
 -    -- | Soft scoping: We want all code that is covered to stay
 -    -- covered.  Note that this scope type does not forbid
 -    -- transformations from happening, as long as all results of
 -    -- the transformations are still covered by this tick or a copy of
 -    -- it. For example
 -    --
 -    --   let x = tick<...> (let y = foo in bar) in baz
 -    --     ===>
 -    --   let x = tick<...> bar; y = tick<...> foo in baz
 -    --
 -    -- Is a valid transformation as far as "bar" and "foo" is
 -    -- concerned, because both still are scoped over by the tick.
 -    --
 -    -- Note though that one might object to the "let" not being
 -    -- covered by the tick any more. However, we are generally lax
 -    -- with this - constant costs don't matter too much, and given
 -    -- that the "let" was effectively merged we can view it as having
 -    -- lost its identity anyway.
 -    --
 -    -- Also note that this scoping behaviour allows floating a tick
 -    -- "upwards" in pretty much any situation. For example:
 -    --
 -    --   case foo of x -> tick<...> bar
 -    --     ==>
 -    --   tick<...> case foo of x -> bar
 -    --
 -    -- While this is always legal, we want to make a best effort to
 -    -- only make us of this where it exposes transformation
 -    -- opportunities.
 -  | SoftScope
+-
 -    -- | Cost centre scoping: We don't want any costs to move to other
 -    -- cost-centre stacks. This means we not only want no code or cost
 -    -- to get moved out of their cost centres, but we also object to
 -    -- code getting associated with new cost-centre ticks - or
 -    -- changing the order in which they get applied.
 -    --
 -    -- A rule of thumb is that we don't want any code to gain new
 -    -- annotations. However, there are notable exceptions, for
 -    -- example:
 -    --
 -    --   let f = \y -> foo in tick<...> ... (f x) ...
 -    --     ==>
 -    --   tick<...> ... foo[x/y] ...
 -    --
 -    -- In-lining lambdas like this is always legal, because inlining a
 -    -- function does not change the cost-centre stack when the
 -    -- function is called.
 -  | CostCentreScope
+-
 -  deriving (Eq)
+-
 --- | Returns the intended scoping rule for a Tickish
 -tickishScoped :: GenTickish pass -> TickishScoping
 -tickishScoped n@ProfNote{}
 -  | profNoteScope n        = CostCentreScope
 -  | otherwise              = NoScope
 -tickishScoped HpcTick{}    = NoScope
 -tickishScoped Breakpoint{} = CostCentreScope
 -   -- Breakpoints are scoped: eventually we're going to do call
 -   -- stacks, but also this helps prevent the simplifier from moving
 -   -- breakpoints around and changing their result type (see #1531).
 -tickishScoped SourceNote{} = SoftScope
+-
 --- | Returns whether the tick scoping rule is at least as permissive
 --- as the given scoping rule.
 -tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool
 -tickishScopesLike t scope = tickishScoped t `like` scope
 -  where NoScope         `like` _               = True
 -        _               `like` NoScope         = False
 -        SoftScope       `like` _               = True
 -        _               `like` SoftScope       = False
 +tickishCounts = \case
 +  ProfNote { profNoteCount = counts } -> counts
 +  HpcTick {}                          -> True
 +  Breakpoint {}                       -> True
 +  SourceNote {}                       -> False
++
 +-- | Is this a non-scoping tick, for which we don't care about precisely
 +-- the extent of code that the tick encompasses?
 +--
 +-- See Note [Scoped ticks]
 +tickishHasNoScope :: GenTickish pass -> Bool
 +tickishHasNoScope = \case
 +  ProfNote { profNoteScope = scopes } -> not scopes
 +  HpcTick {}                          -> True
 +  Breakpoint {}                       -> False
 +  SourceNote {}                       -> False
++
 +-- | A "tick with soft scoping" (for which 'tickishHasSoftScope' is True) is
 +-- one that either does not scope at all (for which 'tickishHasNoScope' is True),
 +-- or that has a "soft" scope: we allow new code to be floated into to the scope,
 +-- as long as all code that was covered remains covered.
 +--
 +-- See Note [Scoped ticks]
 +tickishHasSoftScope :: GenTickish pass -> Bool
 +tickishHasSoftScope = \case
 +  ProfNote { profNoteScope = scopes } -> not scopes
 +  HpcTick {}                          -> True
 +  Breakpoint {}                       -> False
 +  SourceNote {}                       -> True
++
 +{- Note [Scoping ticks and counting ticks]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +Ticks have two independent attributes:
++
 +  * Whether the tick /counts/.
 +    Counting ticks are used when we want a counter to be bumped, e.g. counting
 +    how many times a function is called.
++
 +    See Note [Counting ticks]
++
 +  * What kind of /scope/ the tick has:
 +     * Cost-centre scope: you cannot move a redex into the scope of the tick,
 +                          nor can you float a redex out.
 +     * Soft scope: you can move a redex /into/ the scope of a tick,
 +                   but you cannot float a redex /out/
 +     * No scope: there are no restrictions on floating in or out.
++
 +     See Note [Scoped ticks]
++
 +Note [Counting ticks]
 +~~~~~~~~~~~~~~~~~~~~
 +The following ticks count:
 +  - ProfNote ticks with profNoteCounts = True
 +  - HPC ticks
 +  - Breakpoints
++
 +Going past a counting tick implies bumping a counter.
 +Generally, the simplifier attempts to preserve counts when transforming
 +programs and moving ticks, for example by transforming:
++
 +  case <tick> e of
 +    alt1 -> rhs1
 +    alt2 -> rhs2
++
 +to
++
 +  case e of
 +    alt1 -> <tick> rhs1
 +    alt2 -> <tick> rhs2
++
 +which preserves the total count (as exactly one branch of the case
 +will be taken).
++
 +However, we still allow the simplifier to increase or decrease
 +sharing, so in practice the actual number of ticks may vary, except
 +that we never change the value from zero to non-zero or vice-versa.
++
 +Note [Scoped ticks]
 +~~~~~~~~~~~~~~~~~~~~
 +The following ticks are scoped:
 +  - ProfNote ticks with profNoteScope = True
 +  - Breakpoints
 +  - Source notes
++
 +A scoped tick is one that scopes over a portion of code. For example,
 +an SCC anotation sets the cost centre for the code within; any allocations
 +within that piece of code should get attributed to that cost centre.
++
 +When the simplifier deals with a scoping tick, it ensures that all code that
 +was covered remains covered. For example
++
 +  let x = tick<...> (let y = foo in bar) in baz
 +    ===>
 +  let x = tick<...> bar; y = tick<...> foo in baz
++
 +is a valid transformation as far as "bar" and "foo" are concerned, because
 +both still are scoped over by the tick. One might object to the "let" not
 +being covered by the tick any more. However, we are generally lax with this;
 +constant costs don't matter too much, and given that the "let" was effectively
 +merged we can view it as having lost its identity anyway.
++
 +Perhaps surprisingly, breakpoints are considered to be scoped, because we
 +don't want the simplifier to move them around, changing their result type (see #1531).
++
 +We specifically forbid floating code outside of a scoping tick, as cost
 +associated with the floated-out code would no longer be attributed to the
 +appropriate scope.
++
 +Whether we are allowed to float in additional cost depends on the tick:
++
 +  Cost-centre scope ticks
 +    - ProfNote with profNoteScope = True
 +    - Breakpoints
++
 +    A tick with cost-centre scope is one for which we can neither move
 +    redexes into or move redexes outside of the tick. For example, we don't
 +    want profiling costs to move to other cost-centre stacks.
 +    Morever, we also object to changing the order in which such ticks
 +    are applied.
++
 +    A rule of thumb is that we don't want any code to gain new
 +    lexically-enclosing ticks. For example, we should not transform:
++
 +      f (scctick<foo> a)  ==>  scctick<foo> (f a)
++
 +    as this would attribute the cost of evaluating the application 'f a'
 +    to the cost centre 'foo'.
++
 +    However, there are notable exceptions, for example:
++
 +      let f = \y -> foo in tick<...> ... (f x) ...
 +        ==>
 +      tick<...> ... foo[x/y] ...
++
 +    Inlining lambdas like this is always legal, because inlining a function
 +    does not change the cost-centre stack when the function is called.
++
 +  Soft scope ticks
 +    - Source notes
++
 +    A tick with soft scope is one for which we can move redexes inside the
 +    tick, but cannot float redexes outside the tick. This is a slightly more
 +    lenient notion of scoping than cost-centres, and is used only for source
 +    note ticks (they are used to provide DWARF debug symbols, and for those
 +    it matters less if code from outside gets moved under the tick).
++
 +    Examples:
++
 +      - FloatIn (GHC.Core.Opt.FloatIn.fiExpr)
++
 +          let x = rhs in <tick> body
 +            ==>
 +          <tick> (let x = rhs in body)
++
 +      - Moving a tick outside of a case or of an application
 +        (GHC.Core.Opt.Simplify.Iteration.simplTick)
++
 +          case <tick> e of alts  ==>  <tick> case e of alts
++
 +          (<tick> e1) e2         ==>  <tick> (e1 e2)
++
 +    While these transformations are legal, we want to make a best effort to
 +    only make use of them where it exposes transformation opportunities.
 +-}
  -- | Returns @True@ for ticks that can be floated upwards easily even
  -- where it might change execution counts, such as:
@@ -311,12 +384,11 @@ tickishScopesLike t scope = tickishScoped t `like` scope
  --     ==>
  --   tick<...> (Just foo)
  --
 --- This is a combination of @tickishSoftScope@ and
 --- @tickishCounts@. Note that in principle splittable ticks can become
 --- floatable using @mkNoTick@ -- even though there's currently no
 --- tickish for which that is the case.
 +-- This is a combination of @tickishHasSoftScope@ and @tickishCounts@.
 +-- Note that in principle splittable ticks can become floatable using @mkNoTick@,
 +-- even though there's currently no tickish for which that is the case.
  tickishFloatable :: GenTickish pass -> Bool
 -tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)
 +tickishFloatable t = tickishHasSoftScope t && not (tickishCounts t)
  -- | Returns @True@ for a tick that is both counting /and/ scoping and
  -- can be split into its (tick, scope) parts using 'mkNoScope' and
@@ -334,7 +406,7 @@ mkNoCount n@ProfNote{}                = let n' = n {profNoteCount = False}
  mkNoCount _                           = panic "mkNoCount: Undefined split!"
  mkNoScope :: GenTickish pass -> GenTickish pass
 -mkNoScope n | tickishScoped n == NoScope  = n
 +mkNoScope n | tickishHasNoScope n         = n
              | not (tickishCanSplit n)     = panic "mkNoScope: Cannot split!"
  mkNoScope n@ProfNote{}                    = let n' = n {profNoteScope = False}
                                              in assert (profNoteCount n) n'
@@ -357,7 +429,9 @@ mkNoScope _                               = panic "mkNoScope: Undefined split!"
  -- translate the code as if it found the latter.
  tickishIsCode :: GenTickish pass -> Bool
  tickishIsCode SourceNote{} = False
 -tickishIsCode _tickish     = True  -- all the rest for now
 +tickishIsCode ProfNote{}   = True
 +tickishIsCode Breakpoint{} = True
 +tickishIsCode HpcTick{}    = True
  isProfTick :: GenTickish pass -> Bool
  isProfTick ProfNote{} = True

testsuite/tests/codeGen/should_compile/debug.stdout

@@ -18,7 +18,6 @@ src<debug.hs:4:9>
  src<debug.hs:5:21-29>
  src<debug.hs:5:9-29>
  src<debug.hs:6:1-21>
 -src<debug.hs:6:16-21>
  == CBE ==
  src<debug.hs:4:9>

testsuite/tests/simplCore/should_compile/T26642.hs

 +module T26642 ( saveClobberedTemps ) where
++
 +import Prelude   ( IO, Bool(..), Int, (>>=), (==), return )
 +import Data.Word ( Word64 )
++
 +-------------------------------------------------------------------------------
++
 +data Word64Map a
 +  = Bin (Word64Map a) (Word64Map a)
 +  | Tip a
 +  | Nil
++
 +{-# NOINLINE myFoldr #-}
 +myFoldr :: (a -> b -> b) -> b -> Word64Map a -> b
 +myFoldr f = go
 +  where
 +    {-# NOINLINE go #-}
 +    go z' Nil       = z'
 +    go z' (Tip x)   = f x z'
 +    go z' (Bin l r) = go (go z' r) l
++
 +{-# NOINLINE nonDetFold #-}
 +nonDetFold :: (b -> elt -> IO b) -> b -> Word64Map elt -> IO b
 +nonDetFold f z0 xs = myFoldr c return xs z0
 +  where
 +    {-# NOINLINE c #-}
 +    c x k z = f z x >>= k
++
 +{-# NOINLINE myFalse #-}
 +myFalse :: Bool
 +myFalse = False
++
 +type RealReg = Int
 +data Loc = InReg RealReg | InMem
++
 +saveClobberedTemps :: forall instr. [RealReg] -> IO [instr]
 +saveClobberedTemps clobbered = nonDetFold maybe_spill [] Nil
 +  where
 +    {-# NOINLINE maybe_spill #-}
 +    maybe_spill :: [instr] -> Loc -> IO [instr]
 +    maybe_spill instrs !loc =
 +      case loc of
 +        InReg reg
 +          | myFalse
 +          -> return []
 +        _ -> return instrs

testsuite/tests/simplCore/should_compile/TrickyJoins.hs

 +{-# LANGUAGE DataKinds #-}
 +{-# LANGUAGE GADTs #-}
 +{-# LANGUAGE ScopedTypeVariables #-}
 +{-# LANGUAGE TypeApplications #-}
 +{-# LANGUAGE TypeFamilies #-}
++
 +{-# LANGUAGE MagicHash #-}
 +{-# LANGUAGE UnboxedTuples #-}
++
 +module TrickyJoinPoints where
++
 +import Data.Coerce
 +  ( coerce )
 +import Data.Kind
 +  ( Type )
++
++
 +import Data.Map.Strict (Map)
 +import qualified Data.Map.Strict as Map
 +import qualified Data.Set        as Set
++
 +-----------------------------------
 +-- Join points and profiling ticks
++
 +data ModGuts2 = MkModGuts2
++
 +runCorePasses3 :: Bool -> ModGuts2 -> IO ModGuts2
 +runCorePasses3 pass guts = doCorePass3 pass guts
++
 +doCorePass3 :: Bool -> ModGuts2 -> IO ModGuts2
 +doCorePass3 pass guts = do
 +  _ <- putStrLn "hi"
++
 +  let
 +    updateBinds _ = return guts
++
 +  case pass of
 +    True -> {-# SCC "XXX3" #-} updateBinds False
 +    _ -> {-# SCC "YYY3" #-} updateBinds True
++
 +--------------------------
 +-- Join points & casts
++
 +newtype AdjacencyMap a = AM {
 +    adjacencyMap :: Map a (Set.Set a) }
++
 +overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a
 +overlays = AM . Map.unionsWith Set.union . map adjacencyMap
++
++
 +type SBool :: Bool -> Type
 +data SBool b where
 +  SFalse :: SBool False
 +  STrue  :: SBool True
++
 +type N :: Bool -> Type
 +data family N b
 +newtype instance N False = NF ( Int -> Int )
 +newtype instance N True  = NT ( Int -> Int )
++
 +testCast :: forall b. SBool b -> Int -> Int
 +testCast b n =
 +  case
 +    ( let
 +        {-# NOINLINE juliet #-}
 +        juliet :: Int -> Int -> Int
 +        juliet x = \ y -> x + y + n
 +      in
 +      case b of
 +        SFalse -> NF (juliet 1)
 +        STrue  -> NT (juliet 2)
 +    ) :: N b of
 +      n | SFalse <- b
 +        , NF f <- n
 +        -> f 100
 +        | STrue <- b
 +        , NT g <- n
 +        -> g 200
++
++
 +------------------------------------------
 +-- Join points, profiling ticks and casts
++
 +newtype M = M ( Int -> Int -> Int )
++
 +testCastTick :: forall b. SBool b -> Int -> Int
 +testCastTick b n =
 +  case
 +    ( let
 +        {-# NOINLINE j #-}
 +        j :: Int -> Int -> Int
 +        j x = \ y -> x + y + n
 +        {-# NOINLINE k #-}
 +        k :: M
 +        k = coerce j
 +      in
 +      case b of
 +        SFalse -> {-# SCC "ticked" #-} NF ( coerce @M @( Int -> Int -> Int ) k 1 )
 +        STrue  -> NT ( coerce @M @( Int -> Int -> Int ) k 2 )
 +    ) :: N b of
 +      n | SFalse <- b
 +        , NF f <- n
 +        -> f 100
 +        | STrue <- b
 +        , NT g <- n
 +        -> g 200
++
 +------------------------------------------
++
 +{-# NOINLINE testJoinTransitivity #-}
 +testJoinTransitivity :: Bool -> Int -> Int
 +testJoinTransitivity b n =
 +  let
 +    f x = x ^ ( 99 :: Int ) + 7 * ( x - 19 )
 +    {-# NOINLINE f #-}
 +  in
 +    f (
 +      let
 +        j1 :: Int -> Int
 +        j1 x = x + n
 +        {-# NOINLINE j1 #-}
++
 +        j2 :: Int -> Int
 +        j2 y = j1 (y * 2)
 +        {-# NOINLINE j2 #-}
++
 +        j3 :: Int -> Int
 +        j3 z = j2 (z * 3)
 +        {-# NOINLINE j3 #-}
++
 +      in case b of
 +        True  -> {-# SCC "ticked" #-} j3 10
 +        False -> j3 20
 +    )
++
 +--------------------------------------------------------------------------------
 +-- Test relating to Note [JoinId vs TailCallInfo]
++
 +expt :: Int -> Int
 +expt _ = 3
 +{-# NOINLINE expt #-}
++
 +repro :: (Int, Int) -> (Int, Int)
 +repro (f0,e0) =
 + let
 +  (f,e) =
 +    let n = e0
 +    in
 +      case n > 0 of
 +        True  -> (f0, e0 + n)
 +        False -> (f0, e0)
 +  r = let be = expt e in f * be
 +  in
 +    (r, 7)

testsuite/tests/simplCore/should_compile/all.T

@@ -470,6 +470,9 @@ test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings
  # go should become a join point
  test('T22428', [grep_errmsg(r'jump go') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-unfoldings'])
 +test('TrickyJoins', normal, compile, [''])
 +test('T26642', [unless(have_profiling(), skip)], compile, ['-O -prof -fprof-auto-calls'])
++
  test('T22459', normal, compile, [''])
  test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
  test('T22662', normal, compile, [''])