GitLab

sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC

Commits:

bf85c633

by sheaf at 2026-04-01T18:11:24+02:00

Simplify mkTick

This commit simplifies 'GHC.Core.Utils.mkTick', removing the
accumulating parameter 'rest' which was suspiciously treating a bunch of
different ticks as a group, and moving the group as a whole around the
AST, ignoring that the ticks in the group might have different placement
properties.

Also adds Note [Pushing SCCs inwards] which clarifies the logic for
pushing SCCs into lambdas, constructor applications, and dropping SCCs
around non-function variables (in particular the treatment of splittable
ticks).

A few other changes are also implemented:

  - simplify 'can_split' predicate (no functional change)
  - drop profiling ticks around coercions, fixing #26941 and #27121
  - combine profiling ticks into one when possible

Fixes #26878, #26941 and #27121

Co-authored-by: simonpj <simon.peytonjones@gmail.com>

9 changed files:

compiler/GHC/Core/Utils.hs
compiler/GHC/Types/Tickish.hs
libraries/ghc-heap/tests/tso_and_stack_closures.hs
+ testsuite/tests/profiling/should_compile/T27121.hs
+ testsuite/tests/profiling/should_compile/T27121_aux.hs
testsuite/tests/profiling/should_compile/all.T
+ testsuite/tests/simplCore/should_compile/T26941.hs
+ testsuite/tests/simplCore/should_compile/T26941_aux.hs
testsuite/tests/simplCore/should_compile/all.T

Changes:

compiler/GHC/Core/Utils.hs

@@ -303,101 +303,262 @@ mkCast expr co
  *                                                                      *
  ********************************************************************* -}
 --- | Wraps the given expression in the source annotation, dropping the
 --- annotation if possible.
 +-- | Wraps the given expression in a Tick, floating the tick as far into
 +-- the AST as possible in order to try to satisfy the tick's desired placement
 +-- properties (as per Note [Tickish placement] in GHC.Types.Tickish).
 +--
 +-- Prefer using 'mkTick' over explicit use of the 'Tick' constructor.
 +--
 +-- Also performs small on-the-fly optimisations:
 +--
 +--   * Eliminate unnecessary ticks by either absorbing them into existing ones
 +--     or dropping them if that is valid (e.g. dropping profiling ticks around
 +--     types, coercions and literals).
 +--   * Split profiling ticks into counting/scoping parts so that the two parts
 +--     can be placed independently into the AST.
  mkTick :: CoreTickish -> CoreExpr -> CoreExpr
 -mkTick t orig_expr = mkTick' id orig_expr
 +mkTick t orig_expr = mkTick' orig_expr
   where
    -- Some ticks (cost-centres) can be split in two, with the
    -- non-counting part having laxer placement properties.
 -  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
 +  -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish.
 +  can_split = tickishCanSplit t
 -  -- mkTick' handles floating of ticks *into* the expression.
 -  mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with)
 -                                    -- Always a composition of (Tick t) wrappers
 -          -> CoreExpr               -- Current expression
 -          -> CoreExpr
 -          -- So in the call (mkTick' rest e), the expression
 -          --   (rest e)
 -          -- has the same type as e
 -          -- Returns an expression equivalent to (Tick t (rest e))
 -  mkTick' rest expr = case expr of
 -    -- Float ticks into unsafe coerce the same way we would do with a cast.
 -    Case scrut bndr ty alts@[Alt ac abs _rhs]
 -      | Just rhs <- isUnsafeEqualityCase scrut bndr alts
 -      -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)]
+-
 -    -- Cost centre ticks should never be reordered relative to each
 -    -- other. Therefore we can stop whenever two collide.
 +  -- mkTick' handles floating of tick `t` *into* the expression.
 +  mkTick' :: CoreExpr -> CoreExpr
 +  mkTick' expr = case expr of
      Tick t2 e
 -      | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr
+-
 -    -- Otherwise we assume that ticks of different placements float
 -    -- through each other.
 -      | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e
+-
 -    -- For annotations this is where we make sure to not introduce
 -    -- redundant ticks.
 -      | tickishContains t t2              -> mkTick' rest e  -- Drop t2
 -      | tickishContains t2 t              -> rest e          -- Drop t
 -      | otherwise                         -> mkTick' (rest . Tick t2) e
