GitLab

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

Commits:

b575e28a

by Simon Peyton Jones at 2026-03-12T10:50:22+01: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.

A few other changes are also implemented:

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

Fixes #26878 and #26941

Co-authored-by: sheaf <sam.derbyshire@gmail.com>

5 changed files:

compiler/GHC/Core/Utils.hs
compiler/GHC/Types/Tickish.hs
+ 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,59 +303,72 @@ mkCast expr co
  *                                                                      *
  ********************************************************************* -}
 --- | Wraps the given expression in the source annotation, dropping the
 --- annotation if possible.
 +-- | Wraps the given expression in a Tick while respecting Tick invariants,
 +-- and performing small on-the-fly optimisations.
 +--
 +-- Prefer using 'mkTick' over explicit use of the 'Tick' constructor.
 +--
 +-- Small optimisations performed:
 +--
 +--   * Minimise the AST covered by the tick, by pushing the tick deeper into
 +--     the expression if this doesn't change the semantics of the tick.
 +--     For example, push runtime relevant ticks through type applications
 +--     and type lambdas.
 +--   * 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)]
 +  stop_here e = Tick t e   -- Just wrap `t` around the current expression
 +                           -- That's the default option!
 -    -- 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
 +      | ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 } <- t
 +      , ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 } <- t2
 +      ->
 +        -- Common up ticks with a shared cost centre.
 +        -- Alas, if both ticks count, we are forced to retain both.
 +        if cc1 == cc2 && (not cnt1 || not cnt2)
 +        then
 +          let t' = ProfNote { profNoteCC    = cc1
 +                            , profNoteCount = cnt1 || cnt2
 +                            , profNoteScope = scope1 || scope2
 +                            }
 +          in mkTick t' e
 +        else
 +          -- Cost centre ticks for different cost centres should never be reordered
 +          -- relative to each other. Therefore we can stop whenever two collide.
 +          stop_here expr
++
 +      | tickishPlace t2 /= tickishPlace t
 +      -> -- Otherwise, we assume that ticks of different
 +         -- placements float through each other.
 +         Tick t2 $ mkTick' e
++
 +      -- For source note ticks, this is where we make sure to
 +      -- not introduce redundant ticks.
 +      | tickishContains t t2 -> mkTick' e  -- Drop t2
 +      | tickishContains t2 t -> expr       -- Drop t
 -    -- 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)
 +      | otherwise
 +      -> stop_here expr   -- Always safe
      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
@@ -363,26 +376,41 @@ mkTick t orig_expr = mkTick' id orig_expr
        -- 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
 +      | can_split
 +      -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e
      App f arg
        -- Always float through type applications.
        | 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)
 +      -- permitting. Again we can try splitting.
 +      | 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
++
 +    -- 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 at the 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' e) co
++
 +    -- Float ticks into 'unsafeCoerce' 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' rhs)]
      Var x
 -      | notFunction && tickishPlace t == PlaceCostCentre
 -      -> rest expr  -- Drop t
 -      | notFunction && canSplit
 -      -> Tick (mkNoScope t) $ rest expr
 +      | notFunction
 +      , tickishPlace t == PlaceCostCentre || can_split
 +      -> if tickishPlace t == PlaceCostCentre
 +         then expr -- Drop tick t entirely
 +         else Tick (mkNoScope t) expr
        where
          -- SCCs can be eliminated on variables provided the variable
          -- is not a function.  In these cases the SCC makes no difference:
@@ -392,12 +420,26 @@ mkTick t orig_expr = mkTick' id orig_expr
          -- when the function is called, so we must retain those.
          notFunction = not (isFunTy (idType x))
 -    Lit{}
 -      | tickishPlace t == PlaceCostCentre
 -      -> rest expr   -- Drop t
+-
 -    -- Catch-all: Annotate where we stand
 -    _any -> Tick t $ rest expr
 +    -- It doesn't make sense to wrap static data (such as coercions, types and literals)
 +    -- in a tick which compiles to code, as the code will never be run.
 +    --
 +    -- It is in fact actively harmful, because Core Lint will fail on a
 +    -- coercion binding such as let co = <scc> (...), see #26941.
 +    -- It makes more sense to discard the cost centre tick rather than weakening
 +    -- Core Lint.
 +    e@(Coercion {})
 +      | tickishIsCode t
 +      -> e
 +    e@(Type {})
 +      | tickishIsCode t
 +      -> e
 +    e@(Lit {})
 +      | tickishIsCode t
 +      -> e
++
 +    -- Catch-all: annotate where we stand.
 +    -- In particular (but not only): Let, most Cases.
 +    _any -> Tick t expr
  mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
  mkTicks ticks expr = foldr mkTick expr ticks

compiler/GHC/Types/Tickish.hs

@@ -261,6 +261,10 @@ 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:
@@ -451,7 +455,7 @@ data TickishPlacement =
      -- 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)`.
 +    -- type arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`.
      PlaceRuntime
      -- | As @PlaceRuntime@, but we float the tick through all

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

@@ -568,6 +568,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,