sheaf pushed to branch wip/T27261 at Glasgow Haskell Compiler / GHC Commits: cebc6fc5 by Simon Peyton Jones at 2026-05-25T11:41:51+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. - - - - - 6 changed files: - + changelog.d/T27261 - 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: ===================================== changelog.d/T27261 ===================================== @@ -0,0 +1,10 @@ +section: compiler +issues: #27261 +mrs: !16084 +synopsis: + Avoid a crash in ``mkDupableContWithDmds`` when given empty demands +description: + The case of an empty list of remaining argument demands is now explicitly + handled by trimming the simplifier continuation, to avoid a compiler crash + of the form ``Non-exhaustive patterns in dmd : cont_dmds`` or ``expectNonEmpty`` + in ``mkDupableContWithDmds``. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -62,6 +62,7 @@ import GHC.Types.Var ( isTyCoVar ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey, seqHashKey ) +import qualified GHC.Data.List.Infinite as Inf import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName ) @@ -2444,24 +2445,9 @@ rebuildCall env arg_info _cont ---------- 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 cont) ---------- Simplify type applications -------------- rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) @@ -4045,6 +4031,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`. -} -------------------- @@ -4079,10 +4100,10 @@ mkDupableCont env cont = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont mkDupableContWithDmds - :: SimplEnvIS -> [Demand] -- Demands on arguments; always infinite + :: SimplEnvIS -> RemainingArgDmds -> SimplCont -> SimplM ( SimplFloats, SimplCont) -mkDupableContWithDmds env _ cont +mkDupableContWithDmds env remaining_dmds cont -- Check the invariant | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False = pprPanic "mkDupableContWithDmds" empty @@ -4090,6 +4111,13 @@ mkDupableContWithDmds env _ cont | contIsDupable cont = return (emptyFloats env, 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] + | null remaining_dmds + = return (emptyFloats env, mkBottomCont cont) + mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) @@ -4134,7 +4162,8 @@ mkDupableContWithDmds env _ , thumbsUpPlanA cont = -- Use Plan A of Note [Duplicating StrictArg] -- pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $ - do { let _ :| dmds = expectNonEmpty $ ai_dmds fun + do { let _ :| dmds = expectNonEmpty (ai_dmds fun) -- See Invariant of StrictArg; + -- ai_dmds is never empty ; (floats1, cont') <- mkDupableContWithDmds env dmds cont -- Use the demands from the function to add the right -- demand info on any bindings we make for further args @@ -4180,7 +4209,10 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let dmd:|cont_dmds = expectNonEmpty dmds + do { let dmd:|cont_dmds = + -- We took care to handle an empty demand list at the start, + -- ensuring this call to 'expectNonEmpty' does not panic (#27261). + expectNonEmpty dmds ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; arg' <- simplArg env' Nothing hole_ty se arg arg_mco @@ -4251,7 +4283,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty ; let arg_info = ArgInfo { ai_fun = join_bndr , ai_rules = [], ai_args = [] , ai_encl = False, ai_dmds = repeat topDmd - , ai_discs = repeat 0 } + , ai_discs = Inf.repeat 0 } ; return ( addJoinFloats (emptyFloats env) $ unitJoinFloat $ NonRec join_bndr $ ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -25,13 +25,13 @@ module GHC.Core.Opt.Simplify.Utils ( StaticEnv(..), isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, contIsRhs, + contIsTrivial, contArgs, contIsRhs, mkBottomCont, hasArgs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, -- ArgInfo - ArgInfo(..), ArgSpec(..), mkArgInfo, + ArgInfo(..), ArgSpec(..), RemainingArgDmds, mkArgInfo, addValArgTo, addTyArgTo, argInfoExpr, argSpecArg, pushOutArgs, pushArgSpecs, @@ -54,8 +54,10 @@ import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) +import GHC.Core.TyCo.Compare ( eqTypeIgnoringMultiplicity ) import GHC.Core.FVs import GHC.Core.Utils +import GHC.Core.Make( mkWildValBinder ) import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make @@ -75,6 +77,8 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Name.Env +import GHC.Data.List.Infinite ( Infinite(..) ) +import qualified GHC.Data.List.Infinite as Inf import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -205,10 +209,10 @@ data SimplCont | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] { sc_dup :: DupFlag - , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + , sc_fun :: ArgInfo -- Specifies f, e1..en, whether f has rules, etc -- plus demands and discount flags for *this* arg -- and further args - -- So ai_dmds and ai_discs are never empty + -- Invariant: ai_dmds and ai_discs are never empty , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), -- presumably (arg_ty -> res_ty) -- where res_ty is expected by sc_cont @@ -348,32 +352,41 @@ doesn't matter because we'll never compute them all. data ArgInfo = ArgInfo { - ai_fun :: OutId, -- The function - ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + ai_fun :: OutId, -- ^ The function + ai_args :: [ArgSpec], -- ^ ...applied to these args (which are in *reverse* order) -- NB: all these argumennts are already simplified - ai_rules :: [CoreRule], -- Rules for this function - ai_encl :: Bool, -- Flag saying whether this function - -- or an enclosing one has rules (recursively) - -- True => be keener to inline in all args + ai_rules :: [CoreRule], -- ^ Rules for this function + ai_encl :: Bool, + -- ^ Flag saying whether this function or an enclosing one has rules + -- (recursively) + -- + -- @True@ means: be keener to inline in all args - ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) - -- Usually infinite, but if it is finite it guarantees - -- that the function diverges after being given - -- that number of args + ai_dmds :: RemainingArgDmds, + -- ^ Demands on remaining value arguments (beyond 'ai_args') - ai_discs :: [Int] -- Discounts for remaining value arguments (beyond ai_args) - -- non-zero => be keener to inline - -- Always infinite + ai_discs :: Infinite Int + -- ^ Discounts for remaining value arguments (beyond 'ai_args') + -- + -- A non-zero value means: be keener to inline } -data ArgSpec - = ValArg { as_dmd :: Demand -- Demand placed on this argument - , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal - , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) +-- | 'RemainingArgDmds' gives the demands on any remaining value arguments. +-- +-- It is usually infinite (with 'topDmd's in the tail), but if it is finite it +-- guarantees that the function diverges after being applied to that number +-- of arguments. +type RemainingArgDmds = [Demand] - | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy - , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) +data ArgSpec + -- | A value argument + = ValArg { as_dmd :: Demand -- ^ Demand placed on this argument + , as_arg :: OutExpr -- ^ Apply to this (coercion or value); c.f. 'ApplyToVal' + , as_hole_ty :: OutType } -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg') + -- | A type argument + | TyArg { as_arg_ty :: OutType -- ^ Apply to this type; c.f. 'ApplyToTy' + , as_hole_ty :: OutType } -- ^ Type of the function (presumably @t1 -> t2@ for 'ValArg' or @forall a. blah@ for 'TyArg') instance Outputable ArgInfo where ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules }) @@ -389,7 +402,7 @@ instance Outputable ArgSpec where addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo addValArgTo ai arg hole_ty - | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai + | ArgInfo { ai_dmds = dmd:dmds, ai_discs = Inf _ discs } <- ai -- Pop the top demand and and discounts off , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } = ai { ai_args = arg_spec : ai_args ai @@ -492,12 +505,23 @@ contIsDupable (TickIt _ k) = contIsDupable k contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {}) = True contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k --- This one doesn't look right. A value application is not trivial --- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k 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 contResultType (CastIt { sc_cont = k }) = contResultType k @@ -651,6 +675,35 @@ contEvalContext bndrs cont = go cont -- Perhaps reconstruct the demand on the scrutinee by looking at field -- and case binder dmds, see addCaseBndrDmd. No priority right now. +------------------- +mkBottomCont ::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 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_env = Simplified OkDup + , sc_cont = stop_cont } + where + hole_ty = contHoleType k + stop_cont = contStop k + ------------------- mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo mkArgInfo env fun rules_for_fun cont @@ -672,16 +725,17 @@ mkArgInfo env fun rules_for_fun cont fun_has_rules = not (null rules_for_fun) - vanilla_discounts, arg_discounts :: [Int] - vanilla_discounts = repeat 0 + vanilla_discounts, arg_discounts :: Infinite Int + vanilla_discounts = Inf.repeat 0 arg_discounts = case idUnfolding fun of CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} - -> discounts ++ vanilla_discounts + -> discounts Inf.++ vanilla_discounts _ -> vanilla_discounts - vanilla_dmds, arg_dmds :: [Demand] + vanilla_dmds :: RemainingArgDmds vanilla_dmds = repeat topDmd + arg_dmds :: RemainingArgDmds arg_dmds | not (seInline env) = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] @@ -689,26 +743,22 @@ mkArgInfo env fun rules_for_fun cont = -- add_type_str fun_ty $ case splitDmdSig (idDmdSig fun) of (demands, result_info) - | not (demands `lengthExceeds` n_val_args) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok - -- (see GHC.Core.Op.Simplify.Utils.analyseCont) - if isDeadEndDiv result_info then - demands -- Finite => result is bottom - else - demands ++ vanilla_dmds + | not (demands `lengthExceeds` n_val_args) + -> remaining_dmds -- Enough args, use the strictness given. | otherwise -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) <+> ppr n_val_args <+> ppr demands) $ vanilla_dmds -- Not enough args, or no strictness - add_type_strictness :: Type -> [Demand] -> [Demand] - -- If the function arg types are strict, record that in the 'strictness bits' + where + remaining_dmds :: RemainingArgDmds + -- isDeadEndDiv: if remaining_dmds is finite, result is bottom + -- See (TC1) in Note [Trimming the continuation for bottoming functions] + remaining_dmds | isDeadEndDiv result_info = demands + | otherwise = demands ++ vanilla_dmds + + add_type_strictness :: Type -> RemainingArgDmds -> RemainingArgDmds + -- If the function arg /types/ are strict, record that in the RemainingArgDmds -- No need to instantiate because unboxed types (which dominate the strict -- types) can't instantiate type variables. -- add_type_strictness is done repeatedly (for each call); @@ -915,16 +965,16 @@ the incentive to disappear when we inline `f`! lazyArgContext :: ArgInfo -> CallCtxt -- Use this for lazy arguments lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting + | encl_rules = RuleArgCtxt + | Inf disc _ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting strictArgContext :: ArgInfo -> CallCtxt strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) -- Use this for strict arguments - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = RhsCtxt NonRecursive + | encl_rules = RuleArgCtxt + | Inf disc _ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = RhsCtxt NonRecursive -- Why RhsCtxt? if we see f (g x), and f is strict, we -- want to be a bit more eager to inline g, because it may -- expose an eval (on x perhaps) that can be eliminated or ===================================== 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 ===================================== @@ -601,3 +601,4 @@ test('T25718a', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) +test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cebc6fc598a90471c6a563fdd65eafdd... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cebc6fc598a90471c6a563fdd65eafdd... You're receiving this email because of your account on gitlab.haskell.org.