[commit: ghc] master: Reset cc_pend_sc flag in dropDerivedCt (43a3168)
git at git.haskell.org
git at git.haskell.org
Tue May 9 09:44:37 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/43a31683acbe2f8120fbb73fe5a6fd1f5de9db80/ghc
>---------------------------------------------------------------
commit 43a31683acbe2f8120fbb73fe5a6fd1f5de9db80
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.
>---------------------------------------------------------------
43a31683acbe2f8120fbb73fe5a6fd1f5de9db80
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 ba7c44f..7aef4bb 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -1523,14 +1523,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
@@ -1608,9 +1608,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:
@@ -1805,13 +1804,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]
@@ -2011,6 +2022,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