Be a bit more selective about improvementwip/spj-tc-branch3

This patch makes [W] constraints not participate in
improvement.   See Note [Do not do improvement for WOnly]
in TcSMonad.

Removes some senseless work duplication in some cases;
should not change behaviour.

2 files changed, 57 insertions, 7 deletions

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 5d00e4c773..8c42aa3bd0 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -729,25 +729,32 @@ interactDict _ wi = pprPanic "interactDict" (ppr wi)
 addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
 -- Add derived constraints from type-class functional dependencies.
 addFunDepWork inerts work_ev cls
+  | isImprovable work_ev
   = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)
                -- No need to check flavour; fundeps work between
                -- any pair of constraints, regardless of flavour
                -- Importantly we don't throw workitem back in the
                -- worklist because this can cause loops (see #5236)
+  | otherwise
+  = return ()
   where
     work_pred = ctEvPred work_ev
     work_loc  = ctEvLoc work_ev
 
     add_fds inert_ct
+      | isImprovable inert_ev
       = emitFunDepDeriveds $
         improveFromAnother derived_loc inert_pred work_pred
                -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
                -- NB: We do create FDs for given to report insoluble equations that arise
                -- from pairs of Givens, and also because of floating when we approximate
                -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs
+      | otherwise
+      = return ()
       where
-        inert_pred = ctPred inert_ct
-        inert_loc  = ctLoc inert_ct
+        inert_ev   = ctEvidence inert_ct
+        inert_pred = ctEvPred inert_ev
+        inert_loc  = ctEvLoc inert_ev
         derived_loc = work_loc { ctl_origin = FunDepOrigin1 work_pred  work_loc
                                                             inert_pred inert_loc }
 
@@ -897,7 +904,8 @@ improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar
 --
 -- See Note [FunDep and implicit parameter reactions]
 improveLocalFunEqs ev inerts fam_tc args fsk
-  | isGiven ev   -- See Note [No FunEq improvement for Givens]
+  | isGiven ev -- See Note [No FunEq improvement for Givens]
+    || not (isImprovable ev)
   = return ()
 
   | null improvement_eqns
@@ -941,8 +949,10 @@ improveLocalFunEqs ev inerts fam_tc args fsk
 
     --------------------
     -- See Note [Type inference for type families with injectivity]
-    do_one_injective inj_args (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk })
-      | rhs `tcEqType` lookupFlattenTyVar ieqs ifsk
+    do_one_injective inj_args (CFunEqCan { cc_ev = iev, cc_tyargs = iargs
+                                         , cc_fsk = ifsk })
+      | isImprovable iev
+      , rhs `tcEqType` lookupFlattenTyVar ieqs ifsk
       = [ Pair arg iarg
         | (arg, iarg, True) <- zip3 args iargs inj_args ]
 
@@ -1443,7 +1453,8 @@ reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
 improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()
 -- See Note [FunDep and implicit parameter reactions]
 improveTopFunEqs ev fam_tc args fsk
-  | isGiven ev    -- See Note [No FunEq improvement for Givens]
+  | isGiven ev            -- See Note [No FunEq improvement for Givens]
+    || not (isImprovable ev)
   = return ()
 
   | otherwise
@@ -1823,7 +1834,8 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
                     ; unless s $ insertSafeOverlapFailureTcS work_item
                     ; solve_from_instance theta mk_ev }
                NoInstance ->
-                 do { try_fundep_improvement
+                 do { when (isImprovable fl) $
+                      try_fundep_improvement
                     ; continueWith work_item } }
    where
      dict_pred   = mkClassPred cls xis
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 91d93d0b51..98782e4407 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -57,6 +57,7 @@ module TcSMonad (
     removeInertCts, getPendingScDicts,
     addInertCan, addInertEq, insertFunEq,
     emitInsoluble, emitWorkNC, emitWork,
+    isImprovable,
 
     -- The Model
     kickOutAfterUnification,
@@ -1145,6 +1146,37 @@ them.  If we forget the pend_sc flag, our cunning scheme for avoiding
 generating superclasses repeatedly will fail.
 
 See Trac #11379 for a case of this.
+
+Note [Do not do improvement for WOnly]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do improvement between two constraints (e.g. for injectivity
+or functional dependencies) only if both are "improvable". And
+we improve a constraint wrt the top-level instances only if
+it is improveable.
+
+Improvable:     [G] [WD] [D}
+Not improvable: [W]
+
+Reasons:
+
+* It's less work: fewer pairs to compare
+
+* Every [W] has a shadow [D] so nothing is lost
+
+* Consider [WD] C Int b,  where 'b' is a skolem, and
+    class C a b | a -> b
+    instance C Int Bool
+  We'll do a fundep on it and emit [D] b ~ Bool
+  That will kick out constraint [WD] C Int b
+  Then we'll split it to [W] C Int b (keep in inert)
+                     and [D] C Int b (in work list)
+  When processing the latter we'll rewrite it to
+        [D] C Int Bool
+  At that point it would be /stupid/ to interact it
+  with the inert [W] C Int b in the inert set; after all,
+  it's the very constraint from which the [D] C Int Bool
+  was split!  We can avoid this by not doing improvement
+  on [W] constraints.
 -}
 
 maybeEmitShadow :: InertCans -> Ct -> TcS Ct
@@ -1196,6 +1228,12 @@ intersects_with inert_eqs free_vars
       -- to the underlying UniqFM.  A bit yukky, but efficient.
 
 
+isImprovable :: CtEvidence -> Bool
+-- See Note [Do not do improvement for WOnly]
+isImprovable (CtWanted { ctev_nosh = WOnly }) = False
+isImprovable _                                = True
+
+
 {- *********************************************************************
 *                                                                      *
                    Inert equalities