Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC
Commits:
-
73f3d1a9
by Simon Peyton Jones at 2025-06-23T23:40:01+01:00
3 changed files:
Changes:
| ... | ... | @@ -481,9 +481,8 @@ can_eq_nc_forall ev eq_rel s1 s2 |
| 481 | 481 | , ppr flags1, ppr flags2 ]
|
| 482 | 482 | ; canEqHardFailure ev s1 s2 }
|
| 483 | 483 | |
| 484 | - else do {
|
|
| 485 | - traceTcS "Creating implication for polytype equality" (ppr ev)
|
|
| 486 | - ; let free_tvs = tyCoVarsOfTypes [s1,s2]
|
|
| 484 | + else
|
|
| 485 | + do { let free_tvs = tyCoVarsOfTypes [s1,s2]
|
|
| 487 | 486 | empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs
|
| 488 | 487 | skol_info_anon = UnifyForAllSkol phi1
|
| 489 | 488 | ; skol_info <- mkSkolemInfo skol_info_anon
|
| ... | ... | @@ -525,12 +524,15 @@ can_eq_nc_forall ev eq_rel s1 s2 |
| 525 | 524 | |
| 526 | 525 | init_subst2 = mkEmptySubst (substInScopeSet subst1)
|
| 527 | 526 | |
| 527 | + ; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2)
|
|
| 528 | + |
|
| 528 | 529 | -- Generate the constraints that live in the body of the implication
|
| 529 | 530 | -- See (SF5) in Note [Solving forall equalities]
|
| 530 | 531 | ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $
|
| 531 | 532 | unifyForAllBody ev (eqRelRole eq_rel) $ \uenv ->
|
| 532 | 533 | go uenv skol_tvs init_subst2 bndrs1 bndrs2
|
| 533 | 534 | |
| 535 | + ; traceTcS "Trying to solve the immplication" (ppr s1 $$ ppr s2 $$ ppr wanteds)
|
|
| 534 | 536 | ; ev_binds_var <- newNoTcEvBinds
|
| 535 | 537 | ; solved <- trySolveImplication $
|
| 536 | 538 | (implicationPrototype (ctLocEnv loc))
|
| ... | ... | @@ -1363,7 +1363,10 @@ tryTcS (TcS thing_inside) |
| 1363 | 1363 | , tcs_inerts = new_inert_var
|
| 1364 | 1364 | , tcs_worklist = new_wl_var }
|
| 1365 | 1365 | |
| 1366 | - ; TcM.traceTc "tryTcS {" (ppr old_inerts)
|
|
| 1366 | + ; TcM.traceTc "tryTcS {" $
|
|
| 1367 | + vcat [ text "old_ev_binds:" <+> ppr old_ev_binds_var
|
|
| 1368 | + , text "new_ev_binds:" <+> ppr new_ev_binds_var
|
|
| 1369 | + , ppr old_inerts ]
|
|
| 1367 | 1370 | ; wc <- thing_inside nest_env
|
| 1368 | 1371 | ; TcM.traceTc "tryTcS }" (ppr wc)
|
| 1369 | 1372 | |
| ... | ... | @@ -1371,8 +1374,7 @@ tryTcS (TcS thing_inside) |
| 1371 | 1374 | then return False
|
| 1372 | 1375 | else do { -- Successfully solved
|
| 1373 | 1376 | -- Add the new bindings to the existing ones
|
| 1374 | - new_ev_binds <- TcM.getTcEvBindsMap new_ev_binds_var
|
|
| 1375 | - ; TcM.updTcEvBindsMap old_ev_binds_var (`unionEvBindMap` new_ev_binds)
|
|
| 1377 | + ; TcM.updTcEvBinds old_ev_binds_var new_ev_binds_var
|
|
| 1376 | 1378 | |
| 1377 | 1379 | -- Update the existing inert set
|
| 1378 | 1380 | ; new_inerts <- TcM.readTcRef new_inert_var
|
| ... | ... | @@ -102,7 +102,7 @@ module GHC.Tc.Utils.Monad( |
| 102 | 102 | -- * Type constraints
|
| 103 | 103 | newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
|
| 104 | 104 | addTcEvBind, addTcEvBinds, addTopEvBinds,
|
| 105 | - getTcEvBindsMap, setTcEvBindsMap, updTcEvBindsMap,
|
|
| 105 | + getTcEvBindsMap, setTcEvBindsMap, updTcEvBinds,
|
|
| 106 | 106 | getTcEvTyCoVars, chooseUniqueOccTc,
|
| 107 | 107 | getConstraintVar, setConstraintVar,
|
| 108 | 108 | emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
|
| ... | ... | @@ -1811,11 +1811,24 @@ setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds |
| 1811 | 1811 | | otherwise
|
| 1812 | 1812 | = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
|
| 1813 | 1813 | |
| 1814 | -updTcEvBindsMap :: EvBindsVar -> (EvBindMap -> EvBindMap) -> TcM ()
|
|
| 1815 | -updTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) upd
|
|
| 1816 | - = updTcRef ev_ref upd
|
|
| 1817 | -updTcEvBindsMap v@(CoEvBindsVar {}) _
|
|
| 1818 | - = pprPanic "updTcEvBindsMap" (ppr v)
|
|
| 1814 | +updTcEvBinds :: EvBindsVar -> EvBindsVar -> TcM ()
|
|
| 1815 | +updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_tcv_ref })
|
|
| 1816 | + (EvBindsVar { ebv_binds = new_ebv_ref, ebv_tcvs = new_tcv_ref })
|
|
| 1817 | + = do { new_ebvs <- readTcRef new_ebv_ref
|
|
| 1818 | + ; updTcRef old_ebv_ref (`unionEvBindMap` new_ebvs)
|
|
| 1819 | + ; new_tcvs <- readTcRef new_tcv_ref
|
|
| 1820 | + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) }
|
|
| 1821 | +updTcEvBinds (EvBindsVar { ebv_tcvs = old_tcv_ref })
|
|
| 1822 | + (CoEvBindsVar { ebv_tcvs = new_tcv_ref })
|
|
| 1823 | + = do { new_tcvs <- readTcRef new_tcv_ref
|
|
| 1824 | + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) }
|
|
| 1825 | +updTcEvBinds (CoEvBindsVar { ebv_tcvs = old_tcv_ref })
|
|
| 1826 | + (CoEvBindsVar { ebv_tcvs = new_tcv_ref })
|
|
| 1827 | + = do { new_tcvs <- readTcRef new_tcv_ref
|
|
| 1828 | + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) }
|
|
| 1829 | +updTcEvBinds old_var new_var
|
|
| 1830 | + = pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var)
|
|
| 1831 | + -- Terms inside types, no good
|
|
| 1819 | 1832 | |
| 1820 | 1833 | addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
|
| 1821 | 1834 | -- Add a binding to the TcEvBinds by side effect
|