Simon Peyton Jones pushed to branch wip/26805 at Glasgow Haskell Compiler / GHC Commits: 198f7eeb by Simon Peyton Jones at 2026-01-20T11:42:51+00:00 Fix buglet in short-cut constraint solving This MR address #26805 by using `isSolvedWC`, rather than `isEmptyWC`, in the short-cut constraint solver. See `GHC.Tc.Solver.Dict.tryShortCutSolver`. Easy fix! - - - - - 6 changed files: - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Types/Constraint.hs - + testsuite/tests/simplCore/should_compile/T26805.hs - + testsuite/tests/simplCore/should_compile/T26805.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Gen/Default.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Gen.HsType import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Solver.Solve ( solveWanteds ) -import GHC.Tc.Types.Constraint ( isEmptyWC, andWC, mkSimpleWC ) +import GHC.Tc.Types.Constraint ( isSolvedWC, andWC, mkSimpleWC ) import GHC.Tc.Types.Origin ( CtOrigin(DefaultOrigin) ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -296,7 +296,7 @@ simplifyDefault cls dflt_ty@(L l _) , text "inst_pred:" <+> ppr inst_pred , text "all_wanteds " <+> ppr all_wanteds , text "unsolved:" <+> ppr unsolved ] - ; let is_instance = isEmptyWC unsolved + ; let is_instance = isSolvedWC unsolved ; return $ if | is_instance , ClassPred _ tys <- classifyPredType inst_pred ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -663,6 +663,12 @@ Some wrinkles: of the caller (#15164). You might worry about having a solved-dict that uses a Given -- but that too will have been subject to short-cut solving so it's fine. +(SCS4) In `tryShortCutSolver`, when deciding if we have "completely solved" the + constraint, we must use `isSolvedWC` not `isEmptyWC`. The latter says "False" + if the residual constraint has any implications, even solved ones; and we + don't want to reject short-cut solving just because we have some leftover + /solved/ implications. #26805 was a case in point. + Note [Shortcut solving: incoherence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This optimization relies on coherence of dictionaries to be correct. When we @@ -798,7 +804,11 @@ tryShortCutSolver try_short_cut dict_w@(DictCt { di_ev = ev_w }) -> tryShortCutTcS $ -- tryTcS tries to completely solve some contraints do { residual <- solveSimpleWanteds (unitBag (CDictCan dict_w)) - ; return (isEmptyWC residual) } + ; return (isSolvedWC residual) } + -- NB: isSolvedWC, not isEmptyWC (#26805). We might succeed + -- in fully-solving the constraint but still leave some + -- /solved/ implications in the residual. + -- See (SCS4) in Note [Shortcut solving] | otherwise -> return False } ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1055,6 +1055,13 @@ mkImplicWC :: Bag Implication -> WantedConstraints mkImplicWC implic = emptyWC { wc_impl = implic } +-- | `isEmptyWC` sess if a `WantedConstraints` is truly empty, including +-- having no implications. +-- +-- It's possible that it might have /solved/ implications, which are left around +-- just so we can report unreachable code. So: +-- isEmptyWC implies isSolvedWC- +-- but not vice versa isEmptyWC :: WantedConstraints -> Bool isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_errors = errors }) = isEmptyBag f && isEmptyBag i && isEmptyBag errors ===================================== testsuite/tests/simplCore/should_compile/T26805.hs ===================================== @@ -0,0 +1,29 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TypeData #-} +module T26805( interpret ) where + +import Data.Kind (Type) + +data Phantom (sh :: Type) = Phantom -- newtype fails to specialise as well + +instance Show (Phantom sh) where + show Phantom = "show" + +type Foo r = (forall sh. Show (Phantom sh), Num r) +-- this specialises fine: +-- type Foo r = (Num r) + +type data TK = TKScalar Type + +data AstTensor :: TK -> Type where + AstInt :: Int -> AstTensor (TKScalar Int) + AstPlus :: Foo r => AstTensor (TKScalar r) -> AstTensor (TKScalar r) + +plusConcrete :: Foo r => r -> r +plusConcrete = (+ 1) + +interpret :: AstTensor (TKScalar Int) -> Int +interpret v0 = case v0 of + AstInt n -> n + AstPlus u -> plusConcrete (interpret u) ===================================== testsuite/tests/simplCore/should_compile/T26805.stderr ===================================== @@ -0,0 +1 @@ + \ No newline at end of file ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -578,3 +578,4 @@ test('T26615', [grep_errmsg(r'fEqList')], multimod_compile, ['T26615', '-O -fsp # T26722: there should be no reboxing in $wg test('T26722', [grep_errmsg(r'SPEC')], compile, ['-O -dno-typeable-binds']) +test('T26805', [grep_errmsg(r'fromInteger')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/198f7eeb27e9bca95b7f0b9afc448309... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/198f7eeb27e9bca95b7f0b9afc448309... You're receiving this email because of your account on gitlab.haskell.org.