Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 8725aa42 by mangoiv at 2026-05-29T13:33:44+02:00 Trim the continuation in mkDupableContWithDmds When there are no remaining argument demands, it means the application is bottoming. In this case, we can trim the continuation to avoid the panic that was observed in #27261. See Note [Trimming the continuation for bottoming functions] in GHC.Core.Opt.Simplify.Iteration. This patch was rewritten to avoid pulling in a refactor. The original patch is included in master as 4a645683ee0bd4421a88cd6ec49b40c6046b041d - - - - - 5 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - + testsuite/tests/simplCore/should_compile/T27261.hs - + testsuite/tests/simplCore/should_compile/T27261_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -24,7 +24,7 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) ) -import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) import GHC.Core.Reduction @@ -2293,24 +2293,14 @@ rebuildCall :: SimplEnv -> ArgInfo -> SimplCont ---------- Bottoming applications -------------- rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont + -- When we run out of demands, it means that the call is definitely bottom. + -- See (TC2) in Note [Trimming the continuation for bottoming functions] + = rebuild env (argInfoExpr fun rev_args) (mkBottomCont env cont) + -- NOTE(mangoiv): the env passed to mkBottomCont is only relevant for its static part + -- and should not be looked at whatsoever, which is why it should be fine to pass it + -- this way. The reason why we deviate from the original patch is that it was done + -- after a significant refactor we cannot backport. + -- The original patch should be included in `master` as 4a645683ee0bd4421a88cd6ec49b40c6046b041d ---------- Try inlining, if ai_rewrite = TryInlining -------- -- In the TryInlining case we try inlining immediately, before simplifying @@ -3813,6 +3803,41 @@ When we have then we can just duplicate those alts because the A and C cases will disappear immediately. This is more direct than creating join points and inlining them away. See #4930. + +Note [Trimming the continuation for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + f :: Int -> Int -> Int + f x = error "urk" + + foo = f 3 4 + +f's demand signature say "after one arg I return bottom". We can drop +the remaining arguments, thus + + foo = case f 3 of {} + +This trimming can also be done with other continuations: + * case (error "hello") of { ... } + * f (error "Hello") where f is strict + etc + +We implement the trimming in three parts: + +(TC1) In `mkArgInfo`, for a bottoming function, we make a list of `RemainingArgDmds` + with a finite list of elements (in the example above, just one). + + For comparison, note that, for non-bottoming functions, the `RemainingArgDmds` + always finishes with an infinite list of `topDmd`. + +(TC2) In `rebuildCall`, when we run out of `RemainingArgDmds` we discard the + remaining continuation. + + After discarding the continuation, the types might not match, in which case + we leave behind a (case <hole> of {}) wrapper. See the call to `mkBottomCont`. + +(TC3) In `mkDupableContWithDmds`, we similarly discard the continuation when + we run out of `RemainingArgDmds`. -} -------------------- @@ -3931,7 +3956,7 @@ mkDupableContWithDmds env dmds ; return (floats, ApplyToTy { sc_cont = cont' , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } -mkDupableContWithDmds env dmds +mkDupableContWithDmds env (dmd : cont_dmds) (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se , sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) @@ -3939,8 +3964,7 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:cont_dmds) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont + do { (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' @@ -3954,6 +3978,12 @@ mkDupableContWithDmds env dmds -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_dup = OkToDup, sc_cont = cont' , sc_hole_ty = hole_ty }) } +mkDupableContWithDmds env dmds cont + -- No more demands => function is definitely bottom + -- => simply trim the continuation + -- c.f. the null-demands case in `rebuildCall` + -- See (TC3) in Note [Trimming the continuation for bottoming functions] + | [] <- dmds = return (emptyFloats env, mkBottomCont env cont) mkDupableContWithDmds env _ (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Core.Opt.Simplify.Utils ( SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, contIsRhs, + contIsTrivial, contArgs, contIsRhs, mkBottomCont, countArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -87,6 +87,8 @@ import Control.Monad ( guard, when ) import Data.List ( sortBy ) import Data.Maybe import Data.Graph +import GHC.Core.TyCo.Compare (eqTypeIgnoringMultiplicity) +import GHC.Core.Make (mkWildValBinder) {- ********************************************************************* * * @@ -505,6 +507,20 @@ contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial contIsTrivial (CastIt { sc_cont = k }) = contIsTrivial k contIsTrivial _ = False +------------------- +contStop :: SimplCont -> SimplCont +-- ^ Get the 'Stop' at the tail of the continuation +-- +-- Always returns a continuation of form @(Stop ...)@. +contStop stop@(Stop {}) = stop +contStop (CastIt { sc_cont = k }) = contStop k +contStop (StrictBind { sc_cont = k }) = contStop k +contStop (StrictArg { sc_cont = k }) = contStop k +contStop (Select { sc_cont = k }) = contStop k +contStop (ApplyToTy { sc_cont = k }) = contStop k +contStop (ApplyToVal { sc_cont = k }) = contStop k +contStop (TickIt _ k) = contStop k + ------------------- contResultType :: SimplCont -> OutType contResultType (Stop ty _ _) = ty @@ -623,6 +639,37 @@ contEvalContext k = case k of -- Perhaps reconstruct the demand on the scrutinee by looking at field -- and case binder dmds, see addCaseBndrDmd. No priority right now. +------------------- +mkBottomCont ::StaticEnv -> SimplCont -> SimplCont +-- ^ Given a continuation `cont`, return a `cont` /of the same type/, +-- looking like @(case \ of {})@. +-- +-- This is used when we are going to fill in the @<hole>@ with bottom. +-- See (TC2,3) in Note [Trimming the continuation for bottoming functions] +-- +-- Don't bother to trim, making a @case <hole> of {}@, if we have only +-- an essentially-trivial continuation; e.g. @(<hole> \@ty |> co)@. +mkBottomCont se cont = go cont + where + go k@(Stop {}) = k + go (TickIt t k') = TickIt t (go k') + go k@(CastIt { sc_cont = k' }) = k { sc_cont = go k' } + go k@(ApplyToTy { sc_cont = k' }) = k { sc_cont = go k' } + go k@(Select { sc_alts = [], sc_cont = Stop {} }) = k -- Optimisation only + go k | Stop res_ty _ _ <- stop_cont + , hole_ty `eqTypeIgnoringMultiplicity` res_ty + = stop_cont + | otherwise + = Select { sc_alts = [] + , sc_bndr = mkWildValBinder OneTy hole_ty + , sc_dup = OkToDup + , sc_env = se + , sc_cont = stop_cont } + where + hole_ty = contHoleType k + stop_cont = contStop k + + ------------------- mkArgInfo :: SimplEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo ===================================== testsuite/tests/simplCore/should_compile/T27261.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-full-laziness #-} + +module T27261 (foo) where + +import T27261_aux (myError) + +foo :: [String] -> (() -> Int) -> Int +foo cs = + \ k -> ( case bar of + Just str -> let cs2 = case cs of { [] -> cs; _ -> "stack entry" : cs } + in myError cs2 str + Nothing -> \ c -> c () ) + ( \ _ -> k () ) + +bar :: Maybe String +bar = Nothing +{-# NOINLINE bar #-} ===================================== testsuite/tests/simplCore/should_compile/T27261_aux.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE BangPatterns #-} + +module T27261_aux (myError) where + +myError :: [String] -> String -> a +myError !_ _ = undefined +{-# NOINLINE myError #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -541,3 +541,4 @@ test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, [ test('T26681', normal, compile, ['-O']) test('T26903', [grep_errmsg(r'reverse')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques -dsuppress-all']) test('T26682', normal, multimod_compile, ['T26682', '-O -v0']) +test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8725aa42c3349c2c1bd51e7419454a98... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8725aa42c3349c2c1bd51e7419454a98... You're receiving this email because of your account on gitlab.haskell.org.