Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 0c5da224 by Simon Peyton Jones at 2025-07-05T17:45:38+01:00 This completes moving dict fundeps to the main loop - - - - - 4 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 Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -10,7 +10,7 @@ module GHC.Tc.Solver.Dict ( solveCallStack, -- For GHC.Tc.Solver -- * Functional dependencies - generateTopFunDeps + doTopFunDepImprovement, doLocalFunDepImprovement ) where import GHC.Prelude @@ -95,7 +95,7 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) -- Try fundeps /after/ tryInstances: -- see (DFL2) in Note [Do fundeps last] - ; doLocalFunDepImprovement dict_ct +-- ; doLocalFunDepImprovement dict_ct -- doLocalFunDepImprovement does StartAgain if there -- are any fundeps: see (DFL1) in Note [Do fundeps last] @@ -1434,7 +1434,7 @@ But in general it's a bit painful to figure out the necessary coercion, so we just take the first approach. Here is a better example. Consider: class C a b c | a -> b And: - [G] d1 : C T Int Char + [G] d1 : C T Int Char [W] d2 : C T beta Int In this case, it's *not even possible* to solve the wanted immediately. So we should simply output the functional dependency and add this guy @@ -1630,16 +1630,23 @@ as the fundeps. #7875 is a case in point. -} -generateTopFunDeps :: InstEnvs -> Cts -> [FunDepEqn (CtLoc, RewriterSet)] +doTopFunDepImprovement :: Bag DictCt -> TcS (Cts, Bool) +-- (doFunDeps inst_envs cts) +-- * Generate the fundeps from interacting the +-- top-level `inst_envs` with the constraints `cts` +-- * Do the unifications and return any unsolved constraints -- See Note [Fundeps with instances, and equality orientation] -generateTopFunDeps inst_evs cts - = foldMap do_top cts -- "RAE" `unionBags` interactions +doTopFunDepImprovement cts + = do { inst_envs <- getInstEnvs + ; do_dict_fundeps (do_one inst_envs) cts } where - do_top :: Ct -> [FunDepEqn (CtLoc, RewriterSet)] - do_top (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = xis })) - = assert (not (isGiven ev)) $ - improveFromInstEnv inst_evs mk_ct_loc cls xis + do_one :: InstEnvs -> DictCt -> TcS (Cts, Bool) + do_one inst_envs (DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) + = unifyFunDepWanteds ev eqns where + eqns :: [FunDepEqn (CtLoc, RewriterSet)] + eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis + dict_pred = mkClassPred cls xis dict_loc = ctEvLoc ev dict_origin = ctLocOrigin dict_loc @@ -1655,93 +1662,57 @@ generateTopFunDeps inst_evs cts new_orig = FunDepOrigin2 dict_pred dict_origin inst_pred inst_loc - do_top _other = [] - - -doLocalFunDepImprovement :: DictCt -> SolverStage () --- Add wanted constraints from type-class functional dependencies. -doLocalFunDepImprovement dict_ct@(DictCt { di_ev = work_ev, di_cls = cls }) - = Stage $ - do { inerts <- getInertCans - ; imp <- foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls) - ; if imp then startAgainWith (CDictCan dict_ct) - else continueWith () } +doLocalFunDepImprovement :: Bag DictCt -> TcS (Cts,Bool) +-- Add wanted constraints from type-class functional dependencies +-- against Givens +doLocalFunDepImprovement cts + = do { inerts <- getInertCans -- The inert_dicts are all Givens + ; do_dict_fundeps (do_one (inert_dicts inerts)) cts } where - work_pred = ctEvPred work_ev - work_loc = ctEvLoc work_ev - - add_fds :: Bool -> DictCt -> TcS Bool - add_fds so_far (DictCt { di_ev = inert_ev }) - | isGiven work_ev && isGiven inert_ev - -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] - = return so_far - | otherwise - = do { traceTcS "doLocalFunDepImprovement" (vcat - [ ppr work_ev - , pprCtLoc work_loc, ppr (isGivenLoc work_loc) - , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) - , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) - - ; (new_eqs, unifs) - <- unifyFunDepWanteds work_ev $ - improveFromAnother (derived_loc, inert_rewriters) - inert_pred work_pred - - -- Emit the deferred constraints - -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality - -- - -- All the constraints in `cts` share the same rewriter set so, - -- rather than looking at it one by one, we pass it to - -- extendWorkListChildEqs; just a small optimisation. - ; unless (isEmptyBag cts) $ - updWorkListTcS (extendWorkListChildEqs ev new_eqs) - - ; return (so_far || unifs) - } + do_one givens (DictCt { di_cls = cls, di_ev = wanted_ev }) + = do_dict_fundeps do_one_given (findDictsByClass givens cls) where - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - inert_rewriters = ctEvRewriters inert_ev - derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` - ctl_depth inert_loc - , ctl_origin = FunDepOrigin1 work_pred - (ctLocOrigin work_loc) - (ctLocSpan work_loc) - inert_pred - (ctLocOrigin inert_loc) - (ctLocSpan inert_loc) } - -doTopFunDepImprovement :: DictCt -> SolverStage () --- Try to functional-dependency improvement between the constraint --- and the top-level instance declarations --- See Note [Fundeps with instances, and equality orientation] --- See also Note [Weird fundeps] -doTopFunDepImprovement dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) - | isGiven ev -- No improvement for Givens - = Stage $ continueWith () - | otherwise - = Stage $ - do { traceTcS "try_fundeps" (ppr dict_ct) - ; instEnvs <- getInstEnvs - ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis - ; imp <- emitFunDepWanteds ev fundep_eqns - ; if imp then startAgainWith (CDictCan dict_ct) - else continueWith () } + wanted_pred = ctEvPred wanted_ev + wanted_loc = ctEvLoc wanted_ev + + do_one_given :: DictCt -> TcS (Cts,Bool) + do_one_given (DictCt { di_ev = given_ev }) + = do { traceTcS "doLocalFunDepImprovement" $ + vcat [ ppr wanted_ev + , pprCtLoc wanted_loc, ppr (isGivenLoc wanted_loc) + , pprCtLoc given_loc, ppr (isGivenLoc given_loc) + , pprCtLoc deriv_loc, ppr (isGivenLoc deriv_loc) ] + + ; unifyFunDepWanteds wanted_ev $ + improveFromAnother (deriv_loc, given_rewriters) + given_pred wanted_pred } + where + given_pred = ctEvPred given_ev + given_loc = ctEvLoc given_ev + given_rewriters = ctEvRewriters given_ev + deriv_loc = wanted_loc { ctl_depth = deriv_depth + , ctl_origin = deriv_origin } + deriv_depth = ctl_depth wanted_loc `maxSubGoalDepth` + ctl_depth given_loc + deriv_origin = FunDepOrigin1 wanted_pred + (ctLocOrigin wanted_loc) + (ctLocSpan wanted_loc) + given_pred + (ctLocOrigin given_loc) + (ctLocSpan given_loc) + +do_dict_fundeps :: (DictCt -> TcS (Cts,Bool)) -> Bag DictCt -> TcS (Cts,Bool) +do_dict_fundeps do_dict_fundep cts + = foldr do_one (return (emptyBag, False)) cts where - dict_pred = mkClassPred cls xis - dict_loc = ctEvLoc ev - dict_origin = ctLocOrigin dict_loc - dict_rewriters = ctEvRewriters ev - - mk_ct_loc :: ClsInst -- The instance decl - -> (CtLoc, RewriterSet) - mk_ct_loc ispec - = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc } - , dict_rewriters ) - where - inst_pred = mkClassPred cls (is_tys ispec) - inst_loc = getSrcSpan (is_dfun ispec) + do_one :: DictCt -> TcS (Cts,Bool) -> TcS (Cts,Bool) + do_one dict_ct do_rest + = -- assert (not (isGiven (dictCtEvidence dict_ct)) $ + do { (cts1, unifs1) <- do_dict_fundep dict_ct + ; if isEmptyBag cts1 && not unifs1 + then do_rest -- Common case + else do { (cts2, unifs2) <- do_rest + ; return (cts1 `unionBags` cts2, unifs1 || unifs2) } } {- ********************************************************************* ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -118,7 +118,7 @@ solveEquality ev eq_rel ty1 ty2 ; solveIrred irred_ct } ; Right eq_ct -> do { tryInertEqs eq_ct - ; tryFunDeps eq_rel eq_ct + ; tryFunDeps eq_ct ; tryQCsEqCt eq_ct ; simpleStage (updInertEqs eq_ct) ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } } @@ -3044,8 +3044,8 @@ equality with the template on the left. Delicate, but it works. -} -------------------- -tryFunDeps :: EqRel -> EqCt -> SolverStage () -tryFunDeps eq_rel work_item@(EqCt { eq_lhs = lhs, eq_ev = ev }) +tryFunDeps :: EqCt -> SolverStage () +tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel }) | NomEq <- eq_rel , TyFamLHS tc args <- lhs = Stage $ @@ -3264,7 +3264,7 @@ improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs = do { traceTcS "interactFunEq improvements: " $ vcat [ text "Eqns:" <+> ppr improvement_eqns , text "Candidates:" <+> ppr funeqs_for_tc ] - ; emitFunDepWanteds work_ev improvement_eqns } + ; unifyAndEmitFunDepWanteds work_ev improvement_eqns } where work_loc = ctEvLoc work_ev work_pred = ctEvPred work_ev ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Tc.Solver.Monad ( -- Unification wrapUnifierX, wrapUnifierTcS, unifyFunDeps, uPairsTcM, unifyForAllBody, - unifyFunDepWanteds, + unifyFunDepWanteds, unifyAndEmitFunDepWanteds, -- MetaTyVars newFlexiTcSTy, instFlexiX, @@ -2243,6 +2243,23 @@ solverDepthError loc ty ************************************************************************ -} +unifyAndEmitFunDepWanteds :: CtEvidence -- The work item + -> [FunDepEqn (CtLoc, RewriterSet)] + -> TcS Bool -- True <=> some unification happened +unifyAndEmitFunDepWanteds ev fd_eqns + = do { (new_eqs, unifs) <- unifyFunDepWanteds ev fd_eqns + + ; -- Emit the deferred constraints + -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality + -- + -- All the constraints in `cts` share the same rewriter set so, + -- rather than looking at it one by one, we pass it to + -- extendWorkListChildEqs; just a small optimisation. + ; unless (isEmptyBag new_eqs) $ + updWorkListTcS (extendWorkListChildEqs ev new_eqs) + + ; return unifs } + unifyFunDepWanteds :: CtEvidence -- The work item -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS (Cts, Bool) -- True <=> some unification happened ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -26,7 +26,6 @@ import GHC.Tc.Types import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc( mkGivenLoc ) -import GHC.Tc.Instance.FunDeps ( FunDepEqn(..) ) import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Tc.Utils.Monad as TcM @@ -47,7 +46,6 @@ import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet ) import GHC.Data.Bag import GHC.Data.Maybe -import GHC.Data.Pair import GHC.Utils.Outputable import GHC.Utils.Panic @@ -207,14 +205,21 @@ maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples }) | otherwise = return Nothing + dicts :: Bag DictCt + dicts = mapMaybeBag is_dict simples + where + is_dict (CDictCan d) = Just d + is_dict _ = Nothing + try_fundeps :: TcS (Maybe NextAction) try_fundeps - = do { inst_envs <- getInstEnvs - ; let fundep_eqns = generateTopFunDeps inst_envs simples - ; (new_eqs, unif_happened) <- unifyFunDepWanteds fundep_eqns - ; if null new_eqs && not unif_happened + = do { (new_eqs1, unifs1) <- doTopFunDepImprovement dicts + ; (new_eqs2, unifs2) <- doLocalFunDepImprovement dicts + ; let new_eqs = new_eqs1 `unionBags` new_eqs2 + unifs = unifs1 || unifs2 + ; if null new_eqs && not unifs then return Nothing - else return (Just (NA_TryAgain (wc `addSimples` new_eqs) unif_happened)) } + else return (Just (NA_TryAgain (wc `addSimples` new_eqs) unifs)) } {- Note [Superclass iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c5da2245dd48e9f3dacefebeac4a145... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c5da2245dd48e9f3dacefebeac4a145... You're receiving this email because of your account on gitlab.haskell.org.