Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 73f3d1a9 by Simon Peyton Jones at 2025-06-23T23:40:01+01:00 Wibbles [skip ci] - - - - - 3 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -481,9 +481,8 @@ can_eq_nc_forall ev eq_rel s1 s2 , ppr flags1, ppr flags2 ] ; canEqHardFailure ev s1 s2 } - else do { - traceTcS "Creating implication for polytype equality" (ppr ev) - ; let free_tvs = tyCoVarsOfTypes [s1,s2] + else + do { let free_tvs = tyCoVarsOfTypes [s1,s2] empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs skol_info_anon = UnifyForAllSkol phi1 ; skol_info <- mkSkolemInfo skol_info_anon @@ -525,12 +524,15 @@ can_eq_nc_forall ev eq_rel s1 s2 init_subst2 = mkEmptySubst (substInScopeSet subst1) + ; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2) + -- Generate the constraints that live in the body of the implication -- See (SF5) in Note [Solving forall equalities] ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> go uenv skol_tvs init_subst2 bndrs1 bndrs2 + ; traceTcS "Trying to solve the immplication" (ppr s1 $$ ppr s2 $$ ppr wanteds) ; ev_binds_var <- newNoTcEvBinds ; solved <- trySolveImplication $ (implicationPrototype (ctLocEnv loc)) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1363,7 +1363,10 @@ tryTcS (TcS thing_inside) , tcs_inerts = new_inert_var , tcs_worklist = new_wl_var } - ; TcM.traceTc "tryTcS {" (ppr old_inerts) + ; TcM.traceTc "tryTcS {" $ + vcat [ text "old_ev_binds:" <+> ppr old_ev_binds_var + , text "new_ev_binds:" <+> ppr new_ev_binds_var + , ppr old_inerts ] ; wc <- thing_inside nest_env ; TcM.traceTc "tryTcS }" (ppr wc) @@ -1371,8 +1374,7 @@ tryTcS (TcS thing_inside) then return False else do { -- Successfully solved -- Add the new bindings to the existing ones - new_ev_binds <- TcM.getTcEvBindsMap new_ev_binds_var - ; TcM.updTcEvBindsMap old_ev_binds_var (`unionEvBindMap` new_ev_binds) + ; TcM.updTcEvBinds old_ev_binds_var new_ev_binds_var -- Update the existing inert set ; new_inerts <- TcM.readTcRef new_inert_var ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -102,7 +102,7 @@ module GHC.Tc.Utils.Monad( -- * Type constraints newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, addTcEvBind, addTcEvBinds, addTopEvBinds, - getTcEvBindsMap, setTcEvBindsMap, updTcEvBindsMap, + getTcEvBindsMap, setTcEvBindsMap, updTcEvBinds, getTcEvTyCoVars, chooseUniqueOccTc, getConstraintVar, setConstraintVar, emitConstraints, emitStaticConstraints, emitSimple, emitSimples, @@ -1811,11 +1811,24 @@ setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds | otherwise = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) -updTcEvBindsMap :: EvBindsVar -> (EvBindMap -> EvBindMap) -> TcM () -updTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) upd - = updTcRef ev_ref upd -updTcEvBindsMap v@(CoEvBindsVar {}) _ - = pprPanic "updTcEvBindsMap" (ppr v) +updTcEvBinds :: EvBindsVar -> EvBindsVar -> TcM () +updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_tcv_ref }) + (EvBindsVar { ebv_binds = new_ebv_ref, ebv_tcvs = new_tcv_ref }) + = do { new_ebvs <- readTcRef new_ebv_ref + ; updTcRef old_ebv_ref (`unionEvBindMap` new_ebvs) + ; new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) } +updTcEvBinds (EvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) } +updTcEvBinds (CoEvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) } +updTcEvBinds old_var new_var + = pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var) + -- Terms inside types, no good addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73f3d1a93021137ec47e9f01522ba063... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73f3d1a93021137ec47e9f01522ba063... You're receiving this email because of your account on gitlab.haskell.org.