| ... |
... |
@@ -51,9 +51,10 @@ import GHC.Utils.Misc |
|
51
|
51
|
|
|
52
|
52
|
import GHC.Driver.Session
|
|
53
|
53
|
|
|
54
|
|
-import Data.List( deleteFirstsBy )
|
|
55
|
54
|
|
|
56
|
55
|
import Control.Monad
|
|
|
56
|
+
|
|
|
57
|
+import Data.List( deleteFirstsBy )
|
|
57
|
58
|
import Data.Foldable ( traverse_ )
|
|
58
|
59
|
import Data.Maybe ( mapMaybe )
|
|
59
|
60
|
import qualified Data.Semigroup as S
|
| ... |
... |
@@ -551,14 +552,18 @@ neededEvVars implic@(Implic { ic_given = givens |
|
551
|
552
|
= do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
|
|
552
|
553
|
; tcvs <- TcS.getTcEvTyCoVars ev_binds_var
|
|
553
|
554
|
|
|
554
|
|
- ; let seeds1 = foldr add_implic_seeds old_needs implics
|
|
555
|
|
- seeds2 = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds
|
|
556
|
|
- -- It's OK to use a non-deterministic fold here
|
|
557
|
|
- -- because add_wanted is commutative
|
|
558
|
|
- seeds3 = seeds2 `unionVarSet` tcvs
|
|
559
|
|
- need_inner = findNeededEvVars ev_binds seeds3
|
|
560
|
|
- live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds
|
|
561
|
|
- need_outer = varSetMinusEvBindMap need_inner live_ev_binds
|
|
|
555
|
+ ; let seeds_i = get_implic_needs normal_implics
|
|
|
556
|
+ seeds_w = nonDetStrictFoldEvBindMap add_wanted emptyVarSet ev_binds
|
|
|
557
|
+ -- It's OK to use a non-deterministic fold here
|
|
|
558
|
+ -- because add_wanted is commutative
|
|
|
559
|
+ all_seeds = old_needs `unionVarSet` seeds_i `unionVarSet` seeds_w `unionVarSet` tcvs
|
|
|
560
|
+
|
|
|
561
|
+ need_inner_ignoring_dms = findNeededEvVars ev_binds all_seeds
|
|
|
562
|
+ need_inner_from_dms = findNeededEvVars ev_binds (get_implic_needs dm_implics)
|
|
|
563
|
+ need_inner_full = need_inner_ignoring_dms `unionVarSet` need_inner_from_dms
|
|
|
564
|
+ live_ev_binds = filterEvBindMap (needed_ev_bind need_inner_full) ev_binds
|
|
|
565
|
+
|
|
|
566
|
+ need_outer = varSetMinusEvBindMap need_inner_full live_ev_binds
|
|
562
|
567
|
`delVarSetList` givens
|
|
563
|
568
|
|
|
564
|
569
|
; TcS.setTcEvBindsMap ev_binds_var live_ev_binds
|
| ... |
... |
@@ -566,23 +571,26 @@ neededEvVars implic@(Implic { ic_given = givens |
|
566
|
571
|
|
|
567
|
572
|
; traceTcS "neededEvVars" $
|
|
568
|
573
|
vcat [ text "old_needs:" <+> ppr old_needs
|
|
569
|
|
- , text "seeds3:" <+> ppr seeds3
|
|
|
574
|
+ , text "all_seeds:" <+> ppr all_seeds
|
|
570
|
575
|
, text "tcvs:" <+> ppr tcvs
|
|
571
|
576
|
, text "ev_binds:" <+> ppr ev_binds
|
|
572
|
577
|
, text "live_ev_binds:" <+> ppr live_ev_binds ]
|
|
573
|
578
|
|
|
574
|
|
- ; return (implic { ic_need_inner = need_inner
|
|
|
579
|
+ ; return (implic { ic_need_inner = need_inner_ignoring_dms
|
|
575
|
580
|
, ic_need_outer = need_outer }) }
|
|
576
|
581
|
where
|
|
577
|
|
- add_implic_seeds (Implic { ic_need_outer = needs, ic_info = skol_info }) acc
|
|
578
|
|
- | MethSkol _ is_dm <- skol_info
|
|
579
|
|
- , is_dm -- See Note [Ignore 'needs' from default methods]
|
|
580
|
|
- = acc
|
|
581
|
|
- | otherwise
|
|
|
582
|
+ (dm_implics, normal_implics) = partitionBag is_dm_implic implics
|
|
|
583
|
+ -- dm_implics is usually empty
|
|
|
584
|
+
|
|
|
585
|
+ is_dm_implic (Implic { ic_info = skol_info })
|
|
|
586
|
+ | MethSkol _ is_dm <- skol_info = is_dm
|
|
|
587
|
+ | otherwise = False
|
|
|
588
|
+
|
|
|
589
|
+ get_implic_needs = foldr add_implic_seeds emptyVarSet
|
|
|
590
|
+ add_implic_seeds (Implic { ic_need_outer = needs }) acc
|
|
582
|
591
|
= needs `unionVarSet` acc
|
|
583
|
592
|
|
|
584
|
|
- needed_ev_bind needed (EvBind { eb_lhs = ev_var
|
|
585
|
|
- , eb_info = info })
|
|
|
593
|
+ needed_ev_bind needed (EvBind { eb_lhs = ev_var, eb_info = info })
|
|
586
|
594
|
| EvBindGiven{} <- info = ev_var `elemVarSet` needed
|
|
587
|
595
|
| otherwise = True -- Keep all wanted bindings
|
|
588
|
596
|
|