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
-
23570d20
by Simon Peyton Jones at 2025-07-23T23:38:25+01:00
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:
| ... | ... | @@ -86,14 +86,15 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) |
| 86 | 86 | = assertPpr (ctEvRewriteRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $
|
| 87 | 87 | do { simpleStage $ traceTcS "solveDict" (ppr dict_ct)
|
| 88 | 88 | |
| 89 | + -- Look in the inert dictionaries
|
|
| 89 | 90 | ; tryInertDicts dict_ct
|
| 91 | + |
|
| 92 | + -- Try top-level instances
|
|
| 90 | 93 | ; tryInstances dict_ct
|
| 91 | 94 | |
| 92 | 95 | -- Try fundeps /after/ tryInstances:
|
| 93 | 96 | -- see (DFL2) in Note [Do fundeps last]
|
| 94 | --- ; doLocalFunDepImprovement dict_ct
|
|
| 95 | - -- doLocalFunDepImprovement does StartAgain if there
|
|
| 96 | - -- are any fundeps: see (DFL1) in Note [Do fundeps last]
|
|
| 97 | + ; doDictFunDepImprovement dict_ct
|
|
| 97 | 98 | |
| 98 | 99 | ; simpleStage (updInertDicts dict_ct)
|
| 99 | 100 | ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" }
|
| ... | ... | @@ -10,6 +10,8 @@ module GHC.Tc.Solver.FunDeps ( |
| 10 | 10 | |
| 11 | 11 | import GHC.Prelude
|
| 12 | 12 | |
| 13 | +import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds )
|
|
| 14 | + |
|
| 13 | 15 | import GHC.Tc.Instance.FunDeps
|
| 14 | 16 | import GHC.Tc.Types.Evidence
|
| 15 | 17 | import GHC.Tc.Types.Constraint
|
| ... | ... | @@ -295,7 +297,7 @@ as the fundeps. |
| 295 | 297 | #7875 is a case in point.
|
| 296 | 298 | -}
|
| 297 | 299 | |
| 298 | -doDictFunDepImprovement :: DictCt -> SolverStage Void
|
|
| 300 | +doDictFunDepImprovement :: DictCt -> SolverStage ()
|
|
| 299 | 301 | -- (doDictFunDepImprovement inst_envs cts)
|
| 300 | 302 | -- * Generate the fundeps from interacting the
|
| 301 | 303 | -- top-level `inst_envs` with the constraints `cts`
|
| ... | ... | @@ -306,13 +308,26 @@ doDictFunDepImprovement :: DictCt -> SolverStage Void |
| 306 | 308 | -- are any fundeps: see (DFL1) in Note [Do fundeps last]
|
| 307 | 309 | |
| 308 | 310 | doDictFunDepImprovement dict_ct
|
| 309 | - = do { inst_envs <- getInstEnvs
|
|
| 310 | - ; imp_res1 <- do_dict_local_fds dict_ct
|
|
| 311 | - ; if noImprovement imp_res1
|
|
| 312 | - then do { imp_res2 <- do_one_top inst_envs dict_ct
|
|
| 313 | - ; return (imp_res `plusImprovements` imp_res2) }
|
|
| 314 | - else return (imp_res `plusImprovements` imp_res1) }
|
|
| 311 | + = Stage $
|
|
| 312 | + -- Local dictionaries
|
|
| 313 | + do { inst_envs <- getInstEnvs
|
|
| 314 | + ; imp1 <- solveFunDeps (do_dict_local_fds dict_ct)
|
|
| 315 | + ; if imp1 then start_again else
|
|
| 316 | + -- Top-level instances dictionaries
|
|
| 317 | + do { imp2 <- solveFunDeps (do_one_top inst_envs dict_ct)
|
|
| 318 | + ; if imp2 then start_again
|
|
| 319 | + else continueWith () } }
|
|
| 320 | + where
|
|
| 321 | + start_again = startAgainWith (CDictCan dict_ct)
|
|
| 315 | 322 | |
| 323 | +solveFunDeps :: TcS ImprovementResult -> TcS Bool
|
|
| 324 | +solveFunDeps generate_eqs
|
|
| 325 | + = do { (eqs, imp1) <- generate_eqs
|
|
| 326 | + ; if isEmptyBag eqs
|
|
| 327 | + then return imp1
|
|
| 328 | + else do { imp2 <- nestFunDepsTcS $
|
|
| 329 | + solveWanteds eqs
|
|
| 330 | + ; return (imp1 || imp2) } }
|
|
| 316 | 331 | |
| 317 | 332 | do_one_top :: InstEnvs -> DictCt -> TcS ImprovementResult
|
| 318 | 333 | 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 |
| 340 | 355 | -- Using functional dependencies, interact the DictCt with the
|
| 341 | 356 | -- inert Givens and Wanteds, to produce new equalities
|
| 342 | 357 | do_dict_local_fds dict_ct@(DictCt { di_cls = cls, di_ev = wanted_ev })
|
| 343 | - -- locals contains all the Givens and earlier Wanteds
|
|
| 344 | 358 | = do { inerts <- getInertCans
|
| 345 | 359 | ; foldM do_interaction noopImprovement $
|
| 346 | 360 | findDictsByClass locals cls }
|
| ... | ... | @@ -1353,6 +1353,30 @@ nestTcS (TcS thing_inside) |
| 1353 | 1353 | |
| 1354 | 1354 | ; return res }
|
| 1355 | 1355 | |
| 1356 | +nestFunDepsTcS :: TcS a -> TcS Bool
|
|
| 1357 | +nestFunDepsTcS (TcS thing_inside)
|
|
| 1358 | + = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var
|
|
| 1359 | + , tcs_unif_lvl = unif_lvl_var }) ->
|
|
| 1360 | + do { inerts <- TcM.readTcRef inerts_var
|
|
| 1361 | + ; new_inert_var <- TcM.newTcRef inerts
|
|
| 1362 | + ; new_wl_var <- TcM.newTcRef emptyWorkList
|
|
| 1363 | + ; new_unif_lvl_var <- TcM.newTcRef Nothing
|
|
| 1364 | + ; let nest_env = env { tcs_inerts = new_inert_var
|
|
| 1365 | + , tcs_worklist = new_wl_var
|
|
| 1366 | + , tcs_unif_lvl = new_unif_lvl_var }
|
|
| 1367 | + |
|
| 1368 | + ; (inner_lvl, res) <- TcM.pushTcLevelM $
|
|
| 1369 | + thing_inside nest_env
|
|
| 1370 | + |
|
| 1371 | + ; mb_lvl <- TcM.readTcRef new_unif_lvl_var
|
|
| 1372 | + ; case mb_lvl of
|
|
| 1373 | + Just lvl | lvl < inner_lvl
|
|
| 1374 | + -> do { setUnificationFlag lvl
|
|
| 1375 | + ; return True }
|
|
| 1376 | + _ -> return False -- No unifications (except of vars
|
|
| 1377 | + -- generated in the fundep stuff itself)
|
|
| 1378 | + }
|
|
| 1379 | + |
|
| 1356 | 1380 | emitImplicationTcS :: TcLevel -> SkolemInfoAnon
|
| 1357 | 1381 | -> [TcTyVar] -- Skolems
|
| 1358 | 1382 | -> [EvVar] -- Givens
|
| 1 | +module GHC.Tc.Solver.Solve where
|
|
| 2 | + |
|
| 3 | +import GHC.Tc.Solver.Monad
|
|
| 4 | +import GHC.Tc.Types.Constraint
|
|
| 5 | + |
|
| 6 | +solveSimpleWanteds :: Cts -> TcS WantedConstraints |