Simon Peyton Jones pushed to branch wip/T26315 at Glasgow Haskell Compiler / GHC Commits: 04f3db59 by Simon Peyton Jones at 2025-09-02T01:01:25+01:00 Wibbles - - - - - 5 changed files: - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -39,7 +39,7 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Solver( reportUnsolvedEqualities, pushLevelAndSolveEqualitiesX , emitResidualConstraints ) import GHC.Tc.Solver.Solve( solveWanteds ) -import GHC.Tc.Solver.Monad( runTcS, setTcSMode, TcSMode(..), runTcSWithEvBinds ) +import GHC.Tc.Solver.Monad( runTcS, setTcSMode, TcSMode(..), vanillaTcSMode, runTcSWithEvBinds ) import GHC.Tc.Validity ( checkValidType ) import GHC.Tc.Utils.Monad ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -1146,12 +1146,12 @@ matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult -- Look up the predicate in Given quantified constraints, -- which are effectively just local instance declarations. matchLocalInst body_pred loc - = odo { -- Look in the inert set for a matching Given quantified constraint + = do { -- Look in the inert set for a matching Given quantified constraint inerts@(IS { inert_cans = ics }) <- getInertSet ; case match_local_inst inerts (inert_qcis ics) of - { ([], []) -> do { traceTcS "No local instance for" (ppr body_pred) - ; return NoInstance } - ; (matches, unifs) -> + { ([], []) -> do { traceTcS "No local instance for" (ppr body_pred) + ; return NoInstance } + ; (matches, unifs) -> do { -- Find the best match -- See Note [Use only the best matching quantified constraint] ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -909,19 +909,19 @@ data TcSMode -- ^ Do not select an OVERLAPPABLE instance , tcsmFullySolveQCIs :: Bool -- ^ Fully solve all constraints, without using local Givens - deriving (Eq) + } vanillaTcSMode :: TcSMode -vanillaTcSMode = TcSMode { tcs_pm_check = False +vanillaTcSMode = TcSMode { tcsmPmCheck = False , tcsmEarlyAbort = False , tcsmSkipOverlappable = False , tcsmFullySolveQCIs = False } instance Outputable TcSMode where - ppr (TcSMode { tcs_pm_check = pm, tcsmEarlyAbort = ea + ppr (TcSMode { tcsmPmCheck = pm, tcsmEarlyAbort = ea , tcsmSkipOverlappable = so, tcsmFullySolveQCIs = fs }) = text "TcSMode" <> (braces $ - text "pm=" <> ppr pmc <> comma <> + text "pm=" <> ppr pm <> comma <> text "ea=" <> ppr ea <> comma <> text "so=" <> ppr so <> comma <> text "fs=" <> ppr fs) @@ -1111,9 +1111,9 @@ runTcS tcs runTcSEarlyAbort :: TcS a -> TcM a runTcSEarlyAbort tcs = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds' TcSEarlyAbort ev_binds_var tcs } + ; runTcSWithEvBinds' mode ev_binds_var tcs } where - mode = vanillaTcSMode { tcsmEarlyAbort = True ] + mode = vanillaTcSMode { tcsmEarlyAbort = True } -- | This can deal only with equality constraints. runTcSEqualities :: TcS a -> TcM a @@ -1124,9 +1124,9 @@ runTcSEqualities thing_inside -- | A variant of 'runTcS' that takes and returns an 'InertSet' for -- later resumption of the 'TcS' session. runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) -runTcSInerts inerts tcs = do +runTcSInerts inerts tcs = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds' (vanillaTcMode { tcsmPmCheck = True }) + ; runTcSWithEvBinds' (vanillaTcSMode { tcsmPmCheck = True }) ev_binds_var $ do { setInertSet inerts ; a <- tcs @@ -1136,7 +1136,7 @@ runTcSInerts inerts tcs = do runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds = runTcSWithEvBinds' TcSVanilla +runTcSWithEvBinds = runTcSWithEvBinds' vanillaTcSMode runTcSWithEvBinds' :: TcSMode -> EvBindsVar @@ -1917,7 +1917,7 @@ matchGlobalInst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult matchGlobalInst dflags cls tys loc = do { mode <- getTcSMode ; let skip_overlappable = tcsmSkipOverlappable mode - ; wrapTcS $ TcM.matchGlobalInst dflags short_cut cls tys (Just loc) } + ; wrapTcS $ TcM.matchGlobalInst dflags skip_overlappable cls tys (Just loc) } tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar]) tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -362,6 +362,12 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; traceTcS "solveImplication 2" (ppr given_insols $$ ppr residual_wanted) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; traceTcS "solveImplication 3" $ vcat + [ text "ev_binds_var" <+> ppr ev_binds_var + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) ] + ; let final_wanted = residual_wanted `addInsols` given_insols -- Don't lose track of the insoluble givens, -- which signal unreachable code; put them in ic_wanted @@ -1504,7 +1510,7 @@ solveWantedQCI :: TcSMode -> TcS (Maybe (Either Ct Implication)) -- Try to solve a quantified constraint. -- In TcSChortCut mode, insist on solving it fully or not at all --- Returns +-- Returns -- No-op on all Cts other than CQuantCan -- See Note [Solving a Wanted forall-constraint] solveWantedQCI mode ct@(CQuantCan (QCI { qci_ev = ev, qci_tvs = tvs @@ -1548,22 +1554,23 @@ solveWantedQCI mode ct@(CQuantCan (QCI { qci_ev = ev, qci_tvs = tvs ; imp' <- solveImplication imp - ; let do_update_evidence = setWantedEvTerm dest EvCanonical $ - EvFun { et_tvs = skol_tvs, et_given = given_ev_vars - , et_binds = TcEvBinds ev_binds_var - , et_body = wantedCtEvEvId wanted_ev } - - ; if | isSolvedStatus (ic_status imp') - -> -- Fully solved, we are all done! - do { do_update_evidence; return Nothing } - - | tcsmFullySolveQCIs mode - -> -- No-op if we must fully solve quantified constraints + ; if | tcsmFullySolveQCIs mode + , not (isSolvedStatus (ic_status imp')) + -> -- Not fully solved, but mode says that we must fully + -- solve quantified constraints; so abandon the attempt return (Just (Left ct)) | otherwise - -> -- Otherwise return partly-solved implication - do { do_update_evidence; return (Just (Right imp')) } + -> -- Record evidence and return residual implication + -- NB: even if it is fully solved we must return it, because it is + -- carrying a record of which evidence variables are used + -- See Note [Free vars of EvFun] in GHC.Tc.Types.Evidence + do { setWantedEvTerm dest EvCanonical $ + EvFun { et_tvs = skol_tvs, et_given = given_ev_vars + , et_binds = TcEvBinds ev_binds_var + , et_body = wantedCtEvEvId wanted_ev } + + ; return (Just (Right imp')) } } | otherwise -- A Given QCInst ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1840,10 +1840,14 @@ updTcEvBinds old_var new_var addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind - = do { traceTc "addTcEvBind" $ ppr u $$ - ppr ev_bind - ; bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } + = do { bnds <- readTcRef ev_ref + ; let bnds' = extendEvBinds bnds ev_bind + ; traceTc "addTcEvBind" $ + vcat [ text "EvBindsVar:" <+> ppr u + , text "ev_bind:" <+> ppr ev_bind + , text "bnds:" <+> ppr bnds + , text "bnds':" <+> ppr bnds' ] + ; writeTcRef ev_ref bnds' } addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04f3db59ab95729799944157c11da7b5... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04f3db59ab95729799944157c11da7b5... You're receiving this email because of your account on gitlab.haskell.org.