Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: e9fc82be by Simon Peyton Jones at 2025-07-07T12:00:22+01:00 Wibbles - - - - - 2 changed files: - compiler/GHC/Tc/Solver/Dict.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 - doTopFunDepImprovement, doLocalFunDepImprovement + doDictFunDepImprovement ) where import GHC.Prelude @@ -59,6 +59,7 @@ import GHC.Driver.DynFlags import qualified GHC.LanguageExtensions as LangExt +import Data.Foldable( foldrM ) import Data.Maybe ( listToMaybe, mapMaybe, isJust ) import Data.Void( Void ) @@ -1630,92 +1631,93 @@ as the fundeps. #7875 is a case in point. -} -doTopFunDepImprovement :: Bag DictCt -> TcS (Cts, Bool) --- (doFunDeps inst_envs cts) +doDictFunDepImprovement :: Cts -> TcS (Cts, Bool) +-- (doDictFunDepImprovement 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] -doTopFunDepImprovement cts - = do { inst_envs <- getInstEnvs - ; do_dict_fundeps (do_one inst_envs) cts } +doDictFunDepImprovement unsolved_wanteds + = do { inerts <- getInertCans -- The inert_dicts are all Givens + ; inst_envs <- getInstEnvs + ; (_, new_eqs, unifs) <- foldrM (do_one_dict inst_envs) + (inert_dicts inerts, emptyBag, False) + unsolved_wanteds + ; return (new_eqs, unifs) } + +do_one_dict :: InstEnvs -> Ct + -> (DictMap DictCt, Cts, Bool) + -> TcS (DictMap DictCt, Cts, Bool) +do_one_dict inst_envs (CDictCan dict_ct) (local_dicts, new_eqs, unifs) + = do { (new_eqs1, unifs1) <- do_one_top inst_envs dict_ct + ; (local_dicts2, new_eqs2, unifs2) <- do_one_local local_dicts dict_ct + ; return ( local_dicts2 + , new_eqs1 `unionBags` new_eqs2 `unionBags` new_eqs + , unifs1 || unifs2 || unifs ) } + +do_one_dict _ _ acc -- Non-DictCt constraints + = return acc + +do_one_top :: InstEnvs -> DictCt -> TcS (Cts, Bool) +do_one_top inst_envs (DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) + = unifyFunDepWanteds ev eqns where - do_one :: InstEnvs -> DictCt -> TcS (Cts, Bool) - do_one inst_envs (DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) - = unifyFunDepWanteds ev eqns + 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 + dict_rewriters = ctEvRewriters ev + + mk_ct_loc :: ClsInst -- The instance decl + -> (CtLoc, RewriterSet) + mk_ct_loc ispec + = (dict_loc { ctl_origin = new_orig }, dict_rewriters) 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 - dict_rewriters = ctEvRewriters ev - - mk_ct_loc :: ClsInst -- The instance decl - -> (CtLoc, RewriterSet) - mk_ct_loc ispec - = (dict_loc { ctl_origin = new_orig }, dict_rewriters) - where - inst_pred = mkClassPred cls (is_tys ispec) - inst_loc = getSrcSpan (is_dfun ispec) - new_orig = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc - -doLocalFunDepImprovement :: Bag DictCt -> TcS (Cts,Bool) + inst_pred = mkClassPred cls (is_tys ispec) + inst_loc = getSrcSpan (is_dfun ispec) + new_orig = FunDepOrigin2 dict_pred dict_origin + inst_pred inst_loc + +do_one_local :: DictMap DictCt -> DictCt -> TcS (DictMap DictCt, Cts, Bool) -- Using functional dependencies, interact the unsolved Wanteds -- against each other and the inert Givens, to produce new equalities -doLocalFunDepImprovement wanted - = do { inerts <- getInertCans -- The inert_dicts are all Givens - ; let all_dicts :: DictMap DictCt -- Both Givens and Wanteds - all_dicts = foldr addDict (inert_dicts inerts) wanted - ; do_dict_fundeps (do_one all_dicts) wanted } +do_one_local locals dict_ct@(DictCt { di_cls = cls, di_ev = wanted_ev }) + -- locals contains all the Givens and earlier Wanteds + = do { (new_eqs, unifs) <- foldrM do_interaction (emptyBag, False) $ + findDictsByClass locals cls + ; return (addDict dict_ct locals, new_eqs, unifs) } where - -- all_dicts are all the Givens and all the Wanteds - do_one all_dicts (DictCt { di_cls = cls, di_ev = wanted_ev }) - = do_dict_fundeps do_interaction (findDictsByClass all_dicts cls) + wanted_pred = ctEvPred wanted_ev + wanted_loc = ctEvLoc wanted_ev + + do_interaction :: DictCt -> (Cts,Bool) -> TcS (Cts,Bool) + do_interaction (DictCt { di_ev = all_ev }) (new_eqs, unifs) -- This can be Given or Wanted + = do { traceTcS "doLocalFunDepImprovement" $ + vcat [ ppr wanted_ev + , pprCtLoc wanted_loc, ppr (isGivenLoc wanted_loc) + , pprCtLoc all_loc, ppr (isGivenLoc all_loc) + , pprCtLoc deriv_loc, ppr (isGivenLoc deriv_loc) ] + + ; (new_eqs1, unifs1) <- unifyFunDepWanteds wanted_ev $ + improveFromAnother (deriv_loc, all_rewriters) + all_pred wanted_pred + ; return (new_eqs1 `unionBags` new_eqs, unifs1 || unifs) } where - wanted_pred = ctEvPred wanted_ev - wanted_loc = ctEvLoc wanted_ev - - do_interaction :: DictCt -> TcS (Cts,Bool) - do_interaction (DictCt { di_ev = all_ev }) -- This can be Given or Wanted - = do { traceTcS "doLocalFunDepImprovement" $ - vcat [ ppr wanted_ev - , pprCtLoc wanted_loc, ppr (isGivenLoc wanted_loc) - , pprCtLoc all_loc, ppr (isGivenLoc all_loc) - , pprCtLoc deriv_loc, ppr (isGivenLoc deriv_loc) ] - - ; unifyFunDepWanteds wanted_ev $ - improveFromAnother (deriv_loc, all_rewriters) - all_pred wanted_pred } - where - all_pred = ctEvPred all_ev - all_loc = ctEvLoc all_ev - all_rewriters = ctEvRewriters all_ev - deriv_loc = wanted_loc { ctl_depth = deriv_depth - , ctl_origin = deriv_origin } - deriv_depth = ctl_depth wanted_loc `maxSubGoalDepth` - ctl_depth all_loc - deriv_origin = FunDepOrigin1 wanted_pred - (ctLocOrigin wanted_loc) - (ctLocSpan wanted_loc) - all_pred - (ctLocOrigin all_loc) - (ctLocSpan all_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 - 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) } } + all_pred = ctEvPred all_ev + all_loc = ctEvLoc all_ev + all_rewriters = ctEvRewriters all_ev + deriv_loc = wanted_loc { ctl_depth = deriv_depth + , ctl_origin = deriv_origin } + deriv_depth = ctl_depth wanted_loc `maxSubGoalDepth` + ctl_depth all_loc + deriv_origin = FunDepOrigin1 wanted_pred + (ctLocOrigin wanted_loc) + (ctLocSpan wanted_loc) + all_pred + (ctLocOrigin all_loc) + (ctLocSpan all_loc) {- ********************************************************************* ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -205,18 +205,9 @@ 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 { (new_eqs1, unifs1) <- doTopFunDepImprovement dicts - ; (new_eqs2, unifs2) <- doLocalFunDepImprovement dicts - ; let new_eqs = new_eqs1 `unionBags` new_eqs2 - unifs = unifs1 || unifs2 + = do { (new_eqs, unifs) <- doDictFunDepImprovement simples ; if null new_eqs && not unifs then return Nothing else return (Just (NA_TryAgain (wc `addSimples` new_eqs) unifs)) } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9fc82be442304fc913469f2e416908d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9fc82be442304fc913469f2e416908d... You're receiving this email because of your account on gitlab.haskell.org.