[commit: ghc] ghc-8.2: Reset cc_pend_sc flag in dropDerivedCt (b6f73dd)

git at git.haskell.org git at git.haskell.org
Tue May 16 01:12:02 UTC 2017


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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/b6f73dd7bacec13a7a8898fb0843efc10d4405e5/ghc

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

commit b6f73dd7bacec13a7a8898fb0843efc10d4405e5
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue May 9 09:29:44 2017 +0100

    Reset cc_pend_sc flag in dropDerivedCt
    
    I'd forgotten to reset this flag to True when dropping Derived
    constraints, which led to Trac #13662.  Easily fixed.
    
    (cherry picked from commit 43a31683acbe2f8120fbb73fe5a6fd1f5de9db80)


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

b6f73dd7bacec13a7a8898fb0843efc10d4405e5
 compiler/typecheck/TcCanonical.hs                  | 25 ++++++++-----
 compiler/typecheck/TcRnTypes.hs                    | 41 +++++++++++++++-------
 .../tests/indexed-types/should_compile/T13662.hs   | 25 +++++++++++++
 testsuite/tests/indexed-types/should_compile/all.T |  1 +
 4 files changed, 72 insertions(+), 20 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 10f871f..b623541 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -161,18 +161,19 @@ canClass ev cls tys pend_sc
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We need to add superclass constraints for two reasons:
 
-* For givens, they give us a route to to proof.  E.g.
+* For givens [G], they give us a route to to proof.  E.g.
     f :: Ord a => a -> Bool
     f x = x == x
   We get a Wanted (Eq a), which can only be solved from the superclass
   of the Given (Ord a).
 
-* For wanteds, they may give useful functional dependencies.  E.g.
+* For wanteds [W], and deriveds [WD], [D], they may give useful
+  functional dependencies.  E.g.
      class C a b | a -> b where ...
      class C a b => D a b where ...
-  Now a Wanted constraint (D Int beta) has (C Int beta) as a superclass
+  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass
   and that might tell us about beta, via C's fundeps.  We can get this
-  by generateing a Derived (C Int beta) constraint.  It's derived because
+  by generating a [D] (C Int beta) constraint.  It's derived because
   we don't actually have to cough up any evidence for it; it's only there
   to generate fundep equalities.
 
@@ -227,12 +228,20 @@ So here's the plan:
 4. Go round to (2) again.  This loop (2,3,4) is implemented
    in TcSimplify.simpl_loop.
 
-We try to terminate the loop by flagging which class constraints
-(given or wanted) are potentially un-expanded.  This is what the
-cc_pend_sc flag is for in CDictCan.  So in Step 3 we only expand
-superclasses for constraints with cc_pend_sc set to true (i.e.
+The cc_pend_sc flag in a CDictCan records whether the superclasses of
+this constraint have been expanded.  Specifically, in Step 3 we only
+expand superclasses for constraints with cc_pend_sc set to true (i.e.
 isPendingScDict holds).
 
+Why do we do this?  Two reasons:
+
+* To avoid repeated work, by repeatedly expanding the superclasses of
+  same constraint,
+
+* To terminate the above loop, at least in the -XNoRecursiveSuperClasses
+  case.  If there are recursive superclasses we could, in principle,
+  expand forever, always encountering new constraints.
+
 When we take a CNonCanonical or CIrredCan, but end up classifying it
 as a CDictCan, we set the cc_pend_sc flag to False.
 
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index ee4a6ef..927cac6 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -1493,14 +1493,14 @@ data Ct
   -- Atomic canonical constraints
   = CDictCan {  -- e.g.  Num xi
       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]
+
       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
-                               --              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
-           --     via fundeps
+      cc_tyargs :: [Xi],   -- cc_tyargs are function-free, hence Xi
+
+      cc_pend_sc :: Bool   -- See Note [The superclass story] in TcCanonical
+                           -- True <=> (a) cc_class has superclasses
+                           --          (b) we have not (yet) added those
+                           --              superclasses as Givens
     }
 
   | CIrredEvCan {  -- These stand for yet-unusable predicates
@@ -1578,9 +1578,8 @@ holeOcc :: Hole -> OccName
 holeOcc (ExprHole uv)  = unboundVarOcc uv
 holeOcc (TypeHole occ) = occ
 
-{-
-Note [Hole constraints]
-~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Hole constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
 CHoleCan constraints are used for two kinds of holes,
 distinguished by cc_hole:
 
@@ -1775,13 +1774,25 @@ dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples
 dropDerivedCt :: Ct -> Maybe Ct
 dropDerivedCt ct
   = case ctEvFlavour ev of
-      Wanted WOnly -> Just (ct { cc_ev = ev_wd })
-      Wanted _     -> Just ct
+      Wanted WOnly -> Just (ct' { cc_ev = ev_wd })
+      Wanted _     -> Just ct'
       _            -> ASSERT( isDerivedCt ct ) Nothing
                       -- simples are all Wanted or Derived
   where
     ev    = ctEvidence ct
     ev_wd = ev { ctev_nosh = WDeriv }
+    ct'   = setPendingScDict ct -- See Note [Resetting cc_pend_sc]
+
+{- Note [Resetting cc_pend_sc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we discard Derived constraints, in dropDerivedSimples, we must
+set the cc_pend_sc flag to True, so that if we re-process this
+CDictCan we will re-generate its derived superclasses. Otherwise
+we might miss some fundeps.  Trac #13662 showed this up.
+
+See Note [The superclass story] in TcCanonical.
+-}
+
 
 dropDerivedInsols :: Cts -> Cts
 -- See Note [Dropping derived constraints]
@@ -1976,6 +1987,12 @@ isPendingScDict ct@(CDictCan { cc_pend_sc = True })
                   = Just (ct { cc_pend_sc = False })
 isPendingScDict _ = Nothing
 
+setPendingScDict :: Ct -> Ct
+-- Set the cc_pend_sc flag to True
+setPendingScDict ct@(CDictCan { cc_pend_sc = False })
+                    = ct { cc_pend_sc = True }
+setPendingScDict ct = ct
+
 superClassesMightHelp :: Ct -> Bool
 -- ^ True if taking superclasses of givens, or of wanteds (to perhaps
 -- expose more equalities or functional dependencies) might help to
diff --git a/testsuite/tests/indexed-types/should_compile/T13662.hs b/testsuite/tests/indexed-types/should_compile/T13662.hs
new file mode 100644
index 0000000..5898f25
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T13662.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module T13662 (run) where
+
+newtype Value a = Value a
+
+type family Repr (f :: * -> *) a :: *
+type instance Repr f Int = f Int
+
+class (Repr Value i ~ Value ir) => Native i ir where
+
+instance Native Int Int where
+
+
+fromInt :: (Native i ir) => i -> a
+fromInt = undefined
+
+apply :: (Int -> a -> a) -> a -> a
+apply weight = id
+
+run :: Float -> Float
+run =
+   let weight = \clip v -> fromInt clip * v
+   in  apply weight
+
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 529f7de..00d40ce 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -263,3 +263,4 @@ test('T12538', normal, compile_fail, [''])
 test('T13244', normal, compile, [''])
 test('T13398a', normal, compile, [''])
 test('T13398b', normal, compile, [''])
+test('T13662', normal, compile, [''])



More information about the ghc-commits mailing list