Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 4b02492f by Simon Peyton Jones at 2025-06-26T23:40:31+01:00 Fix two significant bugs - - - - - 7 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -1086,14 +1086,25 @@ matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult -- Look up the predicate in Given quantified constraints, -- which are effectively just local instance declarations. matchLocalInst body_pred loc - = do { inerts@(IS { inert_cans = ics }) <- getInertSet + = do { -- In TcSShortCut mode we do not look at Givens; + -- c.f. tryInertDicts + mode <- getTcSMode + ; case mode of + { TcSShortCut -> do { traceTcS "matchLocalInst:TcSShortCut" (ppr body_pred) + ; return NoInstance } + ; _other -> + + do { -- Look in the inert set for a matching Given quantified constraint + inerts@(IS { inert_cans = ics }) <- getInertSet ; case match_local_inst inerts (inert_insts ics) of { ([], []) -> do { traceTcS "No local instance for" (ppr body_pred) ; return NoInstance } ; (matches, unifs) -> - do { matches <- mapM mk_instDFun matches - ; unifs <- mapM mk_instDFun unifs + + do { -- Find the best match -- See Note [Use only the best matching quantified constraint] + matches <- mapM mk_instDFun matches + ; unifs <- mapM mk_instDFun unifs ; case dominatingMatch matches of { Just (dfun_id, tys, theta) | all ((theta `impliedBySCs`) . thdOf3) unifs @@ -1115,7 +1126,7 @@ matchLocalInst body_pred loc , text "matches:" <+> ppr matches , text "unifs:" <+> ppr unifs , text "best_match:" <+> ppr mb_best ] - ; return NotSure }}}}} + ; return NotSure }}}}}}} where body_pred_tv_set = tyCoVarsOfType body_pred ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -545,7 +545,9 @@ can_eq_nc_forall ev eq_rel s1 s2 , ic_wanted = emptyWC { wc_simple = wanteds } } ; if solved - then do { setWantedEq orig_dest all_co + then do { zonked_all_co <- zonkCo all_co + -- ToDo: explain this zonk + ; setWantedEq orig_dest zonked_all_co ; stopWith ev "Polytype equality: solved" } else canEqSoftFailure IrredShapeReason ev s1 s2 } } @@ -572,7 +574,8 @@ can_eq_nc_forall ev eq_rel s1 s2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To solve an equality between foralls [W] (forall a. t1) ~ (forall b. t2) -the basic plan is simple: just create the implication constraint +the basic plan is simple: use `trySolveImplication` to solve the +implication constraint [W] forall a. { t1 ~ (t2[a/b]) } The evidence we produce is a ForAllCo; see the typing rule for ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1435,7 +1435,7 @@ getTcEvBindsVar = TcS (return . tcs_ev_binds) getTcLevel :: TcS TcLevel getTcLevel = wrapTcS TcM.getTcLevel -getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet +getTcEvTyCoVars :: EvBindsVar -> TcS [TcCoercion] getTcEvTyCoVars ev_binds_var = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var @@ -1989,19 +1989,15 @@ setEvBind ev_bind ; wrapTcS $ TcM.addTcEvBind evb ev_bind } -- | Mark variables as used filling a coercion hole -useVars :: CoVarSet -> TcS () -useVars co_vars +addUsedCoercion :: TcCoercion -> TcS () +addUsedCoercion co = do { ev_binds_var <- getTcEvBindsVar - ; let ref = ebv_tcvs ev_binds_var - ; wrapTcS $ - do { tcvs <- TcM.readTcRef ref - ; let tcvs' = tcvs `unionVarSet` co_vars - ; TcM.writeTcRef ref tcvs' } } + ; wrapTcS (TcM.updTcRef (ebv_tcvs ev_binds_var) (co :)) } -- | Equalities only -setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS () +setWantedEq :: HasDebugCallStack => TcEvDest -> TcCoercion -> TcS () setWantedEq (HoleDest hole) co - = do { useVars (coVarsOfCo co) + = do { addUsedCoercion co ; fillCoercionHole hole co } setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) @@ -2009,7 +2005,7 @@ setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS () setWantedEvTerm (HoleDest hole) _canonical tm | Just co <- evTermCoercion_maybe tm - = do { useVars (coVarsOfCo co) + = do { addUsedCoercion co ; fillCoercionHole hole co } | otherwise = -- See Note [Yukky eq_sel for a HoleDest] ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Tc.Solver.Monad as TcS import GHC.Core.Predicate import GHC.Core.Reduction import GHC.Core.Coercion +import GHC.Core.TyCo.FVs( coVarsOfCos ) import GHC.Core.Class( classHasSCs ) import GHC.Types.Id( idType ) @@ -546,7 +547,7 @@ neededEvVars implic@(Implic { ic_info = info , ic_need_implic = old_need_implic -- See (TRC1) }) = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + ; used_cos <- TcS.getTcEvTyCoVars ev_binds_var ; let -- Find the variables needed by `implics` new_need_implic@(ENS { ens_dms = dm_seeds, ens_fvs = other_seeds }) @@ -556,7 +557,8 @@ neededEvVars implic@(Implic { ic_info = info -- Get the variables needed by the solved bindings -- (It's OK to use a non-deterministic fold here -- because add_wanted is commutative.) - seeds_w = nonDetStrictFoldEvBindMap add_wanted tcvs ev_binds + used_covars = coVarsOfCos used_cos + seeds_w = nonDetStrictFoldEvBindMap add_wanted used_covars ev_binds need_ignoring_dms = findNeededGivenEvVars ev_binds (other_seeds `unionVarSet` seeds_w) need_from_dms = findNeededGivenEvVars ev_binds dm_seeds @@ -577,7 +579,7 @@ neededEvVars implic@(Implic { ic_info = info ; traceTcS "neededEvVars" $ vcat [ text "old_need_implic:" <+> ppr old_need_implic , text "new_need_implic:" <+> ppr new_need_implic - , text "tcvs:" <+> ppr tcvs + , text "used_covars:" <+> ppr used_covars , text "need_ignoring_dms:" <+> ppr need_ignoring_dms , text "need_from_dms:" <+> ppr need_from_dms , text "need:" <+> ppr need ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -360,11 +360,13 @@ data EvBindsVar -- (dictionaries etc) -- Some Given, some Wanted - ebv_tcvs :: IORef CoVarSet - -- The free Given coercion vars needed by Wanted coercions that - -- are solved by filling in their HoleDest in-place. Since they - -- don't appear in ebv_binds, we keep track of their free - -- variables so that we can report unused given constraints + ebv_tcvs :: IORef [TcCoercion] + -- When we solve a Wanted by filling in a CoercionHole, it is as + -- if we were adding an evidence binding + -- co_hole := coercion + -- We keep all these RHS coercions in a list, alongside `ebv_binds`, + -- so that we can report unused given constraints, + -- in GHC.Tc.Solver.neededEvVars -- See Note [Tracking redundant constraints] in GHC.Tc.Solver } @@ -372,7 +374,7 @@ data EvBindsVar -- See above for comments on ebv_uniq, ebv_tcvs ebv_uniq :: Unique, - ebv_tcvs :: IORef CoVarSet + ebv_tcvs :: IORef [TcCoercion] } instance Data.Data TcEvBinds where ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1762,7 +1762,7 @@ addTopEvBinds new_ev_binds thing_inside newTcEvBinds :: TcM EvBindsVar newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet + ; tcvs_ref <- newTcRef [] ; uniq <- newUnique ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) ; return (EvBindsVar { ebv_binds = binds_ref @@ -1774,7 +1774,7 @@ newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap -- must be made monadically newNoTcEvBinds :: TcM EvBindsVar newNoTcEvBinds - = do { tcvs_ref <- newTcRef emptyVarSet + = do { tcvs_ref <- newTcRef [] ; uniq <- newUnique ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref @@ -1785,14 +1785,14 @@ cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar -- solving don't pollute the original cloneEvBindsVar ebv@(EvBindsVar {}) = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet + ; tcvs_ref <- newTcRef [] ; return (ebv { ebv_binds = binds_ref , ebv_tcvs = tcvs_ref }) } cloneEvBindsVar ebv@(CoEvBindsVar {}) - = do { tcvs_ref <- newTcRef emptyVarSet + = do { tcvs_ref <- newTcRef [] ; return (ebv { ebv_tcvs = tcvs_ref }) } -getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet +getTcEvTyCoVars :: EvBindsVar -> TcM [TcCoercion] getTcEvTyCoVars ev_binds_var = readTcRef (ebv_tcvs ev_binds_var) @@ -1817,15 +1817,15 @@ updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_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) } + ; updTcRef old_tcv_ref (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) } + ; updTcRef old_tcv_ref (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) } + ; updTcRef old_tcv_ref (new_tcvs ++) } updTcEvBinds old_var new_var = pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var) -- Terms inside types, no good ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -2444,14 +2444,11 @@ checkTypeHasFixedRuntimeRep prov ty = unless (typeHasFixedRuntimeRep ty) (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) -{- -%************************************************************************ -%* * +{- ********************************************************************** +* * Error messages * * -************************************************************************* - --} +********************************************************************** -} -- See Note [Naughty quantification candidates] naughtyQuantification :: TcType -- original type user wanted to quantify View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b02492f969c106ed3c733393ef159c5... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b02492f969c106ed3c733393ef159c5... You're receiving this email because of your account on gitlab.haskell.org.