GitLab

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

Commits:

344c1fb3

by Simon Peyton Jones at 2026-03-02T11:50:04+01:00

Simplify `GHC.Core.Utils.mkTick`

Addresses #26878, by deleting code!

Fixes #26941 by no longer wrapping coercions with SCC ticks.

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

4 changed files:

compiler/GHC/Core/Utils.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

@@ -304,58 +304,58 @@ mkCast expr co
  ********************************************************************* -}
  -- | Wraps the given expression in the source annotation, dropping the
 +-- annotation if possible.  So
 +--   mkTick t e = Tick t e
 +-- except that we may optimise by pushing `t` inwards or dropping it
  mkTick :: CoreTickish -> CoreExpr -> CoreExpr
 -mkTick :: CoreTickish -> CoreExpr -> CoreExpr
 +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.
 -  -- non-counting part having laxer placement properties.
 +  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
 +  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
 +  -- mkTick' handles floating of tick `t` *into* the expression.
 +  mkTick' :: CoreExpr -> CoreExpr
 +  mkTick' expr = case expr of
      Tick t2 e
 -    Tick t2 e
 +      | ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 } <- t
 +      , ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 } <- t2
 +      ->
 +        -- If the two ticks share the same cost centre and at most one of them
 +        -- counts, then we can merge the two.
 +        if cc1 == cc2 && (not cnt1 || not cnt2)
 +        then
 +          let t' = ProfNote { profNoteCC    = cc1
 +                            , profNoteCount = cnt1 || cnt2
 +                            , profNoteScope = scope1 || scope2
 +                            }
 +          in mkTick t' expr
 +        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
+-
 -    -- 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
 +      | 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
 -      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
 +      -> 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 +363,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)
 +      | 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 +407,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

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,