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

Commits:

8 changed files:

Changes:

  • changelog.d/fix-absent-dict-projection
    1 
    +section: compiler
    2 
    +synopsis: Fix a CorePrep miscompilation that could project a field out of an absent dictionary, resulting in a segfault.
    3 
    +issues: #25924
    4 
    +mrs: !16219
    5 
    +description: We no longer speculatively evaluate bindings that we have already discovered are absent.

  • compiler/GHC/CoreToStg/Prep.hs
    ... ... @@ -2253,12 +2253,18 @@ decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf,
    2253 2253 
       | is_string             = (CaseBound, TopLvlFloatable)
    2254 2254 
           -- String literals are unboxed (so must be case-bound) and float to
    2255 2255 
           -- the top-level
    2256 
    -  | ok_for_spec           = (CaseBound, case lev of Unlifted -> LazyContextFloatable
    2256 
    +  | ok_for_spec
    2257 
    +  , not (isAbsDmd dmd)    = (CaseBound, case lev of Unlifted -> LazyContextFloatable
    2257 2258 
                                                         Lifted   -> TopLvlFloatable)
    2258 2259 
           -- See Note [Speculative evaluation]
    2259 2260 
           -- Ok-for-spec-eval things will be case-bound, lifted or not.
    2260 2261 
           -- But when it's lifted we are ok with floating it to top-level
    2261 2262 
           -- (where it is actually bound lazily).
    2263 
    +      --
    2264 
    +      -- Don't speculate an absent binding. Its RHS may project a field out of
    2265 
    +      -- a dictionary that we filled with a rubbish literal because the
    2266 
    +      -- dictionary was absent (see Note [Absent fillers]). Speculating it
    2267 
    +      -- forces that projection and results in a segfault. See #25924.
    2262 2268 
       | Unlifted <- lev       = (CaseBound, StrictContextFloatable)
    2263 2269 
       | isStrUsedDmd dmd      = (CaseBound, StrictContextFloatable)
    2264 2270 
           -- These will never be floated out of a lazy RHS context

  • testsuite/tests/core-to-stg/T25924/B.hs
    1 
    +{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies, QuantifiedConstraints, TypeAbstractions #-}
    2 
    +module B where
    3 
    +
    4 
    +import Data.Kind
    5 
    +
    6 
    +class ABITypeable a where
    7 
    +  abiTypeInfo :: String
    8 
    +  abiTypeInfo = ""
    9 
    +
    10 
    +  unused :: a -> a
    11 
    +  unused x = x
    12 
    +
    13 
    +data REF a
    14 
    +
    15 
    +instance ABITypeable () where
    16 
    +instance ABITypeable a => ABITypeable (REF a) where
    17 
    +
    18 
    +class (ABITypeable a, ABITypeable a) => YulCatObj a where -- crash stops without duplicate constraint
    19 
    +instance YulCatObj ()
    20 
    +instance YulCatObj a => YulCatObj (REF a)
    21 
    +
    22 
    +type YulO1 a = YulCatObj a
    23 
    +type YulO2 a b = (YulCatObj a, YulCatObj b)
    24 
    +
    25 
    +
    26 
    +type YulCat :: Type -> Type -> Type
    27 
    +data YulCat a b where
    28 
    +  YulExtendType :: forall b. (YulO2 () b) => YulCat () b
    29 
    +  YulComp :: forall a b c. YulCat c b -> YulCat a c -> YulCat a b
    30 
    +  YulJmpB :: forall a b. (YulO2 a b) =>  YulCat a b
    31 
    +
    32 
    +data Trie  a b where
    33 
    +  Z :: Trie  a a
    34 
    +  (:.) :: (YulCatObj a, YulCatObj b) => YulCat a b -> Trie b c -> Trie a c
    35 
    +
    36 
    +type Cat a b = forall c. Trie b c -> Trie a c
    37 
    +
    38 
    +normalize :: forall a b unused  ξ. (Int ~ unused,  YulCatObj a, YulCatObj b)
    39 
    +  => Trie a b -> (forall c. YulCatObj c => Trie a c -> YulCat c b -> ξ) -> ξ
    40 
    +normalize t0 k = case t0 of
    41 
    +  Z -> k Z undefined
    42 
    +  φ :. f -> normalize f $ \f' s -> case f' of
    43 
    +                                     Z -> k Z (s `YulComp` φ)
    44 
    +                                     _ -> undefined
    45 
    +
    46 
    +
    47 
    +toSMC :: forall a b . (YulCatObj a, YulCatObj b) => Cat a b -> YulCat a b
    48 
    +toSMC t = normalize (t Z) $ \f g -> case f of
    49 
    +  Z -> g
    50 
    +  _ -> error "toSMC: normalisation process failed"
    51 
    +
    52 
    +
    53 
    +encode   :: (YulCatObj r, YulCatObj a, YulCatObj b) => (a `YulCat` b) -> (P r a -> P r b)
    54 
    +encode φ (Y f)    = Y (\x -> f (φ :. x))
    55 
    +
    56 
    +
    57 
    +type P :: Type -> Type -> Type
    58 
    +data P r a = Y (Cat r a)
    59 
    +
    60 
    +fromP :: P r a -> Cat r a
    61 
    +fromP (Y f) = f
    62 
    +
    63 
    +
    64 
    +decode :: (YulCatObj a, YulCatObj b) => (P a a -> P a b) -> YulCat a b
    65 
    +decode f  = toSMC (extract f)
    66 
    +
    67 
    +extract ::(YulCatObj a, YulCatObj b) => (P a a -> P a b) -> Cat a b
    68 
    +extract f = fromP (f (Y id))
    69 
    +
    70 
    +
    71 
    +yulShow :: YulCat a' b' -> String
    72 
    +yulShow (YulExtendType @b) = "Te" <> abiTypeInfo @b
    73 
    +yulShow (YulComp cb ac)    = yulShow ac <> yulShow cb
    74 
    +yulShow YulJmpB            = "Jb"
    75 
    +
    76 
    +
    77 
    +lfn' :: forall b unused.
    78 
    +  ( YulO1 (REF b)
    79 
    +  , () ~ unused
    80 
    +  ) =>
    81 
    +  (forall r. YulO1 r => P r () -> P r (REF b)) -> String
    82 
    +lfn' f = yulShow (decode f)
    83 
    +
    84 
    +
    85 
    +extendType'l :: forall a r. (YulO1 a, YulO1 r) => P r () -> P r a
    86 
    +extendType'l = encode YulExtendType
    87 
    +
    88 
    +keccak256'l :: forall a r. YulO2 r a => P r a -> P r ()
    89 
    +keccak256'l = encode YulJmpB

  • testsuite/tests/core-to-stg/T25924/Main.hs
    1 
    +module Main where
    2 
    +import B
    3 
    +
    4 
    +getCounterRef' :: forall b r.
    5 
    +  ( YulO1 b
    6 
    +  , YulO1 r
    7 
    +  -- , YulO1 (REF b)
    8 
    +  ) =>
    9 
    +  P r ()  -> P r (REF b)
    10 
    +getCounterRef' a = extendType'l (keccak256'l a)
    11 
    +{-# NOINLINE getCounterRef' #-}
    12 
    +
    13 
    +main :: IO ()
    14 
    +main = putStrLn $ lfn' @() getCounterRef'

  • testsuite/tests/core-to-stg/T25924/all.T
    1 
    +test('T25924',
    2 
    +     [exit_code(1), ignore_stderr, extra_files(['Main.hs', 'B.hs'])],
    3 
    +     multimod_compile_and_run,
    4 
    +     ['Main', '-O'])

  • testsuite/tests/core-to-stg/T25924a.hs
    1 
    +{-# LANGUAGE GADTs, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-}
    2 
    +module Main where
    3 
    +
    4 
    +class D a where
    5 
    +  m :: a -> Int
    6 
    +  m _ = 0
    7 
    +  n :: a -> Int
    8 
    +  n _ = 0
    9 
    +
    10 
    +class (D a, D a) => C a
    11 
    +
    12 
    +data T a
    13 
    +
    14 
    +instance D a => D (T a)
    15 
    +instance C a => C (T a)
    16 
    +
    17 
    +instance D ()
    18 
    +instance C ()
    19 
    +
    20 
    +data G where
    21 
    +  MkG :: forall a. C (T a) => T a -> G
    22 
    +
    23 
    +sh :: G -> Int
    24 
    +sh (MkG x) = m x
    25 
    +
    26 
    +f :: forall b. C b => G
    27 
    +f = MkG (undefined :: T b)
    28 
    +{-# NOINLINE f #-}
    29 
    +
    30 
    +main :: IO ()
    31 
    +main = print (sh (f @()))

  • testsuite/tests/core-to-stg/T25924a.stdout
    1 
    +0

  • testsuite/tests/core-to-stg/all.T
    ... ... @@ -8,3 +8,4 @@ test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsupp
    8 8 
     test('T23865', normal, compile, ['-O -dlint'])
    9 9 
     test('T24334', normal, compile_and_run, ['-O'])
    10 10 
     test('T24463', normal, compile, ['-O'])
    11 
    +test('T25924a', [ignore_stderr], compile_and_run, ['-O'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help