Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
-
d143b24d
by Brandon Chinn at 2026-08-15T09:10:03-04:00
-
6f6ec8c1
by Zubin Duggal at 2026-08-15T09:10:05-04:00
-
58e92623
by mangoiv at 2026-08-15T09:10:07-04:00
8 changed files:
- + changelog.d/27626
- compiler/GHC/Types/Demand.hs
- docs/users_guide/exts/qualified_strings.rst
- hadrian/hie-bios.bat
- + 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:
| 1 | +section: compiler
|
|
| 2 | +synopsis: Fix a bug where an argument used only by a function's stable unfolding
|
|
| 3 | + could still be marked absent, resulting in a runtime crash.
|
|
| 4 | +mrs: !16503
|
|
| 5 | +issues: #27626 |
| ... | ... | @@ -1849,12 +1849,14 @@ botDmdEnv = mkEmptyDmdEnv botDiv |
| 1849 | 1849 | exnDmdEnv :: DmdEnv
|
| 1850 | 1850 | exnDmdEnv = mkEmptyDmdEnv exnDiv
|
| 1851 | 1851 | |
| 1852 | +combineDmdEnv :: (Demand -> Demand -> Demand) -> DmdEnv -> DmdEnv -> DmdEnv
|
|
| 1853 | +combineDmdEnv f (DE fv1 d1) (DE fv2 d2)
|
|
| 1854 | + -- See Note [Demand env Equality]
|
|
| 1855 | + = DE (plusVarEnv_CD f fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2))
|
|
| 1856 | + (lubDivergence d1 d2)
|
|
| 1857 | + |
|
| 1852 | 1858 | lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
|
| 1853 | -lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div
|
|
| 1854 | - where
|
|
| 1855 | - -- See Note [Demand env Equality]
|
|
| 1856 | - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)
|
|
| 1857 | - lub_div = lubDivergence d1 d2
|
|
| 1859 | +lubDmdEnv = combineDmdEnv lubDmd
|
|
| 1858 | 1860 | |
| 1859 | 1861 | addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv
|
| 1860 | 1862 | addVarDmdEnv env@(DE fvs div) id dmd
|
| ... | ... | @@ -1908,36 +1910,31 @@ instance Eq DmdType where |
| 1908 | 1910 | = ds1 == ds2 -- cheap checks first
|
| 1909 | 1911 | && env1 == env2
|
| 1910 | 1912 | |
| 1913 | +-- | The smaller 'DmdType' is eta expanded using its 'defaultArgDmd'.
|
|
| 1914 | +-- See Note [Default demand on free variables and arguments].
|
|
| 1915 | +zipDmdType :: (Demand -> Demand -> Demand) -> DmdType -> DmdType -> DmdType
|
|
| 1916 | +zipDmdType f (DmdType fv1 ds1) (DmdType fv2 ds2)
|
|
| 1917 | + = DmdType (combineDmdEnv f fv1 fv2) (go ds1 ds2)
|
|
| 1918 | + where
|
|
| 1919 | + def1, def2 :: Demand -- Default argument demands for eta expansion
|
|
| 1920 | + def1 = defaultArgDmd (de_div fv1)
|
|
| 1921 | + def2 = defaultArgDmd (de_div fv2)
|
|
| 1922 | + |
|
| 1923 | + -- If `ds1` is shorter than `ds2`, extend `ds1` with the appropriate
|
|
| 1924 | + -- default demand `def1`; and similarly if `ds2` is shorter
|
|
| 1925 | + go (d1:ds1') (d2:ds2') = f d1 d2 : go ds1' ds2'
|
|
| 1926 | + go [] ds2' = map (def1 `f`) ds2'
|
|
| 1927 | + go ds1' [] = map (`f` def2) ds1'
|
|
| 1928 | + |
|
| 1911 | 1929 | -- | Compute the least upper bound of two 'DmdType's elicited /by the same
|
| 1912 | 1930 | -- incoming demand/!
|
| 1913 | 1931 | lubDmdType :: DmdType -> DmdType -> DmdType
|
| 1914 | -lubDmdType d1 d2 = DmdType lub_fv lub_ds
|
|
| 1915 | - where
|
|
| 1916 | - n = max (dmdTypeDepth d1) (dmdTypeDepth d2)
|
|
| 1917 | - (DmdType fv1 ds1) = etaExpandDmdType n d1
|
|
| 1918 | - (DmdType fv2 ds2) = etaExpandDmdType n d2
|
|
| 1919 | - lub_ds = zipWithEqual lubDmd ds1 ds2
|
|
| 1920 | - lub_fv = lubDmdEnv fv1 fv2
|
|
| 1932 | +lubDmdType = zipDmdType lubDmd
|
|
| 1921 | 1933 | |
| 1922 | 1934 | -- | Combine two 'DmdType's for stable unfolding analysis.
|
| 1923 | 1935 | -- See Note [Combining demands for stable unfoldings].
|
| 1924 | 1936 | maxDmdType :: DmdType -> DmdType -> DmdType
|
| 1925 | -maxDmdType (DmdType fv1 ds1) (DmdType fv2 ds2)
|
|
| 1926 | - = DmdType combined_fv combined_ds
|
|
| 1927 | - where
|
|
| 1928 | - combined_fv = maxDmdEnv fv1 fv2
|
|
| 1929 | - combined_ds = go ds1 ds2
|
|
| 1930 | - -- If lists have different lengths, keep remaining ds1 (from RHS)
|
|
| 1931 | - go rhs [] = rhs
|
|
| 1932 | - go [] _ = []
|
|
| 1933 | - go (r:rhs) (u:unfs) = maxDmd r u : go rhs unfs
|
|
| 1934 | - |
|
| 1935 | --- | See Note [Combining demands for stable unfoldings].
|
|
| 1936 | -maxDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
|
|
| 1937 | -maxDmdEnv (DE fv1 d1) (DE fv2 d2) = DE combined_fv combined_div
|
|
| 1938 | - where
|
|
| 1939 | - combined_fv = plusVarEnv_CD maxDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)
|
|
| 1940 | - combined_div = lubDivergence d1 d2
|
|
| 1937 | +maxDmdType = zipDmdType maxDmd
|
|
| 1941 | 1938 | |
| 1942 | 1939 | discardArgDmds :: DmdType -> DmdEnv
|
| 1943 | 1940 | discardArgDmds (DmdType fv _) = fv
|
| ... | ... | @@ -15,3 +15,10 @@ The ``-XQualifiedStrings`` extension allows string literals to be qualified usin |
| 15 | 15 | This allows more precise control over the ``fromString`` function than :extension:`OverloadedStrings`, which overloads all string literals for an entire module.
|
| 16 | 16 | |
| 17 | 17 | If :extension:`MultilineStrings` is also enabled, ``M."""test"""`` will also work, desugaring the multiline string first, then the qualified string literal.
|
| 18 | + |
|
| 19 | +Laws
|
|
| 20 | +~~~~
|
|
| 21 | + |
|
| 22 | +If the following expression typechecks, it should hold:
|
|
| 23 | + |
|
| 24 | +* ``Data.String.fromString "str" == M."str"`` |
| 1 | +module M2 where
|
|
| 2 | + |
|
| 3 | +-- f's stable unfolding template is the PAP `mk g`, which is not
|
|
| 4 | +-- eta-expanded, so its DmdType has depth 0. The big lambda keeps the
|
|
| 5 | +-- template large enough that f does not certainlyWillInline, so it is
|
|
| 6 | +-- worker/wrappered.
|
|
| 7 | +{-# INLINABLE [1] f #-}
|
|
| 8 | +f :: Int -> Int -> Float
|
|
| 9 | +f = mk (\y -> succ . succ . succ . succ . succ . succ . succ . succ . succ $ y)
|
|
| 10 | + |
|
| 11 | +-- Arity 1: the `let` does real work, so mk is not eta-expanded past it.
|
|
| 12 | +-- The returned function really forces x.
|
|
| 13 | +{-# NOINLINE mk #-}
|
|
| 14 | +mk :: (Int -> Int) -> Int -> Int -> Float
|
|
| 15 | +mk t = let s = t 1 in \dummy x -> x `seq` fromIntegral (t (dummy + s))
|
|
| 16 | + |
|
| 17 | +{-# INLINE mkFast #-}
|
|
| 18 | +mkFast :: (Int -> Int) -> Int -> Int -> Float
|
|
| 19 | +mkFast t = \dummy x -> fromIntegral (t dummy)
|
|
| 20 | + |
|
| 21 | +-- Active only before phase 1: rewrites f's RHS early, but is dead by
|
|
| 22 | +-- the time f's stable unfolding (activation [1]) is inlined at call
|
|
| 23 | +-- sites.
|
|
| 24 | +{-# RULES "mk" [~1] forall t. mk t = mkFast t #-}
|
|
| 25 | + |
|
| 26 | +{-# NOINLINE g #-}
|
|
| 27 | +g :: Int -> Int
|
|
| 28 | +g x = x + 1 |
| 1 | +-- The raised threshold persuades GHC to inline the worker's stable
|
|
| 2 | +-- unfolding in this small program; a larger program does that naturally.
|
|
| 3 | +{-# OPTIONS_GHC -funfolding-use-threshold=400 #-}
|
|
| 4 | +module Main where
|
|
| 5 | +import M2 ( f )
|
|
| 6 | +main = print (f 19 12) |
| 1 | +38.0 |
| ... | ... | @@ -36,3 +36,4 @@ test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208']) |
| 36 | 36 | test('T25439', normal, compile_and_run, [''])
|
| 37 | 37 | test('T26748', normal, compile_and_run, [''])
|
| 38 | 38 | test('T26416', [extra_files(['M1.hs'])], multimod_compile_and_run, ['T26416','M1.hs'])
|
| 39 | +test('T27626', [extra_files(['M2.hs'])], multimod_compile_and_run, ['T27626','M2.hs']) |