Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: cbe4300e by Simon Peyton Jones at 2026-02-05T04:31:04-05:00 Fix subtle bug in GHC.Core.Utils.mkTick This patch fixes a decade-old bug in `mkTick`, which could generate type-incorrect code! See the diagnosis in #26772. The new code is simpler and easier to understand. (As #26772 says, I think it could be improved further.) - - - - - a193a8da by Simon Peyton Jones at 2026-02-05T04:31:04-05:00 Modify a debug-trace in the Simplifier ...just to show a bit more information. - - - - - b579dfdc by Simon Peyton Jones at 2026-02-05T04:31:04-05:00 Fix long-standing interaction between ticks and casts The code for Note [Eliminate Identity Cases] was simply wrong when ticks and casts interacted. This patch fixes the interaction. It was shown up when validating #26772, although it's not the exactly the bug that's reported by #26772. Nor is it easy to reproduce, hence no regression test. - - - - - 9 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Evidence.hs - testsuite/tests/ghci.debugger/scripts/T26042b.stdout - testsuite/tests/ghci.debugger/scripts/T26042c.stdout - testsuite/tests/ghci.debugger/scripts/T26042d2.stdout - testsuite/tests/ghci.debugger/scripts/T26042f2.stdout Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1713,6 +1713,7 @@ simplCast env body co0 cont0 , sc_hole_ty = coercionLKind co }) } -- NB! As the cast goes past, the -- type of the hole changes (#16312) + -- (f |> co) e ===> (f (e |> co1)) |> co2 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 @@ -1838,7 +1839,7 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] not (exprIsTrivial arg) && not (isDeadOcc (idOccInfo bndr)) ) - -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $ + -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> text ":=" <+> ppr arg $$ ppr (seIdSubst env)) $ tick (PreInlineUnconditionally bndr) ; simplLam env' body cont } ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Types.Tickish import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Types.Name.Env import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -81,9 +82,9 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic -import Control.Monad ( when ) +import Control.Monad ( guard, when ) import Data.List ( sortBy ) -import GHC.Types.Name.Env +import Data.Maybe import Data.Graph {- ********************************************************************* @@ -2570,7 +2571,27 @@ Note [Eliminate Identity Case] True -> True; False -> False -and similar friends. +and similar friends. There are some tricky wrinkles: + +(EIC1) Casts. We've seen this: + case e of x { _ -> x `cast` c } + And we definitely want to eliminate this case, to give + e `cast` c +(EIC2) Ticks. Similarly + case e of x { _ -> Tick t x } + At least if the tick is 'floatable' we want to eliminate the case + to give + Tick t e + +So `check_eq` strips off enclosing casts and ticks from the RHS of the +alternative, returning a wrapper function that will rebuild them around +the scrutinee if case-elim is successful. + +(EIC3) What if there are many alternatives, all identities. If casts + are involved they must be the same cast, to make the types line up. + In principle there could be different ticks in each RHS, but we just + pick the ticks from the first alternative. (In the common case there + is only one alternative.) Note [Scrutinee Constant Folding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2764,45 +2785,47 @@ mkCase mode scrut outer_bndr alts_ty alts -- See Note [Eliminate Identity Case] -------------------------------------------------- -mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case - | all identity_alt alts +mkCase1 _mode scrut case_bndr _ (alt1 : alts) -- Identity case + | Just wrap <- identity_alt alt1 -- `wrap`: see (EIC1) and (EIC2) + , all (isJust . identity_alt) alts -- See (EIC3) in Note [Eliminate Identity Case] = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } + ; return (wrap scrut) } where - ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts' - identity_alt (Alt con args rhs) = check_eq rhs con args - - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args - - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False + identity_alt :: CoreAlt -> Maybe (CoreExpr -> CoreExpr) + identity_alt (Alt con args rhs) = check_eq con args rhs + + check_eq :: AltCon -> [Var] -> CoreExpr -> Maybe (CoreExpr -> CoreExpr) + -- (check_eq con args e) return True if + -- e looks like (Tick (Cast (Tick (con args)))) + -- where (con args) is the LHS of the alternative + -- In that case it returns (\e. Tick (Cast (Tick e))), + -- a wrapper function that can rebuild the tick/cast stuff + -- See (EIC1) and (EIC2) in Note [Eliminate Identity Case] + check_eq alt_con args (Cast e co) -- See (EIC1) + = do { guard (not (any (`elemVarSet` tyCoVarsOfCo co) args)) + ; wrap <- check_eq alt_con args e + ; return (flip mkCast co . wrap) } + check_eq alt_con args (Tick t e) -- See (EIC2) + = do { guard (tickishFloatable t) + ; wrap <- check_eq alt_con args e + ; return (Tick t . wrap) } + check_eq alt_con args e + | is_id alt_con args e = Just (\e -> e) + | otherwise = Nothing + + is_id :: AltCon -> [Var] -> CoreExpr -> Bool + is_id _ _ (Var v) | v == case_bndr = True + is_id (LitAlt lit') _ (Lit lit) = lit == lit' + is_id (DataAlt con) args rhs + | Var v <- rhs -- Optimisation only + , null arg_tys + , null args = v == dataConWorkId con + | otherwise = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + is_id _ _ _ = False arg_tys = tyConAppArgs (idType case_bndr) - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut - mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -252,7 +252,7 @@ applyTypeToArgs op_ty args mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr mkCastMCo e MRefl = e -mkCastMCo e (MCo co) = Cast e co +mkCastMCo e (MCo co) = mkCast e co -- We are careful to use (MCo co) only when co is not reflexive -- Hence (Cast e co) rather than (mkCast e co) @@ -305,40 +305,41 @@ mkCast expr co -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id id orig_expr +mkTick t orig_expr = mkTick' id 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 + -- mkTick' handles floating of ticks *into* the expression. - -- In this function, `top` is applied after adding the tick, and `rest` before. - -- This will result in applications that look like (top $ Tick t $ rest expr). - -- If we want to push the tick deeper, we pre-compose `top` with a function - -- adding the tick. - mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) - -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) - -> CoreExpr -- current expression + mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) + -- Always a composition of (Tick t) wrappers + -> CoreExpr -- Current expression -> CoreExpr - mkTick' top rest expr = case expr of + -- 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 - -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs + -> 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. Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr -- Otherwise we assume that ticks of different placements float -- through each other. - | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + | 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' top rest e - | tickishContains t2 t -> orig_expr - | otherwise -> mkTick' top (rest . Tick t2) e + | 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 @@ -346,14 +347,14 @@ mkTick t orig_expr = mkTick' id id orig_expr -- 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 -> mkTick' (top . flip Cast co) rest e - Coercion co -> Coercion co + Cast e co -> mkCast (mkTick' rest e) co + Coercion co -> Tick t $ rest (Coercion co) 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 - -> mkTick' (top . Lam x) rest e + -> Lam x $ mkTick' rest 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 @@ -362,25 +363,25 @@ mkTick t orig_expr = mkTick' id id orig_expr -- floated, and the lambda may then be in a position to be -- beta-reduced. | canSplit - -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e App f arg -- Always float through type applications. | not (isRuntimeArg arg) - -> mkTick' (top . flip App arg) rest f + -> App (mkTick' rest f) arg -- We can also float through constructor applications, placement -- permitting. Again we can split. | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) -> if tickishPlace t == PlaceCostCentre - then top $ rest $ tickHNFArgs t expr - else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then rest $ tickHNFArgs t expr + else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr Var x | notFunction && tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t | notFunction && canSplit - -> top $ Tick (mkNoScope t) $ rest expr + -> 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: @@ -392,10 +393,10 @@ mkTick t orig_expr = mkTick' id id orig_expr Lit{} | tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t -- Catch-all: Annotate where we stand - _any -> top $ Tick t $ rest expr + _any -> Tick t $ rest expr mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -49,6 +49,7 @@ import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core.Utils( mkCast ) import GHC.Core ( Expr(..), mkConApp ) import GHC.StgToCmm.Closure ( isSmallFamily ) @@ -455,7 +456,7 @@ matchWithDict [cls_ty, mty] = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ Var k `App` (evUnaryDictAppE cls dict_args meth_arg) where - meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr) + meth_arg = Var sv `mkCast` mkSubCo (evExprCoercion ev_expr) ; let mk_ev [c] = evDictApp wd_cls [cls_ty, mty] [evWithDict c] mk_ev e = pprPanic "matchWithDict" (ppr e) @@ -657,7 +658,7 @@ matchDataToTag dataToTagClass [levity, dty] = do (mkReflCo Representational intPrimTy) -> do { addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3 ; let mk_ev _ = evDictApp dataToTagClass [levity, dty] $ - [methodRep `Cast` methodCo] + [methodRep `mkCast` methodCo] ; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.) , cir_mk_ev = mk_ev , cir_canonical = EvCanonical ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Tc.Utils.TcType import GHC.Core import GHC.Core.Coercion.Axiom import GHC.Core.Coercion +import GHC.Core.Utils( mkCast ) import GHC.Core.Ppr () -- Instance OutputableBndr TyVar import GHC.Core.Predicate import GHC.Core.Type @@ -930,7 +931,7 @@ evCastE ee co | assertPpr (coercionRole co == Representational) (vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $ isReflCo co = ee - | otherwise = Cast ee co + | otherwise = mkCast ee co evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm -- Dictionary instance application, including when the "dictionary function" ===================================== testsuite/tests/ghci.debugger/scripts/T26042b.stdout ===================================== @@ -22,30 +22,18 @@ _result :: -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, Int #) = _ Stopped in Main.foo, T26042b.hs:14:3-18 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ 13 y = 4 14 n <- bar (x + y) ^^^^^^^^^^^^^^^^ 15 return n -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ Stopped in Main.main, T26042b.hs:5:3-26 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 4 main = do 5 a <- foo False undefined ^^^^^^^^^^^^^^^^^^^^^^^^ 6 print a -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 14 14 ===================================== testsuite/tests/ghci.debugger/scripts/T26042c.stdout ===================================== @@ -1,18 +1,12 @@ Breakpoint 0 activated at T26042c.hs:10:15-22 Stopped in Main.foo, T26042c.hs:10:15-22 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ 9 foo :: Bool -> Int -> IO Int 10 foo True i = return i ^^^^^^^^ 11 foo False _ = do Stopped in Main.main, T26042c.hs:5:3-26 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 4 main = do 5 a <- foo False undefined ^^^^^^^^^^^^^^^^^^^^^^^^ ===================================== testsuite/tests/ghci.debugger/scripts/T26042d2.stdout ===================================== @@ -1,10 +1,7 @@ Breakpoint 0 activated at T26042d2.hs:11:3-21 hello1 Stopped in Main.f, T26042d2.hs:11:3-21 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 10 f = do 11 putStrLn "hello2.1" ^^^^^^^^^^^^^^^^^^^ ===================================== testsuite/tests/ghci.debugger/scripts/T26042f2.stdout ===================================== @@ -1,6 +1,6 @@ Breakpoint 0 activated at T26042f.hs:(20,7)-(21,14) Stopped in T8.t, T26042f.hs:(20,7)-(21,14) -_result :: Int = _ +_result :: Identity Int = _ x :: Int = 450 19 t :: Int -> Identity Int vv @@ -18,12 +18,12 @@ _result :: Identity Int = _ ^^^^^^^^^^^^ 15 n <- pure (a+a) Stopped in T8.f, T26042f.hs:8:3-14 -_result :: Identity Int = _ +_result :: Int = _ x :: Int = 15 7 f x = do 8 b <- g (x*x) ^^^^^^^^^^^^ 9 y <- pure (b+b) x :: Int = 15 -_result :: Identity Int = _ +_result :: Int = _ 7248 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea0d1317a630799a6b7bea12b24ef7e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea0d1317a630799a6b7bea12b24ef7e... You're receiving this email because of your account on gitlab.haskell.org.