Zubin pushed to branch wip/27626 at Glasgow Haskell Compiler / GHC Commits: 876bc4ee by Zubin Duggal at 2026-08-13T13:24:15+05:30 DmdAnal: Fix maxDmdType We need to eta expand the smaller DmdType using defaultArgDmd, like in lubDmdType. Introduce zipDmdType as a common combinator to implement both maxDmdType and lubDmdType uniformly. fixes #27626 - - - - - 6 changed files: - + changelog.d/27626 - compiler/GHC/Types/Demand.hs - + testsuite/tests/dmdanal/should_run/M2.hs - + testsuite/tests/dmdanal/should_run/T27626.hs - + testsuite/tests/dmdanal/should_run/T27626.stdout - testsuite/tests/dmdanal/should_run/all.T Changes: ===================================== changelog.d/27626 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a bug where an argument used only by a function's stable unfolding + could still be marked absent, resulting in a runtime crash. +mrs: !16503 +issues: #27626 ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1849,12 +1849,14 @@ botDmdEnv = mkEmptyDmdEnv botDiv exnDmdEnv :: DmdEnv exnDmdEnv = mkEmptyDmdEnv exnDiv +combineDmdEnv :: (Demand -> Demand -> Demand) -> DmdEnv -> DmdEnv -> DmdEnv +combineDmdEnv f (DE fv1 d1) (DE fv2 d2) + -- See Note [Demand env Equality] + = DE (plusVarEnv_CD f fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)) + (lubDivergence d1 d2) + lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div - where - -- See Note [Demand env Equality] - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - lub_div = lubDivergence d1 d2 +lubDmdEnv = combineDmdEnv lubDmd addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv addVarDmdEnv env@(DE fvs div) id dmd @@ -1908,36 +1910,31 @@ instance Eq DmdType where = ds1 == ds2 -- cheap checks first && env1 == env2 +-- | The smaller 'DmdType' is eta expanded using its 'defaultArgDmd'. +-- See Note [Default demand on free variables and arguments]. +zipDmdType :: (Demand -> Demand -> Demand) -> DmdType -> DmdType -> DmdType +zipDmdType f (DmdType fv1 ds1) (DmdType fv2 ds2) + = DmdType (combineDmdEnv f fv1 fv2) (go ds1 ds2) + where + def1, def2 :: Demand -- Default argument demands for eta expansion + def1 = defaultArgDmd (de_div fv1) + def2 = defaultArgDmd (de_div fv2) + + -- If `ds1` is shorter than `ds2`, extend `ds1` with the appropriate + -- default demand `def1`; and similarly if `ds2` is shorter + go (d1:ds1') (d2:ds2') = f d1 d2 : go ds1' ds2' + go [] ds2' = map (def1 `f`) ds2' + go ds1' [] = map (`f` def2) ds1' + -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 = DmdType lub_fv lub_ds - where - n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1) = etaExpandDmdType n d1 - (DmdType fv2 ds2) = etaExpandDmdType n d2 - lub_ds = zipWithEqual lubDmd ds1 ds2 - lub_fv = lubDmdEnv fv1 fv2 +lubDmdType = zipDmdType lubDmd -- | Combine two 'DmdType's for stable unfolding analysis. -- See Note [Combining demands for stable unfoldings]. maxDmdType :: DmdType -> DmdType -> DmdType -maxDmdType (DmdType fv1 ds1) (DmdType fv2 ds2) - = DmdType combined_fv combined_ds - where - combined_fv = maxDmdEnv fv1 fv2 - combined_ds = go ds1 ds2 - -- If lists have different lengths, keep remaining ds1 (from RHS) - go rhs [] = rhs - go [] _ = [] - go (r:rhs) (u:unfs) = maxDmd r u : go rhs unfs - --- | See Note [Combining demands for stable unfoldings]. -maxDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -maxDmdEnv (DE fv1 d1) (DE fv2 d2) = DE combined_fv combined_div - where - combined_fv = plusVarEnv_CD maxDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - combined_div = lubDivergence d1 d2 +maxDmdType = zipDmdType maxDmd discardArgDmds :: DmdType -> DmdEnv discardArgDmds (DmdType fv _) = fv ===================================== testsuite/tests/dmdanal/should_run/M2.hs ===================================== @@ -0,0 +1,28 @@ +module M2 where + +-- f's stable unfolding template is the PAP `mk g`, which is not +-- eta-expanded, so its DmdType has depth 0. The big lambda keeps the +-- template large enough that f does not certainlyWillInline, so it is +-- worker/wrappered. +{-# INLINABLE [1] f #-} +f :: Int -> Int -> Float +f = mk (\y -> succ . succ . succ . succ . succ . succ . succ . succ . succ $ y) + +-- Arity 1: the `let` does real work, so mk is not eta-expanded past it. +-- The returned function really forces x. +{-# NOINLINE mk #-} +mk :: (Int -> Int) -> Int -> Int -> Float +mk t = let s = t 1 in \dummy x -> x `seq` fromIntegral (t (dummy + s)) + +{-# INLINE mkFast #-} +mkFast :: (Int -> Int) -> Int -> Int -> Float +mkFast t = \dummy x -> fromIntegral (t dummy) + +-- Active only before phase 1: rewrites f's RHS early, but is dead by +-- the time f's stable unfolding (activation [1]) is inlined at call +-- sites. +{-# RULES "mk" [~1] forall t. mk t = mkFast t #-} + +{-# NOINLINE g #-} +g :: Int -> Int +g x = x + 1 ===================================== testsuite/tests/dmdanal/should_run/T27626.hs ===================================== @@ -0,0 +1,6 @@ +-- The raised threshold persuades GHC to inline the worker's stable +-- unfolding in this small program; a larger program does that naturally. +{-# OPTIONS_GHC -funfolding-use-threshold=400 #-} +module Main where +import M2 ( f ) +main = print (f 19 12) ===================================== testsuite/tests/dmdanal/should_run/T27626.stdout ===================================== @@ -0,0 +1 @@ +38.0 ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -36,3 +36,4 @@ test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208']) test('T25439', normal, compile_and_run, ['']) test('T26748', normal, compile_and_run, ['']) test('T26416', [extra_files(['M1.hs'])], multimod_compile_and_run, ['T26416','M1.hs']) +test('T27626', [extra_files(['M2.hs'])], multimod_compile_and_run, ['T27626','M2.hs']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/876bc4ee7d8d46e425f0748f9f641932... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/876bc4ee7d8d46e425f0748f9f641932... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help