sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC Commits: d45e6b52 by Simon Peyton Jones at 2026-03-11T19:53:27+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,24 @@ mkTick t orig_expr = mkTick' id orig_expr -- when the function is called, so we must retain those. notFunction = not (isFunTy (idType x)) + Coercion co + -- Make sure to drop SCCs around coercions, to avoid generating Core + -- of the form 'let co = scc<foo> <Int>_N' (which Core Lint isn't happy with). + -- See #26941. + | tickishPlace t == PlaceCostCentre + -> Coercion co -- Drop tick t entirely + | can_split + -> Tick (mkNoScope t) expr + Lit{} | tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t + -> expr -- Drop tick t entirely + | can_split + -> Tick (mkNoScope t) expr - -- Catch-all: Annotate where we stand - _any -> Tick t $ rest expr + -- Catch-all: Annotate where we stand. + -- Used for Type, 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/d45e6b52f4cc31c96b918f0a0e0ab89b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d45e6b52f4cc31c96b918f0a0e0ab89b... You're receiving this email because of your account on gitlab.haskell.org.