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
- - - - -
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
=====================================
@@ -0,0 +1,14 @@
+{-# 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
=====================================
@@ -0,0 +1,20 @@
+{-# 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,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b575e28afb5d1dab8e25174454644094...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b575e28afb5d1dab8e25174454644094...
You're receiving this email because of your account on gitlab.haskell.org.
