Zubin pushed to branch wip/27626 at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • changelog.d/27626
    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

  • compiler/GHC/Types/Demand.hs
    ... ... @@ -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

  • testsuite/tests/dmdanal/should_run/M2.hs
    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

  • testsuite/tests/dmdanal/should_run/T27626.hs
    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)

  • testsuite/tests/dmdanal/should_run/T27626.stdout
    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'])
    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'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/876bc4ee7d8d46e425f0748f9f641932fd26c54e at 1786607667