Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: b071f3c5 by Simon Peyton Jones at 2025-07-23T23:37:49+01:00 Work in progress [skip ci] - - - - - 23570d20 by Simon Peyton Jones at 2025-07-23T23:38:25+01:00 Add hs-boot file [skip ci] - - - - - 4 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/Monad.hs - + compiler/GHC/Tc/Solver/Solve.hs-boot Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -86,14 +86,15 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) = assertPpr (ctEvRewriteRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ do { simpleStage $ traceTcS "solveDict" (ppr dict_ct) + -- Look in the inert dictionaries ; tryInertDicts dict_ct + + -- Try top-level instances ; tryInstances dict_ct -- Try fundeps /after/ tryInstances: -- see (DFL2) in Note [Do fundeps last] --- ; doLocalFunDepImprovement dict_ct - -- doLocalFunDepImprovement does StartAgain if there - -- are any fundeps: see (DFL1) in Note [Do fundeps last] + ; doDictFunDepImprovement dict_ct ; simpleStage (updInertDicts dict_ct) ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -10,6 +10,8 @@ module GHC.Tc.Solver.FunDeps ( import GHC.Prelude +import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds ) + import GHC.Tc.Instance.FunDeps import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint @@ -295,7 +297,7 @@ as the fundeps. #7875 is a case in point. -} -doDictFunDepImprovement :: DictCt -> SolverStage Void +doDictFunDepImprovement :: DictCt -> SolverStage () -- (doDictFunDepImprovement inst_envs cts) -- * Generate the fundeps from interacting the -- top-level `inst_envs` with the constraints `cts` @@ -306,13 +308,26 @@ doDictFunDepImprovement :: DictCt -> SolverStage Void -- are any fundeps: see (DFL1) in Note [Do fundeps last] doDictFunDepImprovement dict_ct - = do { inst_envs <- getInstEnvs - ; imp_res1 <- do_dict_local_fds dict_ct - ; if noImprovement imp_res1 - then do { imp_res2 <- do_one_top inst_envs dict_ct - ; return (imp_res `plusImprovements` imp_res2) } - else return (imp_res `plusImprovements` imp_res1) } + = Stage $ + -- Local dictionaries + do { inst_envs <- getInstEnvs + ; imp1 <- solveFunDeps (do_dict_local_fds dict_ct) + ; if imp1 then start_again else + -- Top-level instances dictionaries + do { imp2 <- solveFunDeps (do_one_top inst_envs dict_ct) + ; if imp2 then start_again + else continueWith () } } + where + start_again = startAgainWith (CDictCan dict_ct) +solveFunDeps :: TcS ImprovementResult -> TcS Bool +solveFunDeps generate_eqs + = do { (eqs, imp1) <- generate_eqs + ; if isEmptyBag eqs + then return imp1 + else do { imp2 <- nestFunDepsTcS $ + solveWanteds eqs + ; return (imp1 || imp2) } } do_one_top :: InstEnvs -> DictCt -> TcS ImprovementResult do_one_top inst_envs (DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) @@ -340,7 +355,6 @@ do_dict_local_fds :: DictCt -> TcS ImprovementResult -- Using functional dependencies, interact the DictCt with the -- inert Givens and Wanteds, to produce new equalities do_dict_local_fds dict_ct@(DictCt { di_cls = cls, di_ev = wanted_ev }) - -- locals contains all the Givens and earlier Wanteds = do { inerts <- getInertCans ; foldM do_interaction noopImprovement $ findDictsByClass locals cls } ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1353,6 +1353,30 @@ nestTcS (TcS thing_inside) ; return res } +nestFunDepsTcS :: TcS a -> TcS Bool +nestFunDepsTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var + , tcs_unif_lvl = unif_lvl_var }) -> + do { inerts <- TcM.readTcRef inerts_var + ; new_inert_var <- TcM.newTcRef inerts + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; new_unif_lvl_var <- TcM.newTcRef Nothing + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var + , tcs_unif_lvl = new_unif_lvl_var } + + ; (inner_lvl, res) <- TcM.pushTcLevelM $ + thing_inside nest_env + + ; mb_lvl <- TcM.readTcRef new_unif_lvl_var + ; case mb_lvl of + Just lvl | lvl < inner_lvl + -> do { setUnificationFlag lvl + ; return True } + _ -> return False -- No unifications (except of vars + -- generated in the fundep stuff itself) + } + emitImplicationTcS :: TcLevel -> SkolemInfoAnon -> [TcTyVar] -- Skolems -> [EvVar] -- Givens ===================================== compiler/GHC/Tc/Solver/Solve.hs-boot ===================================== @@ -0,0 +1,6 @@ +module GHC.Tc.Solver.Solve where + +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Constraint + +solveSimpleWanteds :: Cts -> TcS WantedConstraints View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9a428316d587d88158f56fc0161257... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9a428316d587d88158f56fc0161257... You're receiving this email because of your account on gitlab.haskell.org.