Zubin pushed to branch wip/25924 at Glasgow Haskell Compiler / GHC Commits: 409a285a by Zubin Duggal at 2026-06-19T13:43:33+05:30 CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary (which we generated because it absent). Solution: Don't speculate on bindings we already know are absent. Fixes 25924 - - - - - 8 changed files: - + changelog.d/fix-absent-dict-projection - compiler/GHC/CoreToStg/Prep.hs - + testsuite/tests/core-to-stg/T25924/B.hs - + testsuite/tests/core-to-stg/T25924/Main.hs - + testsuite/tests/core-to-stg/T25924/all.T - + testsuite/tests/core-to-stg/T25924a.hs - + testsuite/tests/core-to-stg/T25924a.stdout - testsuite/tests/core-to-stg/all.T Changes: ===================================== changelog.d/fix-absent-dict-projection ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a CorePrep miscompilation that could project a field out of an absent dictionary, resulting in a segfault. +issues: #25924 +mrs: !16219 +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, | is_string = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level - | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable + | ok_for_spec + , not (isAbsDmd dmd) = (CaseBound, case lev of Unlifted -> LazyContextFloatable Lifted -> TopLvlFloatable) -- See Note [Speculative evaluation] -- Ok-for-spec-eval things will be case-bound, lifted or not. -- But when it's lifted we are ok with floating it to top-level -- (where it is actually bound lazily). + -- + -- Don't speculate an absent binding. Its RHS may project a field out of + -- a dictionary that we filled with a rubbish literal because the + -- dictionary was absent (see Note [Absent fillers]). Speculating it + -- forces that projection and results in a segfault. See #25924. | Unlifted <- lev = (CaseBound, StrictContextFloatable) | isStrUsedDmd dmd = (CaseBound, StrictContextFloatable) -- These will never be floated out of a lazy RHS context ===================================== testsuite/tests/core-to-stg/T25924/B.hs ===================================== @@ -0,0 +1,89 @@ +{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies, QuantifiedConstraints, TypeAbstractions #-} +module B where + +import Data.Kind + +class ABITypeable a where + abiTypeInfo :: String + abiTypeInfo = "" + + unused :: a -> a + unused x = x + +data REF a + +instance ABITypeable () where +instance ABITypeable a => ABITypeable (REF a) where + +class (ABITypeable a, ABITypeable a) => YulCatObj a where -- crash stops without duplicate constraint +instance YulCatObj () +instance YulCatObj a => YulCatObj (REF a) + +type YulO1 a = YulCatObj a +type YulO2 a b = (YulCatObj a, YulCatObj b) + + +type YulCat :: Type -> Type -> Type +data YulCat a b where + YulExtendType :: forall b. (YulO2 () b) => YulCat () b + YulComp :: forall a b c. YulCat c b -> YulCat a c -> YulCat a b + YulJmpB :: forall a b. (YulO2 a b) => YulCat a b + +data Trie a b where + Z :: Trie a a + (:.) :: (YulCatObj a, YulCatObj b) => YulCat a b -> Trie b c -> Trie a c + +type Cat a b = forall c. Trie b c -> Trie a c + +normalize :: forall a b unused ξ. (Int ~ unused, YulCatObj a, YulCatObj b) + => Trie a b -> (forall c. YulCatObj c => Trie a c -> YulCat c b -> ξ) -> ξ +normalize t0 k = case t0 of + Z -> k Z undefined + φ :. f -> normalize f $ \f' s -> case f' of + Z -> k Z (s `YulComp` φ) + _ -> undefined + + +toSMC :: forall a b . (YulCatObj a, YulCatObj b) => Cat a b -> YulCat a b +toSMC t = normalize (t Z) $ \f g -> case f of + Z -> g + _ -> error "toSMC: normalisation process failed" + + +encode :: (YulCatObj r, YulCatObj a, YulCatObj b) => (a `YulCat` b) -> (P r a -> P r b) +encode φ (Y f) = Y (\x -> f (φ :. x)) + + +type P :: Type -> Type -> Type +data P r a = Y (Cat r a) + +fromP :: P r a -> Cat r a +fromP (Y f) = f + + +decode :: (YulCatObj a, YulCatObj b) => (P a a -> P a b) -> YulCat a b +decode f = toSMC (extract f) + +extract ::(YulCatObj a, YulCatObj b) => (P a a -> P a b) -> Cat a b +extract f = fromP (f (Y id)) + + +yulShow :: YulCat a' b' -> String +yulShow (YulExtendType @b) = "Te" <> abiTypeInfo @b +yulShow (YulComp cb ac) = yulShow ac <> yulShow cb +yulShow YulJmpB = "Jb" + + +lfn' :: forall b unused. + ( YulO1 (REF b) + , () ~ unused + ) => + (forall r. YulO1 r => P r () -> P r (REF b)) -> String +lfn' f = yulShow (decode f) + + +extendType'l :: forall a r. (YulO1 a, YulO1 r) => P r () -> P r a +extendType'l = encode YulExtendType + +keccak256'l :: forall a r. YulO2 r a => P r a -> P r () +keccak256'l = encode YulJmpB ===================================== testsuite/tests/core-to-stg/T25924/Main.hs ===================================== @@ -0,0 +1,14 @@ +module Main where +import B + +getCounterRef' :: forall b r. + ( YulO1 b + , YulO1 r + -- , YulO1 (REF b) + ) => + P r () -> P r (REF b) +getCounterRef' a = extendType'l (keccak256'l a) +{-# NOINLINE getCounterRef' #-} + +main :: IO () +main = putStrLn $ lfn' @() getCounterRef' ===================================== testsuite/tests/core-to-stg/T25924/all.T ===================================== @@ -0,0 +1,4 @@ +test('T25924', + [exit_code(1), ignore_stderr, extra_files(['Main.hs', 'B.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T25924a.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-} +module Main where + +class D a where + m :: a -> Int + m _ = 0 + n :: a -> Int + n _ = 0 + +class (D a, D a) => C a + +data T a + +instance D a => D (T a) +instance C a => C (T a) + +instance D () +instance C () + +data G where + MkG :: forall a. C (T a) => T a -> G + +sh :: G -> Int +sh (MkG x) = m x + +f :: forall b. C b => G +f = MkG (undefined :: T b) +{-# NOINLINE f #-} + +main :: IO () +main = print (sh (f @())) ===================================== testsuite/tests/core-to-stg/T25924a.stdout ===================================== @@ -0,0 +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 test('T23865', normal, compile, ['-O -dlint']) test('T24334', normal, compile_and_run, ['-O']) test('T24463', normal, compile, ['-O']) +test('T25924a', [ignore_stderr], compile_and_run, ['-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409a285ae0c05ddbf1f2c69812f79578... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409a285ae0c05ddbf1f2c69812f79578... You're receiving this email because of your account on gitlab.haskell.org.