Zubin pushed to branch wip/26416 at Glasgow Haskell Compiler / GHC Commits: c7831beb by Zubin Duggal at 2026-02-10T16:03:05+05:30 disable absence - - - - - 3af454f3 by Zubin Duggal at 2026-02-10T16:03:05+05:30 DmdAnal: Don't give an absent demand signature to an argument if the argument doesn't also have an absent demand signature in its unfolding. Otherwise, in some cases we might mark an argument as absent and generate a LitRubbish for it, but then the function might inline and turn out to actually use this argument, resulting in a run time crash. Partially addresses #26416. There may still be cases where an absent argument turns out to be used due to a rule firing. - - - - - d3d265ad by Zubin Duggal at 2026-02-10T16:03:05+05:30 wip - - - - - c40d2ae3 by Zubin Duggal at 2026-02-10T16:03:21+05:30 Revert "disable absence" This reverts commit c7831beb636df350d0fabb728bb0d11df555ad1e. - - - - - 5 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Types/Demand.hs - + testsuite/tests/dmdanal/should_run/M1.hs - + testsuite/tests/dmdanal/should_run/T26416.hs - testsuite/tests/dmdanal/should_run/all.T Changes: ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -23,7 +23,7 @@ import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type -import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) +import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds, idRuleVars ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.TyCo.Compare ( eqType ) @@ -1106,8 +1106,18 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs DmdType rhs_env rhs_dmds = rhs_dmd_ty + + -- See Note [Absence analysis for stable unfoldings and RULES] + -- If there's a stable unfolding, we need to combine argument demands + -- from the unfolding with those from the RHS, because the unfolding + -- might use arguments that the (optimised) RHS doesn't. + -- Any argument with a demand absent in one but not the other can + -- be problematic, see #26416 + -- Also combine the DmdEnv (free variables) from the unfolding + (unf_fv_env, combined_rhs_dmds) = combineUnfoldingDmds env rhs_sd id rhs_env rhs_dmds + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity - rhs_dmds (de_div rhs_env) rhs' + combined_rhs_dmds (de_div rhs_env) rhs' dmd_sig_arity = ww_arity + strictCallArity body_sd sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds) @@ -1135,7 +1145,10 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs NonRecursive -> rhs_env -- See Note [Absence analysis for stable unfoldings and RULES] - rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id) + -- The unfolding FVs are handled via unf_fv_env from combineUnfoldingDmds. + -- Here we only need demandRoots for RULES. + rhs_env2 = rhs_env1 `plusDmdEnv` unf_fv_env + `plusDmdEnv` demandRootSet env (idRuleVars id) -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 @@ -1144,6 +1157,31 @@ splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs +-- | If there is a stable unfolding, combine argument demands and free variable +-- demands from the unfolding with those from the RHS. +-- See Note [Absence analysis for stable unfoldings and RULES], Wrinkle (W3). +-- +-- Returns (combined DmdEnv for free variables, combined arg demands) +-- The DmdEnv is nopDmdEnv if there's no stable unfolding. +combineUnfoldingDmds :: AnalEnv -> SubDemand -> Id -> DmdEnv -> [Demand] -> (DmdEnv, [Demand]) +combineUnfoldingDmds env rhs_sd id rhs_fv_env rhs_dmds + | not (isStableUnfolding unf) + = (nopDmdEnv, rhs_dmds) -- No stable unfolding, nothing to do + + | Just unf_body <- maybeUnfoldingTemplate unf + , let WithDmdType (DmdType unf_fv_env unf_dmds) _ = dmdAnal env rhs_sd unf_body + , let combined_dmds = go rhs_dmds unf_dmds + -- Lub the free variable demands from unfolding with RHS + combined_fv_env = lubDmdEnv rhs_fv_env unf_fv_env + = -- pprTrace "combineUnfoldingDmds" (ppr id $$ ppr rhs_dmds $$ ppr unf_dmds $$ ppr combined_dmds) $ + (combined_fv_env, combined_dmds) + | otherwise = (nopDmdEnv, rhs_dmds) + where + unf = realIdUnfolding id + go rhs [] = rhs + go [] _ = [] + go (r:rhs) (u:unfs) = lubUBglbLBDmd r u : go rhs unfs + -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type @@ -1523,6 +1561,34 @@ Wrinkles: for `sg`, failing to unleash the signature and hence observed an absent error instead of the `really important message`. + (W3) The SOLUTION above handles /free variables/ of stable unfoldings, but + what about /arguments/? Consider (#26416) + + fromVector :: (Storable a, KnownNat n) => Vector a -> Vector a + fromVector v = ... (uses Storable dictionary) ... + {-# INLINABLE fromVector #-} + + Suppose that the optimised RHS of `fromVector` somehow discards the use of + the Storable dictionary, but the stable unfolding still uses it. Then the + demand signature will say that the Storable dictionary argument is absent, + and worker/wrapper will replace it with `LitRubbish`. But when the + worker's unfolding is inlined, it will use that rubbish value as a real + dictionary, leading to a segfault! + + SOLUTION: in `dmdAnalRhsSig`, if the function has a stable unfolding, + analyse it with `dmdAnal` and combine the resulting `DmdType` with the + RHS's `DmdType`. This is done by `combineUnfoldingDmds`, which: + + * For argument demands: combines them using `lubUBglbLBDmd`, which takes + the glb (max) of lower bounds (strictness) and lub (max) of upper + bounds (usage). See Note [Combining demands for stable unfoldings]. + This ensures that if the unfolding uses an argument, it won't be + marked as absent, while preserving any strictness the RHS reveals. + + * For free variable demands: combines them using `lubDmdEnv`. This + replaces the `demandRoots` approach for stable unfoldings (though + we still use `demandRoots` for RULES via `idRuleVars`). + Note [DmdAnal for DataCon wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We give DataCon wrappers a (necessarily flat) demand signature in @@ -2046,8 +2112,11 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs arg_triples :: [(Type, StrictnessMark, Demand)] arg_triples = take ww_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] + zipWith mk_triple + [ bndr | bndr <- bndrs, isRuntimeVar bndr ] + arg_dmds + where + mk_triple bndr dmd = (idType bndr, NotMarkedStrict, get_dmd dmd) arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds) -- If ww_arity < length arg_dmds, the leftover ones @@ -2063,12 +2132,10 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs -- This is the budget initialisation step of -- Note [Worker argument budget] - get_dmd :: Id -> Demand - get_dmd bndr + get_dmd :: Demand -> Demand + get_dmd dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -23,6 +23,8 @@ module GHC.Types.Demand ( lubCard, lubDmd, lubSubDmd, -- *** Greatest lower bound glbCard, + -- *** Unfolding combination (glb on strictness, lub on usage) + lubUBglbLBDmd, -- *** Plus plusCard, plusDmd, plusSubDmd, -- *** Multiply @@ -49,7 +51,7 @@ module GHC.Types.Demand ( -- * Demand environments DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs, - multDmdEnv, reuseEnv, + lubDmdEnv, multDmdEnv, reuseEnv, -- * Demand types DmdType(..), dmdTypeDepth, @@ -864,6 +866,77 @@ lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 -- Otherwise (Call `lub` Prod) return Top lubSubDmd _ _ = topSubDmd +{- Note [Combining demands for stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a function has a stable unfolding, the optimised RHS and the unfolding +may have different demand signatures for the same arguments. This can happen +because: + + * The optimised RHS may have had transformations applied that reveal + strictness (e.g., inlining exposes a case on an argument). + + * The optimised RHS may have had transformations applied that drop usage + (e.g., a rewrite rule fires that doesn't use an argument, or a seq on + a dictionary is dropped because dictionaries are known to terminate). + +When we inline the stable unfolding at a call site, we get the unfolding's +behaviour, not the RHS's. So we must be conservative and combine the demands: + + * For strictness (lower bounds): we can take the MAXIMUM (glb). + If the RHS reveals that an argument is strict, that strictness was + always there semantically - the analysis just couldn't see it in the + unfolding. Sound optimisations never make lazy code strict. + + * For usage (upper bounds): we must take the MAXIMUM (lub). + If the unfolding uses an argument but the RHS doesn't, we must not + mark it absent, or we'll replace it with rubbish that the unfolding + will then try to use, causing a segfault. See #26416. + +So for cardinality bounds [l1..u1] from RHS and [l2..u2] from unfolding, +we compute [max(l1,l2)..max(u1,u2)]. + +See Note [Absence analysis for stable unfoldings and RULES] in GHC.Core.Opt.DmdAnal +for the broader context. +-} + +-- | Combine demands for stable unfolding analysis. +-- See Note [Combining demands for stable unfoldings]. +lubUBglbLBCard :: Card -> Card -> Card +-- Given Note [Bit vector representation for Card]: +-- * bit 0 (strictness): take AND (glb) - 0 means strict, so 0 wins +-- * bits 1,2 (usage): take OR (lub) - if either uses, result uses +lubUBglbLBCard (Card a) (Card b) = Card ((a .&. b .&. 0b001) .|. ((a .|. b) .&. 0b110)) + +-- | See Note [Combining demands for stable unfoldings]. +lubUBglbLBDmd :: Demand -> Demand -> Demand +lubUBglbLBDmd BotDmd dmd2 = dmd2 +lubUBglbLBDmd dmd1 BotDmd = dmd1 +lubUBglbLBDmd (n1 :* sd1) (n2 :* sd2) = + lubUBglbLBCard n1 n2 :* lubUBglbLBSubDmd sd1 sd2 + +lubUBglbLBSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Shortcuts for neutral and absorbing elements. +lubUBglbLBSubDmd (Poly Unboxed C_10) sd = sd +lubUBglbLBSubDmd sd (Poly Unboxed C_10) = sd +lubUBglbLBSubDmd sd@(Poly Boxed C_0N) _ = sd +lubUBglbLBSubDmd _ sd@(Poly Boxed C_0N) = sd +-- Prod +lubUBglbLBSubDmd (Prod b1 ds1) (Poly b2 n2) + | let !d = polyFieldDmd b2 n2 + = mkProd (lubBoxity b1 b2) (strictMap (lubUBglbLBDmd d) ds1) +lubUBglbLBSubDmd (Prod b1 ds1) (Prod b2 ds2) + | equalLength ds1 ds2 + = mkProd (lubBoxity b1 b2) (strictZipWith lubUBglbLBDmd ds1 ds2) +-- Handle Call +lubUBglbLBSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (lubUBglbLBCard n1 n2) (lubUBglbLBSubDmd sd1 sd2) +-- Handle Poly +lubUBglbLBSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubUBglbLBCard n1 n2) +-- Other Poly case by commutativity +lubUBglbLBSubDmd sd1@Poly{} sd2 = lubUBglbLBSubDmd sd2 sd1 +-- Otherwise (Call `lubUBglbLB` Prod) return Top +lubUBglbLBSubDmd _ _ = topSubDmd + -- | Denotes '+' on 'Demand'. plusDmd :: Demand -> Demand -> Demand plusDmd AbsDmd dmd2 = dmd2 ===================================== testsuite/tests/dmdanal/should_run/M1.hs ===================================== @@ -0,0 +1,17 @@ +-- Short module name is essential, or else f doesn't inline +module M1 where +{-# INLINABLE [2] f #-} +f :: Int -> Int -> Float +f !dummy x = if times dummy 0 x == 1 + then 3.0 else 4.0 + +{-# INLINE [0] times #-} +times :: Int -> Int -> Int -> Int +times dummy 0 x = x `seq` ( 0 + big dummy ) +times _ a b = a * b + +{-# RULES "times" [1] forall dummy x. times dummy 0 x = 0 + big dummy #-} + +big :: Int -> Int +big x = succ . succ . succ . succ . succ . succ . succ . succ . succ $ x +{-# INLINE big #-} ===================================== testsuite/tests/dmdanal/should_run/T26416.hs ===================================== @@ -0,0 +1,3 @@ +module Main where +import M1 ( f ) +main = print (f 19 12) ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -34,3 +34,4 @@ test('T22475b', normal, compile_and_run, ['']) test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise']) test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208']) test('T25439', normal, compile_and_run, ['']) +test('T26416', normal, multimod_compile_and_run, ['T26416','M1.hs']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b5979c2091d736c2f49f6520d85cab... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b5979c2091d736c2f49f6520d85cab... You're receiving this email because of your account on gitlab.haskell.org.