Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 5c2484eb by Simon Peyton Jones at 2025-06-22T23:56:27+01:00 Work in progress [skip ci] Trying to avoid TcSSpecPrag by solving immediately. Nicer. - - - - - 5 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Constraint.hs Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -1137,7 +1137,10 @@ matchLocalInst body_pred loc match_local_inst inerts (qci@(QCI { qci_tvs = qtvs , qci_body = qbody , qci_ev = qev }) - :qcis) + : qcis) + | isWanted qev -- Skip Wanteds + = match_local_inst inerts qcis + | let in_scope = mkInScopeSet (qtv_set `unionVarSet` body_pred_tv_set) , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) emptyTvSubstEnv qbody body_pred ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -1875,8 +1875,9 @@ noGivenNewtypeReprEqs tc (IS { inert_cans = inerts }) | otherwise = False - might_help_qc (QCI { qci_body = pred }) - | ClassPred cls [_, t1, t2] <- classifyPredType pred + might_help_qc (QCI { qci_ev = ev, qci_body = pred }) + | isGiven ev + , ClassPred cls [_, t1, t2] <- classifyPredType pred , cls `hasKey` coercibleTyConKey = headed_by_tc t1 t2 | otherwise ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -2380,9 +2380,6 @@ unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a) -- See See (SF5) in Note [Solving forall equalities] in GHC.Tc.Solver.Equality unifyForAllBody ev role unify_body = do { (res, cts, unified) <- wrapUnifierX ev role unify_body - -- Ignore the rewriters. They are used in wrapUnifierTcS only - -- as an optimistion to prioritise the work list; but they are - -- /also/ stored in each individual constraint we return. -- Kick out any inert constraint that we have unified ; _ <- kickOutAfterUnification unified ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -280,7 +280,7 @@ solveNestedImplications implics ; return unsolved_implics } solveImplication :: Implication -- Wanted - -> TcS Implication -- Simplified implication (empty or singleton) + -> TcS Implication -- Simplified implication -- Precondition: The TcS monad contains an empty worklist and given-only inerts -- which after trying to solve this implication we must restore to their original value solveImplication imp@(Implic { ic_tclvl = tclvl @@ -1318,11 +1318,11 @@ try_inert_qcs (QCI { qci_ev = ev_w }) inerts = -- See Note [Solving a Wanted forall-constraint] solveWantedForAll_norm :: WantedCtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> SolverStage Void -solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = loc +solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = ct_loc , ctev_rewriters = rewriters }) tvs theta body_pred = Stage $ - TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $ + TcS.setSrcSpan (getCtLocEnvLoc loc_env) $ -- This setSrcSpan is important: the emitImplicationTcS uses that -- TcLclEnv for the implication, and that in turn sets the location -- for the Givens when solving the constraint (#21006) @@ -1339,24 +1339,38 @@ solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = loc ; given_ev_vars <- mapM newEvVar inst_theta ; (lvl, (w_id, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) + do { let ct_loc' = setCtLocOrigin ct_loc (ScOrigin is_qc NakedSc) -- Set the thing to prove to have a ScOrigin, so we are -- careful about its termination checks. -- See (QC-INV) in Note [Solving a Wanted forall-constraint] - ; wanted_ev <- newWantedNC loc' rewriters inst_pred + ; wanted_ev <- newWantedNC ct_loc' rewriters inst_pred -- NB: inst_pred can be an equality ; return ( wantedCtEvEvId wanted_ev , unitBag (mkNonCanonical $ CtWanted wanted_ev)) } ; traceTcS "solveForAll" (ppr given_ev_vars $$ ppr wanteds $$ ppr w_id) - ; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds + ; ev_binds_var <- newTcEvBinds + ; solved <- trySolveImplication $ + implicationPrototype loc_env + { ic_tclvl = lvl + , ic_binds = ev_binds_var + , ic_info = skol_info_anon + , ic_warn_inacessible = False + , ic_skols = skol_tvs + , ic_given = given_ev_vars + , ic_wanted = emptyWC { wc_simple = wanteds } } + ; if not solved + then updInertIrreds ( + else + do { ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds ; setWantedEvTerm dest EvCanonical $ EvFun { et_tvs = skol_tvs, et_given = given_ev_vars , et_binds = ev_binds, et_body = w_id } ; stopWith (CtWanted wtd) "Wanted forall-constraint (implication)" } where - is_qc = IsQC (ctLocOrigin loc) + loc_env = ctLocEnv loc + is_qc = IsQC (ctLocOrigin ct_loc) empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -990,8 +990,9 @@ pendingScDict_maybe _ = Nothing pendingScInst_maybe :: QCInst -> Maybe QCInst -- Same as isPendingScDict, but for QCInsts -pendingScInst_maybe qci@(QCI { qci_pend_sc = f }) - | pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) +pendingScInst_maybe qci@(QCI { qci_flav = flav, qci_pend_sc = f }) + | Given <- flav -- Do not expand Wanted QCIs + , pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) | otherwise = Nothing superClassesMightHelp :: WantedConstraints -> Bool View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c2484ebf3115bceda3f39062b9a9b1a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c2484ebf3115bceda3f39062b9a9b1a... You're receiving this email because of your account on gitlab.haskell.org.