+-
 -    -- Ticks don't care about types, so we just float all ticks
 -    -- through them. Note that it's not enough to check for these
 -    -- cases top-level. While mkTick will never produce Core with type
 -    -- expressions below ticks, such constructs can be the result of
 -    -- unfoldings. We therefore make an effort to put everything into
 -    -- the right place no matter what we start with.
 -    Cast e co   -> mkCast (mkTick' rest e) co
 -    Coercion co -> Tick t $ rest (Coercion co)
++
 +      -- Common up ticks when possible, including profiling ticks that
 +      -- share a cost centre and source notes that subsume one another.
 +      | Just t' <- combineTickish_maybe t t2
 +      -> mkTick t' e
++
 +      -- Profiling ticks for different cost centres should never be reordered
 +      -- relative to each other. Therefore, we stop whenever two collide.
 +      | ProfNote {} <- t
 +      , ProfNote {} <- t2
 +      -> Tick t expr
++
 +      -- Ticks of different placements float through each other, so that each
 +      -- tick can be floated into its expected position in the AST.
 +      -- See Note [Tickish placement] in GHC.Types.Tickish.
 +      | tickishPlace t2 /= tickishPlace t
 +      -> Tick t2 $ mkTick' e
      Lam x e
        -- Always float through type lambdas. Even for non-type lambdas,
        -- floating is allowed for all but the most strict placement rule.
        | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
 -      -> Lam x $ mkTick' rest e
 +      -> Lam x $ mkTick' e
 -      -- If it is both counting and scoped, we split the tick into its
 -      -- two components, often allowing us to keep the counting tick on
 -      -- the outside of the lambda and push the scoped tick inside.
 -      -- The point of this is that the counting tick can probably be
 -      -- floated, and the lambda may then be in a position to be
 -      -- beta-reduced.
 -      | canSplit
 -      -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e
 +      -- Push SCCs into lambdas.
 +      -- See (PSCC2) in Note [Pushing SCCs inwards].
 +      | can_split
 +      -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e
      App f arg
 -      -- Always float through type applications.
 +      -- All ticks float inwards through non-runtime arguments, as per
 +      -- Note [Tickish placement] in GHC.Types.Tickish.
        | not (isRuntimeArg arg)
 -      -> App (mkTick' rest f) arg
 +      -> App (mkTick' f) arg
 -      -- We can also float through constructor applications, placement
 -      -- permitting. Again we can split.
 -      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
 +      -- Push SCCs into saturated constructor applications.
 +      -- See (PSCC3) in Note [Pushing SCCs inwards].
 +      | isSaturatedConApp expr
 +      , tickishPlace t == PlaceCostCentre || can_split
        -> if tickishPlace t == PlaceCostCentre
 -         then rest $ tickHNFArgs t expr
 -         else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
 +         then tickHNFArgs t expr
 +         else Tick (mkNoScope t) $ tickHNFArgs (mkNoCount t) expr
++
 +    -- See Note [No ticks around types or coercions]
 +    e@(Coercion {}) -> e
 +    e@(Type {})     -> e
 +    -- Don't wrap static data in a tick which compiles to code,
 +    -- as the code will never be run.
 +    e@(Lit {}) | tickishIsCode t -> e
++
 +    -- All ticks can be floated through casts, as per Note [Tickish placement].
 +    Cast e co   -> mkCast (mkTick' e) co
++
 +    -- Treat 'unsafeCoerce' as if it was a cast: float all ticks inwards.
 +    -- See Note [Push ticks into unsafeCoerce]
 +    Case scrut bndr ty alts@[Alt ac abs _rhs]
 +      | Just rhs <- isUnsafeEqualityCase scrut bndr alts
 +      -> Case scrut bndr ty [Alt ac abs (mkTick' rhs)]
      Var x
 -      | notFunction && tickishPlace t == PlaceCostCentre
 -      -> rest expr  -- Drop t
 -      | notFunction && canSplit
 -      -> Tick (mkNoScope t) $ rest expr
 -      where
 -        -- SCCs can be eliminated on variables provided the variable
 -        -- is not a function.  In these cases the SCC makes no difference:
 -        -- the cost of evaluating the variable will be attributed to its
 -        -- definition site.  When the variable refers to a function, however,
 -        -- an SCC annotation on the variable affects the cost-centre stack
 -        -- when the function is called, so we must retain those.
 -        notFunction = not (isFunTy (idType x))
+-
 -    Lit{}
 +       -- Don't drop any ticks around a function
 +      | isFunTy (idType x)
 +      -> Tick t expr
 +      -- Drop SCCs around non-function variables.
 +      -- See (PSCC1) in Note [Pushing SCCs inwards].
        | tickishPlace t == PlaceCostCentre
 -      -> rest expr   -- Drop t
 +      -> -- Drop pure SCC ticks:  scc<foo> (x :: Int) ==> x
 +         expr
 +      | can_split
 +      -> -- Drop the scoping part of the tick, but keep the counting part.
 +         Tick (mkNoScope t) expr
++
 +    -- Catch-all: annotate where we stand.
 +    -- In particular (but not only): Let, most Cases.
 +    _other -> Tick t expr
++
 +{- Note [Pushing SCCs inwards]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +Amongst all ticks, SCCs have the laxest placement properties (PlaceCostCentre,
 +as described in Note [Tickish placement] GHC.Types.Tickish):
++
 +  (PSCC1) SCCs around non-function variables can be eliminated.
 +    The cost of evaluating the variable will be attributed to its definition
 +    site, so the SCC makes no difference. Example:
++
 +      scc<foo> (x :: Int)  ==>  x
++
 +    NB: this is only valid when the variable is not a function. For example, in:
++
 +      scc<foo> (f :: Int -> Int)
++
 +    we must retain the cost centre annotation, as it affects the cost-centre
 +    pointer when the function is called. Discarding the SCC in this case would
 +    defeat the profiling mechanism entirely!
++
 +  (PSCC2) SCCs can be pushed into lambdas.
++
 +       scc<foo> (\x -> e)  ==>  \x -> scc<foo> e
++
 +  (PSCC3) We can push SCCs into (saturated) constructor applications.
 +    For example, for an arity 2 data constructor 'D':
++
 +       scc<foo> (D e1 e2)  ==>  D (scc<foo> e1) (scc<foo> e2)
++
 +Now, two kinds of ticks contain SCCs:
++
 +  - bare SCCs (i.e. ProfNote with profNoteCounts = False, profNoteScopes = True)
 +  - profiling ticks that both count and scope
++
 +The above explanation deals with bare SCCs. When handling profiling ticks that
 +both count and scope, we can split tick into two, so that the scoping part can
 +be pushed inwards (or even discarded). Specifically, we perform the following
 +transformations:
++
 +  (PSCC1) Drop the SCC around non-function variables, keeping only the counting
 +    part:
++
 +       scctick<foo> (x :: Int)  ==>  tick<foo> x
++
 +  (PSCC2) Push the SCC inside lambdas:
++
 +       scctick<foo> (\x. e)  ==>  tick<foo> (\x. scc<foo> e)
++
 +    NB: we must keep the counting part outside the lambda, in order to preserve
 +    tick counter tallies – it would not be sound to push the counting part inside.
 -    -- Catch-all: Annotate where we stand
 -    _any -> Tick t $ rest expr
 +  (PSCC3) Push the SCC inside saturated contructor applications.
++
 +       scctick<foo> (D e1 e2)  ==>  tick<foo> (D (scc<foo> e1) (scc<foo> e2))
++
 +The benefit of these transformation is that the counting part, tick<foo>, can
 +likely be floated out of the way, which may expose additional optimisation
 +opportunities. For example, for (PSCC2):
++
 +  (scctick<foo> (\x. e)) arg
++
 +    ==>{PSCC2}
++
 +  (tick<foo> (\x. scc<foo> e)) arg
++
 +    ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope}
++
 +  tick<foo> ((\x. scc<foo> e) arg)
++
 +    ==>{beta reduction}
++
 +  tick<foo> (let x = arg in scc<foo> e)
++
 +For (PSCC3):
++
 +  case (scctick<foo> (Just x)) of { Nothing -> 0; Just y -> y + 1 }
++
 +    ==>{PSCC3}
++
 +  case (tick<foo> (Just (scc<foo> x))) of { Nothing -> 0; Just y -> y + 1 }
++
 +    ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope}
++
 +  tick<foo> (case Just (scc<foo> x) of { Nothing -> 0; Just y -> y + 1 })
++
 +    ==>{case of known constructor}
++
 +  tick<foo> (let y = scc<foo> x in y + 1)
++
 +Note [Push ticks into unsafeCoerce]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +In #25212, we had a program of the form:
++
 +  data Box = Box Any
 +  asBox :: a -> Box
 +  asBox x = {-# SCC asBox #-} Box (unsafeCoerce x)
++
 +As per Note [Implementing unsafeCoerce] in GHC.Internal.Unsafe.Coerce, the call
 +to `unsafeCoerce` turns into
++
 +  case unsafeEqualityProof @Type @a @Any of
 +    UnsafeRefl (co :: a ~# Any) -> x |> Sub co
++
 +The worker for 'asBox' is then of the form:
++
 +  $wasBox = \@a (x :: a) ->
 +    (# case unsafeEqualityProof @Type @a @Any of
 +        UnsafeRefl (co :: a ~# Any) -> x |> Sub co
 +    #)
++
 +When inserting the SCC, we push it into the constructor as per (PSCC3) in
 +Note [Pushing SCCs inwards], so we get:
++
 +  $wasBox = \@a (x :: a) ->
 +    tick<asBox>
 +    (# scc<asBox>
 +       case unsafeEqualityProof @Type @a @Any of
 +         UnsafeRefl (co :: a ~# Any) -> x |> Sub co
 +    #)
++
 +Now, if we don't push the SCC tick into the case statement, Core Prep will
 +see an expression like 'MkSolo# (scc<asBox> ...)', which it will ANFise to
 +'let x = scc<asBox> ... in MkSolo# x', creating an unwanted thunk in the process.
++
 +So the strategy is to treat this 'unsafeEqualityProof' case statement as if it
 +was a cast. We thus push the SCC into the RHS of the pattern match:
++
 +  $wasBox = \@a (x :: a) ->
 +    tick<asBox>
 +    (# case unsafeEqualityProof @Type @a @Any of
 +         UnsafeRefl (co :: a ~# Any) -> scc<asBox> x |> Sub co
 +    #)
++
 +Then the SCC completely evaporates, as per (PSCC1) in Note [Pushing SCCs inwards].
++
 +Note [No ticks around types or coercions]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +It doesn't make much sense to put a tick around a type or a coercion, as both
 +types and coercions are erased in the end.
++
 +In fact, it is quite dangerous to add a tick around types or coercions, because
 +the optimiser does not robustly look through ticks:
++
 +  - 'GHC.Core.SimpleOpt.simple_bind_pair' does not look through ticks when
 +    looking at the RHS to decide whether it is a Type or Coercion,
 +  - 'GHC.Core.Opt.Simplify.Iteration.completeBind' does not look through ticks
 +    when looking at the RHS of an CoVar binding.
++
 +This means it is vital to drop ticks around types/coercions:
++
 +  - (#26941) Core Lint rejects bindings of the form "let co = tick ..."
 +    in which the LHS is a CoVar and the RHS is a ticked Coercion.
 +  - (#27121) The simplifier mis-handles ticked coercion bindings, which can
 +    result in 'lookupIdSubst' panics (due to failing to extend the substitution
 +    with a coercion).
 +-}
  mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
  mkTicks ticks expr = foldr mkTick expr ticks
@@ -2573,8 +2734,8 @@ exprIsTickedString = isJust . exprIsTickedString_maybe
  exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
  exprIsTickedString_maybe (Lit (LitString bs)) = Just bs
  exprIsTickedString_maybe (Tick t e)
 -  -- we don't tick literals with CostCentre ticks, compare to mkTick
 -  | tickishPlace t == PlaceCostCentre = Nothing
 +  -- Shortcut: ticks with code never wrap literals (compare with 'mkTick')
 +  | tickishIsCode t = Nothing
    | otherwise = exprIsTickedString_maybe e
  exprIsTickedString_maybe _ = Nothing

compiler/GHC/Types/Tickish.hs

@@ -17,6 +17,7 @@ module GHC.Types.Tickish (
    TickishPlacement(..),
    tickishPlace,
    tickishContains,
 +  combineTickish_maybe,
    -- * Breakpoint tick identifiers
    BreakpointId(..), BreakTickIndex
@@ -261,8 +262,12 @@ Ticks have two independent attributes:
       See Note [Scoped ticks]
 +Note that profiling notes which both count and scope can be split into two
 +separate ticks, one that counts and doesn't scope and one that scopes and doesn't
 +count; see 'tickishCanSplit', 'mkNoCount' and 'mkNoScope'.
++
  Note [Counting ticks]
 -~~~~~~~~~~~~~~~~~~~~
 +~~~~~~~~~~~~~~~~~~~~~
  The following ticks count:
    - ProfNote ticks with profNoteCounts = True
    - HPC ticks
@@ -290,7 +295,7 @@ 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
@@ -375,6 +380,61 @@ Whether we are allowed to float in additional cost depends on the tick:
      While these transformations are legal, we want to make a best effort to
      only make use of them where it exposes transformation opportunities.
++
 +Note [Tickish placement]
 +~~~~~~~~~~~~~~~~~~~~~~~~
 +The placement behaviour of ticks (i.e. which nodes we want the tick to be placed
 +around in the AST) is governed by 'TickishPlacement'.
 +From most restrictive to least restrictive placement rules:
++
 +  - PlaceRuntime: counting ticks.
++
 +    Ticks with 'PlaceRuntime' placement want to be placed around run-time
 +    expressions. They can be moved through pure compile-time constructs such as
 +    other type arguments, casts, or type lambdas:
++
 +      tick <t> (f @ty)    ==>   (tick <t> f) @ty
 +      tick <t> (e |> co)  ==>   (tick <t> e) |> co
 +      tick <t> (/\a. e)   ==>   /\a. tick <t> e
++
 +    This is the most restrictive placement rule for ticks, as all tickishs have
 +    in common that they want to track runtime behaviour.
++
 +    Any tick that counts (see Note [Counting ticks]) has 'PlaceRuntime' placement.
++
 +  - PlaceNonLam: source notes.
++
 +    Like PlaceRuntime, but we can also float the tick through value lambdas:
++
 +      tick <t> (\x. e)   ==>   \x. tick <t> e
++
 +    This makes sense where there is little difference between annotating the
 +    lambda and annotating the lambda's code.
++
 +  - PlaceCostCentre: non-counting profiling ticks.
++
 +    In addition to floating through lambdas, cost-centre style tickishs can be
 +    pushed into (saturated) constructor applications, and can be eliminated when
 +    placed around non-function variables:
++
 +      tick <t> (C e1 e2)   ==>  C (tick <t> e1) (tick <t> e2)
++
 +      tick <t> (x :: Int)  ==>  (x :: Int)
++
 +    Neither the constructor application nor the variable 'x' are likely to have
 +    any cost worth mentioning.
++
 +We generally try to push ticks inwards until they end up placed around a Core
 +expression that is appropriate for their placement rule, as described above.
 +This gives us the opportunity to eliminate the tick, either by combining it with
 +another tick (see 'combineTickish_maybe') or by dropping it altogether. For
 +example, a (non-counting) SCC around a non-function variable can be dropped, as
 +there is no cost to scope over.
++
 +After the tick has been placed by 'mkTick', the simplifier may later (during
 +simplification) decide to float it outwards (see e.g. GHC.Core.Opt.Simplify.Iteration.simplTick).
 +The story here is not fully worked out, as the simplifier calls 'mkTick', which
 +might push the tick inwards again.
  -}
  -- | Returns @True@ for ticks that can be floated upwards easily even
@@ -441,35 +501,19 @@ isProfTick _          = False
  -- annotating for example using @mkTick@. If we find that we want to
  -- put a tickish on an expression ruled out here, we try to float it
  -- inwards until we find a suitable expression.
 +--
 +-- See Note [Tickish placement].
  data TickishPlacement =
 -    -- | Place ticks exactly on run-time expressions. We can still
 -    -- move the tick through pure compile-time constructs such as
 -    -- other ticks, casts or type lambdas. This is the most
 -    -- restrictive placement rule for ticks, as all tickishs have in
 -    -- common that they want to track runtime processes. The only
 -    -- legal placement rule for counting ticks.
 -    -- NB: We generally try to move these as close to the relevant
 -    -- runtime expression as possible. This means they get pushed through
 -    -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`.
 +    -- | Place ticks exactly on run-time expressions, moving them through pure
 +    -- compile-time constructs such as other ticks, casts or type lambdas.
      PlaceRuntime
 -    -- | As @PlaceRuntime@, but we float the tick through all
 -    -- lambdas. This makes sense where there is little difference
 -    -- between annotating the lambda and annotating the lambda's code.
 +    -- | As @PlaceRuntime@, but also allow to float the tick through all lambdas.
    | PlaceNonLam
 -    -- | In addition to floating through lambdas, cost-centre style
 -    -- tickishs can also be moved from constructors, non-function
 -    -- variables and literals. For example:
 -    --
 -    --   let x = scc<...> C (scc<...> y) (scc<...> 3) in ...
 -    --
 -    -- Neither the constructor application, the variable or the
 -    -- literal are likely to have any cost worth mentioning. And even
 -    -- if y names a thunk, the call would not care about the
 -    -- evaluation context. Therefore removing all annotations in the
 -    -- above example is safe.
 +    -- | As 'PlaceNonLam', but also float through constructors, non-function
 +    -- variables and literals.
    | PlaceCostCentre
    deriving (Eq,Show)
@@ -477,7 +521,9 @@ data TickishPlacement =
  instance Outputable TickishPlacement where
    ppr = text . show
 --- | Placement behaviour we want for the ticks
 +-- | Placement behaviour we want for the ticks.
 +--
 +-- See Note [Tickish placement].
  tickishPlace :: GenTickish pass -> TickishPlacement
  tickishPlace n@ProfNote{}
    | profNoteCount n        = PlaceRuntime
@@ -486,6 +532,43 @@ tickishPlace HpcTick{}     = PlaceRuntime
  tickishPlace Breakpoint{}  = PlaceRuntime
  tickishPlace SourceNote{}  = PlaceNonLam
 +-- | Merge two ticks into one, if that is possible.
 +--
 +-- Examples:
 +--
 +--  - combine two source note ticks if one contains the other,
 +--  - combine a non-counting profiling tick with a non-scoping profiling tick
 +--    for the same cost centre
 +--  - combine two equal breakpoint ticks or HPC ticks
 +combineTickish_maybe :: Eq (GenTickish pass)
 +                     => GenTickish pass -> GenTickish pass -> Maybe (GenTickish pass)
 +combineTickish_maybe
 +  (ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 })
 +  (ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 })
 +    | cc1 == cc2
 +    , not cnt1 || not cnt2
 +    = Just $ ProfNote { profNoteCC    = cc1
 +                      , profNoteCount = cnt1 || cnt2
 +                      , profNoteScope = scope1 || scope2
 +                      }
 +combineTickish_maybe t1@(SourceNote sp1 n1) t2@(SourceNote sp2 n2)
 +  | n1 == n2
 +  , sp1 `containsSpan` sp2
 +  = Just t1
 +  | n1 == n2
 +  , sp2 `containsSpan` sp1
 +  = Just t2
 +  -- NB: it would be possible to use 'combineRealSrcSpans' instead,
 +  -- but that has the risk of combining many source note ticks into a single
 +  -- tick with a huge source span.
 +combineTickish_maybe t1@(HpcTick {}) t2@(HpcTick {})
 +  | t1 == t2
 +  = Just t1
 +combineTickish_maybe t1@(Breakpoint {}) t2@(Breakpoint {})
 +  | t1 == t2
 +  = Just t1
 +combineTickish_maybe _ _ = Nothing
++
  -- | Returns whether one tick "contains" the other one, therefore
  -- making the second tick redundant.
  tickishContains :: Eq (GenTickish pass)

libraries/ghc-heap/tests/tso_and_stack_closures.hs

@@ -48,7 +48,9 @@ main = do
                          assertEqual (cc_module myCostCentre) "Main"
                          assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:24:48-80")
                          assertEqual (cc_is_caf myCostCentre) False
 -                    Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre)
 +                    Nothing -> error "MyCostCentre not found"
 +                      -- Don't print all of 'linkedCostCentres costCentre',
 +                      -- as that is ~20k lines of output.
  #endif
  linkedCostCentres :: Maybe CostCentre -> [CostCentre]

testsuite/tests/profiling/should_compile/T27121.hs

 +module T27121 where
++
 +import T27121_aux
++
 +updateFileDiagnostics
 +  :: LanguageContextEnv ()
 +  -> IO ()
 +updateFileDiagnostics env = do
 +  withTrace $ \ _tag ->
 +    runLspT env $ do
 +      sendNotification SMethod_TextDocumentPublishDiagnostics
 +        PublishDiagnosticsParams

testsuite/tests/profiling/should_compile/T27121_aux.hs

 +{-# LANGUAGE DataKinds #-}
 +{-# LANGUAGE DerivingStrategies #-}
 +{-# LANGUAGE DuplicateRecordFields #-}
 +{-# LANGUAGE FunctionalDependencies #-}
 +{-# LANGUAGE LambdaCase #-}
 +{-# LANGUAGE RoleAnnotations #-}
 +{-# LANGUAGE TypeFamilies #-}
++
 +module T27121_aux
 +  ( withTrace
 +  , sendNotification
 +  , LspT, runLspT
 +  , SMethod(..)
 +  , LanguageContextEnv
 +  , PublishDiagnosticsParams(..)
 +  )
 + where
++
 +-- base
 +import Control.Monad.IO.Class ( MonadIO, liftIO )
 +import Data.Kind ( Type )
 +import GHC.TypeLits ( Symbol )
++
 +--------------------------------------------------------------------------------
++
 +withTrace :: Monad m => ((String -> String -> m ()) -> m a) -> m a
 +withTrace act
 +  | myUserTracingEnabled
 +  = return undefined
 +  | otherwise = act (\_ _ -> pure ())
 +{-# NOINLINE withTrace #-}
++
 +myUserTracingEnabled :: Bool
 +myUserTracingEnabled = False
 +{-# NOINLINE myUserTracingEnabled #-}
++
 +type Text = String
++
 +newtype LspT config a = LspT {unLspT :: LanguageContextEnv config -> IO a}
++
 +instance Functor (LspT config) where
 +  fmap f (LspT g) = LspT (fmap f . g)
++
 +instance Applicative (LspT config) where
 +  pure = LspT . const . pure
 +  LspT f <*> LspT a = LspT $ \ env -> f env <*> a env
 +instance Monad (LspT config) where
 +  LspT a >>= f = LspT $ \ env -> do
 +    b <- a env
 +    unLspT ( f b ) env
 +instance MonadIO (LspT config) where
 +  liftIO = LspT . const . liftIO
++
 +type role LspT representational nominal
++
 +runLspT :: LanguageContextEnv config -> LspT config a -> IO a
 +runLspT env (LspT f) = f env
 +{-# INLINE runLspT #-}
++
 +data PublishDiagnosticsParams = PublishDiagnosticsParams
++
 +data LanguageContextEnv config =
 +  LanguageContextEnv
 +    { resSendMessage :: FromServerMessage -> IO () }
++
++
 +sendNotification ::
 +  forall (m :: Method ServerToClient Notification) f config.
 +  MonadLsp config f =>
 +  SServerMethod m ->
 +  MessageParams m ->
 +  f ()
 +sendNotification m params =
 +  let msg = TNotificationMessage { _method = m, _params = params }
 +   in case splitServerMethod m of
 +        IsServerNot -> sendToClient $ fromServerNot msg
++
 +type Method :: MessageDirection -> MessageKind -> Type
 +data Method f t where
 +  Method_TextDocumentImplementation :: Method ClientToServer Request
 +  Method_TextDocumentTypeDefinition :: Method ClientToServer Request
 +  Method_WorkspaceWorkspaceFolders :: Method ServerToClient Request
 +  Method_WorkspaceConfiguration :: Method ServerToClient Request
 +  Method_TextDocumentDocumentColor :: Method ClientToServer Request
 +  Method_TextDocumentColorPresentation :: Method ClientToServer Request
 +  Method_TextDocumentFoldingRange :: Method ClientToServer Request
 +  Method_TextDocumentDeclaration :: Method ClientToServer Request
 +  Method_TextDocumentSelectionRange :: Method ClientToServer Request
 +  Method_WindowWorkDoneProgressCreate :: Method ServerToClient Request
 +  Method_TextDocumentPrepareCallHierarchy :: Method ClientToServer Request
 +  Method_CallHierarchyIncomingCalls :: Method ClientToServer Request
 +  Method_CallHierarchyOutgoingCalls :: Method ClientToServer Request
 +  Method_TextDocumentSemanticTokensFull :: Method ClientToServer Request
 +  Method_TextDocumentSemanticTokensFullDelta :: Method ClientToServer Request
 +  Method_TextDocumentSemanticTokensRange :: Method ClientToServer Request
 +  Method_WorkspaceSemanticTokensRefresh :: Method ServerToClient Request
 +  Method_WindowShowDocument :: Method ServerToClient Request
 +  Method_TextDocumentLinkedEditingRange :: Method ClientToServer Request
 +  Method_WorkspaceWillCreateFiles :: Method ClientToServer Request
 +  Method_WorkspaceWillRenameFiles :: Method ClientToServer Request
 +  Method_WorkspaceWillDeleteFiles :: Method ClientToServer Request
 +  Method_TextDocumentMoniker :: Method ClientToServer Request
 +  Method_TextDocumentPrepareTypeHierarchy :: Method ClientToServer Request
 +  Method_TypeHierarchySupertypes :: Method ClientToServer Request
 +  Method_TypeHierarchySubtypes :: Method ClientToServer Request
 +  Method_TextDocumentInlineValue :: Method ClientToServer Request
 +  Method_WorkspaceInlineValueRefresh :: Method ServerToClient Request
 +  Method_TextDocumentInlayHint :: Method ClientToServer Request
 +  Method_InlayHintResolve :: Method ClientToServer Request
 +  Method_WorkspaceInlayHintRefresh :: Method ServerToClient Request
 +  Method_TextDocumentDiagnostic :: Method ClientToServer Request
 +  Method_WorkspaceDiagnostic :: Method ClientToServer Request
 +  Method_WorkspaceDiagnosticRefresh :: Method ServerToClient Request
 +  Method_ClientRegisterCapability :: Method ServerToClient Request
 +  Method_ClientUnregisterCapability :: Method ServerToClient Request
 +  Method_Initialize :: Method ClientToServer Request
 +  Method_Shutdown :: Method ClientToServer Request
 +  Method_WindowShowMessageRequest :: Method ServerToClient Request
 +  Method_TextDocumentWillSaveWaitUntil :: Method ClientToServer Request
 +  Method_TextDocumentCompletion :: Method ClientToServer Request
 +  Method_CompletionItemResolve :: Method ClientToServer Request
 +  Method_TextDocumentHover :: Method ClientToServer Request
 +  Method_TextDocumentSignatureHelp :: Method ClientToServer Request
 +  Method_TextDocumentDefinition :: Method ClientToServer Request
 +  Method_TextDocumentReferences :: Method ClientToServer Request
 +  Method_TextDocumentDocumentHighlight :: Method ClientToServer Request
 +  Method_TextDocumentDocumentSymbol :: Method ClientToServer Request
 +  Method_TextDocumentCodeAction :: Method ClientToServer Request
 +  Method_CodeActionResolve :: Method ClientToServer Request
 +  Method_WorkspaceSymbol :: Method ClientToServer Request
 +  Method_WorkspaceSymbolResolve :: Method ClientToServer Request
 +  Method_TextDocumentCodeLens :: Method ClientToServer Request
 +  Method_CodeLensResolve :: Method ClientToServer Request
 +  Method_WorkspaceCodeLensRefresh :: Method ServerToClient Request
 +  Method_TextDocumentDocumentLink :: Method ClientToServer Request
 +  Method_DocumentLinkResolve :: Method ClientToServer Request
 +  Method_TextDocumentFormatting :: Method ClientToServer Request
 +  Method_TextDocumentRangeFormatting :: Method ClientToServer Request
 +  Method_TextDocumentOnTypeFormatting :: Method ClientToServer Request
 +  Method_TextDocumentRename :: Method ClientToServer Request
 +  Method_TextDocumentPrepareRename :: Method ClientToServer Request
 +  Method_WorkspaceExecuteCommand :: Method ClientToServer Request
 +  Method_WorkspaceApplyEdit :: Method ServerToClient Request
 +  Method_WorkspaceDidChangeWorkspaceFolders :: Method ClientToServer Notification
 +  Method_WindowWorkDoneProgressCancel :: Method ClientToServer Notification
 +  Method_WorkspaceDidCreateFiles :: Method ClientToServer Notification
 +  Method_WorkspaceDidRenameFiles :: Method ClientToServer Notification
 +  Method_WorkspaceDidDeleteFiles :: Method ClientToServer Notification
 +  Method_NotebookDocumentDidOpen :: Method ClientToServer Notification
 +  Method_NotebookDocumentDidChange :: Method ClientToServer Notification
 +  Method_NotebookDocumentDidSave :: Method ClientToServer Notification
 +  Method_NotebookDocumentDidClose :: Method ClientToServer Notification
 +  Method_Initialized :: Method ClientToServer Notification
 +  Method_Exit :: Method ClientToServer Notification
 +  Method_WorkspaceDidChangeConfiguration :: Method ClientToServer Notification
 +  Method_WindowShowMessage :: Method ServerToClient Notification
 +  Method_WindowLogMessage :: Method ServerToClient Notification
 +  Method_TelemetryEvent :: Method ServerToClient Notification
 +  Method_TextDocumentDidOpen :: Method ClientToServer Notification
 +  Method_TextDocumentDidChange :: Method ClientToServer Notification
 +  Method_TextDocumentDidClose :: Method ClientToServer Notification
 +  Method_TextDocumentDidSave :: Method ClientToServer Notification
 +  Method_TextDocumentWillSave :: Method ClientToServer Notification
 +  Method_WorkspaceDidChangeWatchedFiles :: Method ClientToServer Notification
 +  Method_TextDocumentPublishDiagnostics :: Method ServerToClient Notification
 +  Method_SetTrace :: Method ClientToServer Notification
 +  Method_LogTrace :: Method ServerToClient Notification
 +  Method_CancelRequest :: Method f Notification
 +  Method_Progress :: Method f Notification
 +  Method_CustomMethod :: Symbol -> Method f t
++
 +type SMethod :: forall f t . Method f t -> Type
 +data SMethod m where
 +  SMethod_TextDocumentImplementation :: SMethod Method_TextDocumentImplementation
 +  SMethod_TextDocumentTypeDefinition :: SMethod Method_TextDocumentTypeDefinition
 +  SMethod_WorkspaceWorkspaceFolders :: SMethod Method_WorkspaceWorkspaceFolders
 +  SMethod_WorkspaceConfiguration :: SMethod Method_WorkspaceConfiguration
 +  SMethod_TextDocumentDocumentColor :: SMethod Method_TextDocumentDocumentColor
 +  SMethod_TextDocumentColorPresentation :: SMethod Method_TextDocumentColorPresentation
 +  SMethod_TextDocumentFoldingRange :: SMethod Method_TextDocumentFoldingRange
 +  SMethod_TextDocumentDeclaration :: SMethod Method_TextDocumentDeclaration
 +  SMethod_TextDocumentSelectionRange :: SMethod Method_TextDocumentSelectionRange
 +  SMethod_WindowWorkDoneProgressCreate :: SMethod Method_WindowWorkDoneProgressCreate
 +  SMethod_TextDocumentPrepareCallHierarchy :: SMethod Method_TextDocumentPrepareCallHierarchy
 +  SMethod_CallHierarchyIncomingCalls :: SMethod Method_CallHierarchyIncomingCalls
 +  SMethod_CallHierarchyOutgoingCalls :: SMethod Method_CallHierarchyOutgoingCalls
 +  SMethod_TextDocumentSemanticTokensFull :: SMethod Method_TextDocumentSemanticTokensFull
 +  SMethod_TextDocumentSemanticTokensFullDelta :: SMethod Method_TextDocumentSemanticTokensFullDelta
 +  SMethod_TextDocumentSemanticTokensRange :: SMethod Method_TextDocumentSemanticTokensRange
 +  SMethod_WorkspaceSemanticTokensRefresh :: SMethod Method_WorkspaceSemanticTokensRefresh
 +  SMethod_WindowShowDocument :: SMethod Method_WindowShowDocument
 +  SMethod_TextDocumentLinkedEditingRange :: SMethod Method_TextDocumentLinkedEditingRange
 +  SMethod_WorkspaceWillCreateFiles :: SMethod Method_WorkspaceWillCreateFiles
 +  SMethod_WorkspaceWillRenameFiles :: SMethod Method_WorkspaceWillRenameFiles
 +  SMethod_WorkspaceWillDeleteFiles :: SMethod Method_WorkspaceWillDeleteFiles
 +  SMethod_TextDocumentMoniker :: SMethod Method_TextDocumentMoniker
 +  SMethod_TextDocumentPrepareTypeHierarchy :: SMethod Method_TextDocumentPrepareTypeHierarchy
 +  SMethod_TypeHierarchySupertypes :: SMethod Method_TypeHierarchySupertypes
 +  SMethod_TypeHierarchySubtypes :: SMethod Method_TypeHierarchySubtypes
 +  SMethod_TextDocumentInlineValue :: SMethod Method_TextDocumentInlineValue
 +  SMethod_WorkspaceInlineValueRefresh :: SMethod Method_WorkspaceInlineValueRefresh
 +  SMethod_TextDocumentInlayHint :: SMethod Method_TextDocumentInlayHint
 +  SMethod_InlayHintResolve :: SMethod Method_InlayHintResolve
 +  SMethod_WorkspaceInlayHintRefresh :: SMethod Method_WorkspaceInlayHintRefresh
 +  SMethod_TextDocumentDiagnostic :: SMethod Method_TextDocumentDiagnostic
 +  SMethod_WorkspaceDiagnostic :: SMethod Method_WorkspaceDiagnostic
 +  SMethod_WorkspaceDiagnosticRefresh :: SMethod Method_WorkspaceDiagnosticRefresh
 +  SMethod_ClientRegisterCapability :: SMethod Method_ClientRegisterCapability
 +  SMethod_ClientUnregisterCapability :: SMethod Method_ClientUnregisterCapability
 +  SMethod_Initialize :: SMethod Method_Initialize
 +  SMethod_Shutdown :: SMethod Method_Shutdown
 +  SMethod_WindowShowMessageRequest :: SMethod Method_WindowShowMessageRequest
 +  SMethod_TextDocumentWillSaveWaitUntil :: SMethod Method_TextDocumentWillSaveWaitUntil
 +  SMethod_TextDocumentCompletion :: SMethod Method_TextDocumentCompletion
 +  SMethod_CompletionItemResolve :: SMethod Method_CompletionItemResolve
 +  SMethod_TextDocumentHover :: SMethod Method_TextDocumentHover
 +  SMethod_TextDocumentSignatureHelp :: SMethod Method_TextDocumentSignatureHelp
 +  SMethod_TextDocumentDefinition :: SMethod Method_TextDocumentDefinition
 +  SMethod_TextDocumentReferences :: SMethod Method_TextDocumentReferences
 +  SMethod_TextDocumentDocumentHighlight :: SMethod Method_TextDocumentDocumentHighlight
 +  SMethod_TextDocumentDocumentSymbol :: SMethod Method_TextDocumentDocumentSymbol
 +  SMethod_TextDocumentCodeAction :: SMethod Method_TextDocumentCodeAction
 +  SMethod_CodeActionResolve :: SMethod Method_CodeActionResolve
 +  SMethod_WorkspaceSymbol :: SMethod Method_WorkspaceSymbol
 +  SMethod_WorkspaceSymbolResolve :: SMethod Method_WorkspaceSymbolResolve
 +  SMethod_TextDocumentCodeLens :: SMethod Method_TextDocumentCodeLens
 +  SMethod_CodeLensResolve :: SMethod Method_CodeLensResolve
 +  SMethod_WorkspaceCodeLensRefresh :: SMethod Method_WorkspaceCodeLensRefresh
 +  SMethod_TextDocumentDocumentLink :: SMethod Method_TextDocumentDocumentLink
 +  SMethod_DocumentLinkResolve :: SMethod Method_DocumentLinkResolve
 +  SMethod_TextDocumentFormatting :: SMethod Method_TextDocumentFormatting
 +  SMethod_TextDocumentRangeFormatting :: SMethod Method_TextDocumentRangeFormatting
 +  SMethod_TextDocumentOnTypeFormatting :: SMethod Method_TextDocumentOnTypeFormatting
 +  SMethod_TextDocumentRename :: SMethod Method_TextDocumentRename
 +  SMethod_TextDocumentPrepareRename :: SMethod Method_TextDocumentPrepareRename
 +  SMethod_WorkspaceExecuteCommand :: SMethod Method_WorkspaceExecuteCommand
 +  SMethod_WorkspaceApplyEdit :: SMethod Method_WorkspaceApplyEdit
 +  SMethod_WorkspaceDidChangeWorkspaceFolders :: SMethod Method_WorkspaceDidChangeWorkspaceFolders
 +  SMethod_WindowWorkDoneProgressCancel :: SMethod Method_WindowWorkDoneProgressCancel
 +  SMethod_WorkspaceDidCreateFiles :: SMethod Method_WorkspaceDidCreateFiles
 +  SMethod_WorkspaceDidRenameFiles :: SMethod Method_WorkspaceDidRenameFiles
 +  SMethod_WorkspaceDidDeleteFiles :: SMethod Method_WorkspaceDidDeleteFiles
 +  SMethod_NotebookDocumentDidOpen :: SMethod Method_NotebookDocumentDidOpen
 +  SMethod_NotebookDocumentDidChange :: SMethod Method_NotebookDocumentDidChange
 +  SMethod_NotebookDocumentDidSave :: SMethod Method_NotebookDocumentDidSave
 +  SMethod_NotebookDocumentDidClose :: SMethod Method_NotebookDocumentDidClose
 +  SMethod_Initialized :: SMethod Method_Initialized
 +  SMethod_Exit :: SMethod Method_Exit
 +  SMethod_WorkspaceDidChangeConfiguration :: SMethod Method_WorkspaceDidChangeConfiguration
 +  SMethod_WindowShowMessage :: SMethod Method_WindowShowMessage
 +  SMethod_WindowLogMessage :: SMethod Method_WindowLogMessage
 +  SMethod_TelemetryEvent :: SMethod Method_TelemetryEvent
 +  SMethod_TextDocumentDidOpen :: SMethod Method_TextDocumentDidOpen
 +  SMethod_TextDocumentDidChange :: SMethod Method_TextDocumentDidChange
 +  SMethod_TextDocumentDidClose :: SMethod Method_TextDocumentDidClose
 +  SMethod_TextDocumentDidSave :: SMethod Method_TextDocumentDidSave
 +  SMethod_TextDocumentWillSave :: SMethod Method_TextDocumentWillSave
 +  SMethod_WorkspaceDidChangeWatchedFiles :: SMethod Method_WorkspaceDidChangeWatchedFiles
 +  SMethod_TextDocumentPublishDiagnostics :: SMethod Method_TextDocumentPublishDiagnostics
 +  SMethod_SetTrace :: SMethod Method_SetTrace
 +  SMethod_LogTrace :: SMethod Method_LogTrace
 +  SMethod_CancelRequest :: SMethod Method_CancelRequest
 +  SMethod_Progress :: SMethod Method_Progress
++
 +type SServerMethod (m :: Method ServerToClient t) = SMethod m
++
 +data MessageDirection = ServerToClient | ClientToServer
++
 +data MessageKind = Notification | Request
++
++
 +type ServerNotOrReq :: forall t. Method ServerToClient t -> Type
 +data ServerNotOrReq m where
 +  IsServerNot ::
 +    ( TMessage m ~ TNotificationMessage m
 +    ) =>
 +    ServerNotOrReq (m :: Method ServerToClient Notification)
 +  IsServerReq ::
 +    forall (m :: Method ServerToClient Request).
 +    ( TMessage m ~ TRequestMessage m
 +    ) =>
 +    ServerNotOrReq m
++
 +type TMessage :: forall f t. Method f t -> Type
 +type family TMessage m where
 +  TMessage (Method_CustomMethod s :: Method f t) = ()
 +  TMessage (m :: Method f Request) = TRequestMessage m
 +  TMessage (m :: Method f Notification) = TNotificationMessage m
++
++
 +data TNotificationMessage (m :: Method f Notification) = TNotificationMessage
 +  { _method :: SMethod m
 +  , _params :: MessageParams m
 +  }
++
 +data TRequestMessage (m :: Method f Request) = TRequestMessage
++
 +type MessageParams :: forall f t . Method f t -> Type
 +type family MessageParams (m ::  Method f t) where
 +  MessageParams Method_TextDocumentPublishDiagnostics = PublishDiagnosticsParams
++
 +class MonadIO m => MonadLsp config m | m -> config where
 +  getLspEnv :: m (LanguageContextEnv config)
++
 +instance MonadLsp config (LspT config) where
 +  {-# INLINE getLspEnv #-}
 +  getLspEnv = LspT pure
++
++
 +{-# INLINE splitServerMethod #-}
 +splitServerMethod :: SServerMethod m -> ServerNotOrReq m
 +splitServerMethod = \case
 +  SMethod_TextDocumentPublishDiagnostics -> IsServerNot
 +  SMethod_WindowShowMessage -> IsServerNot
 +  SMethod_WindowShowMessageRequest -> IsServerReq
 +  SMethod_WindowShowDocument -> IsServerReq
 +  SMethod_WindowLogMessage -> IsServerNot
 +  SMethod_WindowWorkDoneProgressCreate -> IsServerReq
 +  SMethod_Progress -> IsServerNot
 +  SMethod_TelemetryEvent -> IsServerNot
 +  SMethod_ClientRegisterCapability -> IsServerReq
 +  SMethod_ClientUnregisterCapability -> IsServerReq
 +  SMethod_WorkspaceWorkspaceFolders -> IsServerReq
 +  SMethod_WorkspaceConfiguration -> IsServerReq
 +  SMethod_WorkspaceApplyEdit -> IsServerReq
 +  SMethod_LogTrace -> IsServerNot
 +  SMethod_CancelRequest -> IsServerNot
 +  SMethod_WorkspaceCodeLensRefresh -> IsServerReq
 +  SMethod_WorkspaceSemanticTokensRefresh -> IsServerReq
 +  SMethod_WorkspaceInlineValueRefresh -> IsServerReq
 +  SMethod_WorkspaceInlayHintRefresh -> IsServerReq
 +  SMethod_WorkspaceDiagnosticRefresh -> IsServerReq
++
 +fromServerNot ::
 +  forall (m :: Method ServerToClient Notification).
 +  TMessage m ~ TNotificationMessage m =>
 +  TNotificationMessage m ->
 +  FromServerMessage
 +fromServerNot m@TNotificationMessage{_method = meth} = FromServerMess meth m
++
++
 +data FromServerMessage' a where
 +  FromServerMess :: forall t (m :: Method ServerToClient t) a. SMethod m -> TMessage m -> FromServerMessage' a
 +  FromServerRsp :: forall (m :: Method ClientToServer Request) a. a m -> TResponseMessage m -> FromServerMessage' a
++
 +type FromServerMessage = FromServerMessage' SMethod
++
 +data TResponseMessage (m :: Method f Request) = TResponseMessage
++
 +sendToClient :: MonadLsp config m => FromServerMessage -> m ()
 +sendToClient msg = do
 +  f <- resSendMessage <$> getLspEnv
 +  liftIO $ f msg
 +{-# INLINE sendToClient #-}

testsuite/tests/profiling/should_compile/all.T

@@ -21,3 +21,4 @@ test('T15108', [test_opts], compile, ['-O -prof -fprof-auto'])
  test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894'])
  test('T20938', [test_opts], compile, ['-O -prof'])
  test('T26056', [test_opts], compile, ['-O -prof'])
 +test('T27121', [test_opts], compile, ['-O -prof -fprof-auto'])

testsuite/tests/simplCore/should_compile/T26941.hs

 +{-# LANGUAGE DataKinds #-}
 +{-# LANGUAGE GADTs #-}
 +{-# LANGUAGE TypeOperators #-}
++
 +module T26941 where
++
 +import GHC.TypeLits
++
 +import T26941_aux ( SMayNat(SKnown), ListH, shxHead )
++
 +shsHead :: ListH (Just n : sh) Int -> SNat n
 +shsHead shx =
 +  case shxHead shx of
 +    SKnown SNat -> SNat

testsuite/tests/simplCore/should_compile/T26941_aux.hs

 +{-# LANGUAGE DataKinds #-}
 +{-# LANGUAGE GADTs #-}
 +{-# LANGUAGE StandaloneKindSignatures #-}
 +{-# LANGUAGE TypeOperators #-}
++
 +module T26941_aux where
++
 +import Data.Kind
 +import GHC.TypeLits
++
 +shxHead :: ListH (n : sh) i -> SMayNat i n
 +shxHead list = {-# SCC "bad_scc" #-}
 +  ( case list of (i `ConsKnown` _) -> SKnown i )
++
 +type ListH :: [Maybe Nat] -> Type -> Type
 +data ListH sh i where
 +  ConsKnown :: SNat n -> ListH sh i -> ListH (Just n : sh) i
++
 +data SMayNat i n where
 +  SKnown :: SNat n -> SMayNat i (Just n)

testsuite/tests/simplCore/should_compile/all.T

@@ -576,6 +576,8 @@ test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniqu
  test('T26349',  normal, compile, ['-O -ddump-rules'])
  test('T26681',  normal, compile, ['-O'])
 +test('T26941', [extra_files(['T26941_aux.hs']), req_profiling], multimod_compile, ['T26941', '-v0 -O -prof'])
++
  # T26709: we expect three `case` expressions not four
  test('T26709', [grep_errmsg(r'case')],
         multimod_compile,