[commit: ghc] master: Document and improve superclass expansion (8871737)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/8871737db588b1cb8f7d33d60c5af80b85b2422d/ghc

>---------------------------------------------------------------

commit 8871737db588b1cb8f7d33d60c5af80b85b2422d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Feb 8 13:14:02 2016 +0000

    Document and improve superclass expansion
    
    When investigating Trac #11523 I found that superclass
    expansion was a little over-aggressive; we were sort of
    unrolling each loop twice.
    
    This patch corrects that, and adds explanatory comments.


>---------------------------------------------------------------

8871737db588b1cb8f7d33d60c5af80b85b2422d
 compiler/typecheck/TcCanonical.hs | 45 ++++++++++++++++++++++++++++-----------
 compiler/typecheck/TcRnTypes.hs   |  3 ++-
 2 files changed, 34 insertions(+), 14 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 5dc35ac..75996f8 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -366,21 +366,37 @@ mkGivensWithSuperClasses :: CtLoc -> [EvId] -> TcS [Ct]
 -- From a given EvId, make its Ct, plus the Ct's of its superclasses
 -- See Note [The superclass story]
 -- The loop-breaking here follows Note [Expanding superclasses] in TcType
+--
+-- Example:  class D a => C a
+--           class C [a] => D a
+-- makeGivensWithSuperClasses (C x) will return (C x, D x, C[x])
+--   i.e. up to and including the first repetition of C
 mkGivensWithSuperClasses loc ev_ids = concatMapM go ev_ids
   where
-    go ev_id = mk_superclasses emptyNameSet $
-               CtGiven { ctev_evar = ev_id
-                       , ctev_pred = evVarPred ev_id
-                       , ctev_loc  = loc }
+    go ev_id = mk_superclasses emptyNameSet this_ev
+       where
+         this_ev = CtGiven { ctev_evar = ev_id
+                           , ctev_pred = evVarPred ev_id
+                           , ctev_loc = loc }
 
 makeSuperClasses :: [Ct] -> TcS [Ct]
 -- Returns strict superclasses, transitively, see Note [The superclasses story]
 -- See Note [The superclass story]
 -- The loop-breaking here follows Note [Expanding superclasses] in TcType
+-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s
+--    superclasses, up to /and including/ the first repetition of C
+--
+-- Example:  class D a => C a
+--           class C [a] => D a
+-- makeSuperClasses (C x) will return (D x, C [x])
+--
+-- NB: the incoming constraints have had their cc_pend_sc flag already
+--     flipped to False, by isPendingScDict, so we are /obliged/ to at
+--     least produce the immediate superclasses
 makeSuperClasses cts = concatMapM go cts
   where
     go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
-          = mk_strict_superclasses emptyNameSet ev cls tys
+          = mk_strict_superclasses (unitNameSet (className cls)) ev cls tys
     go ct = pprPanic "makeSuperClasses" (ppr ct)
 
 mk_superclasses :: NameSet -> CtEvidence -> TcS [Ct]
@@ -393,13 +409,13 @@ mk_superclasses rec_clss ev
   = return [mkNonCanonical ev]
 
 mk_superclasses_of :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]
--- Return this class constraint, plus its superclasses
+-- Always return this class constraint,
+-- and expand its superclasses
 mk_superclasses_of rec_clss ev cls tys
-  | loop_found
-  = return [this_ct]
-  | otherwise
-  = do { sc_cts <- mk_strict_superclasses rec_clss' ev cls tys
-       ; return (this_ct : sc_cts) }
+  | loop_found = return [this_ct]  -- cc_pend_sc of this_ct = True
+  | otherwise  = do { sc_cts <- mk_strict_superclasses rec_clss' ev cls tys
+                    ; return (this_ct : sc_cts) }
+                                   -- cc_pend_sc of this_ct = False
   where
     cls_nm     = className cls
     loop_found = cls_nm `elemNameSet` rec_clss
@@ -407,15 +423,19 @@ mk_superclasses_of rec_clss ev cls tys
                | otherwise         = rec_clss `extendNameSet` cls_nm
     this_ct    = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
                           , cc_pend_sc = loop_found }
+                 -- NB: If there is a loop, we cut off, so we have not
+                 --     added the superclasses, hence cc_pend_sc = True
 
 mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]
+-- Always return the immediate superclasses of (cls tys);
+-- and expand their superclasses, provided none of them are in rec_clss
+-- nor are repeated
 mk_strict_superclasses rec_clss ev cls tys
   | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
   = do { sc_evs <- newGivenEvVars (mk_given_loc loc)
                                   (mkEvScSelectors (EvId evar) cls tys)
        ; concatMapM (mk_superclasses rec_clss) sc_evs }
 
-
   | isEmptyVarSet (tyCoVarsOfTypes tys)
   = return [] -- Wanteds with no variables yield no deriveds.
               -- See Note [Improvement from Ground Wanteds]
@@ -445,7 +465,6 @@ mk_strict_superclasses rec_clss ev cls tys
        = loc        -- is only used for Givens, but does no harm
 
 
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 151e370..0474f74 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -1366,7 +1366,7 @@ data Ct
       cc_class  :: Class,
       cc_tyargs :: [Xi],       -- cc_tyargs are function-free, hence Xi
       cc_pend_sc :: Bool       -- True <=> (a) cc_class has superclasses
-                               --          (b) we have not yet added those
+                               --          (b) we have not (yet) added those
                                --              superclasses as Givens
            -- NB: cc_pend_sc is used for G/W/D.  For W/D the reason
            --     we need superclasses is to expose possible improvement
@@ -1769,6 +1769,7 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
                          _      -> False
 
 isPendingScDict :: Ct -> Maybe Ct
+-- Says whether cc_pend_sc is True, AND if so flips the flag
 isPendingScDict ct@(CDictCan { cc_pend_sc = True })
                   = Just (ct { cc_pend_sc = False })
 isPendingScDict _ = Nothing