[commit: ghc] wip/T2893: Move SCC on evidence binds to post-desguaring (e0d5286)
git at git.haskell.org
git at git.haskell.org
Wed Jan 31 12:01:43 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T2893
Link : http://ghc.haskell.org/trac/ghc/changeset/e0d5286c8cea23ca27163abe76d63c1f10719fa2/ghc
>---------------------------------------------------------------
commit e0d5286c8cea23ca27163abe76d63c1f10719fa2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Jan 31 11:54:32 2018 +0000
Move SCC on evidence binds to post-desguaring
This fixes Trac #14735, and is generally nicer anyway.
>---------------------------------------------------------------
e0d5286c8cea23ca27163abe76d63c1f10719fa2
compiler/deSugar/DsBinds.hs | 35 +++++++++++++++++---
compiler/typecheck/TcEvidence.hs | 37 ++++++++++++----------
testsuite/tests/typecheck/should_compile/T14735.hs | 30 ++++++++++++++++++
testsuite/tests/typecheck/should_compile/all.T | 1 +
4 files changed, 82 insertions(+), 21 deletions(-)
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 5af21ae..4246400 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -52,7 +52,7 @@ import Name
import VarSet
import Rules
import VarEnv
-import Var( EvVar )
+import Var( EvVar, varType )
import Outputable
import Module
import SrcLoc
@@ -63,6 +63,7 @@ import BasicTypes
import DynFlags
import FastString
import Util
+import UniqSet( nonDetEltsUniqSet )
import MonadUtils
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
@@ -1138,15 +1139,39 @@ dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
-dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
+dsEvBinds bs
+ = do { ds_bs <- mapBagM dsEvBind bs
+ ; return (mk_ev_binds ds_bs) }
+
+mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
+-- We do SCC analysis of the evidence bindings, /after/ desugaring
+-- them. This is convenient: it means we can use the CoreSyn
+-- free-variable functions rather than having to do accurate free vars
+-- for EvTerm.
+mk_ev_binds ds_binds
+ = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
where
- ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r}))
- = liftM (NonRec v) (dsEvTerm r)
- ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs)
+ edges :: [ Node EvVar (EvVar,CoreExpr) ]
+ edges = foldrBag ((:) . mk_node) [] ds_binds
+
+ mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
+ mk_node b@(var, rhs)
+ = DigraphNode { node_payload = b
+ , node_key = var
+ , node_dependencies = nonDetEltsUniqSet $
+ exprFreeVars rhs `unionVarSet`
+ coVarsOfType (varType var) }
+ -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
+ -- is still deterministic even if the edges are in nondeterministic order
+ -- as explained in Note [Deterministic SCC] in Digraph.
+
+ ds_scc (AcyclicSCC (v,r)) = NonRec v r
+ ds_scc (CyclicSCC prs) = Rec prs
dsEvBind :: EvBind -> DsM (Id, CoreExpr)
dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
+
{-**********************************************************************
* *
Desugaring EvTerms
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 6d7275b..3b055c7 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -16,7 +16,7 @@ module TcEvidence (
lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
isEmptyEvBindMap,
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
- sccEvBinds, evBindVar,
+ evBindVar,
-- EvTerm (already a CoreExpr)
EvTerm(..), EvExpr,
@@ -773,10 +773,17 @@ evTermCoercion (EvExpr (Coercion co)) = co
evTermCoercion (EvExpr (Cast tm co)) = mkCoCast (evTermCoercion (EvExpr tm)) co
evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm)
+
+{- *********************************************************************
+* *
+ Free variables
+* *
+********************************************************************* -}
+
evVarsOfTerm :: EvTerm -> VarSet
evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e
evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev
-evVarsOfTerm (EvFun {}) = emptyVarSet
+evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun]
evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm
@@ -789,22 +796,20 @@ evVarsOfTypeable ev =
EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2]
EvTypeableTyLit e -> evVarsOfTerm e
--- | Do SCC analysis on a bag of 'EvBind's.
-sccEvBinds :: Bag EvBind -> [SCC EvBind]
-sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
- where
- edges :: [ Node EvVar EvBind ]
- edges = foldrBag ((:) . mk_node) [] bs
- mk_node :: EvBind -> Node EvVar EvBind
- mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
- = DigraphNode b var (nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`
- coVarsOfType (varType var)))
- -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
- -- is still deterministic even if the edges are in nondeterministic order
- -- as explained in Note [Deterministic SCC] in Digraph.
+{- Note [Free vars of EvFun]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Finding the free vars of an EvFun is made tricky by the fact the
+bindings et_binds may be a mutable variable. Fortunately, we
+can just squeeze by. Here's how.
+
+* evVarsOfTerm is used only by TcSimplify.neededEvVars.
+* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the
+ ic_binds field of an Implication
+* So we can track usage via the processing for that implication,
+ (see Note [Tracking redundant constraints] in TcSimplify).
+ We can ignore usage from the EvFun altogether.
-{-
************************************************************************
* *
Pretty printing
diff --git a/testsuite/tests/typecheck/should_compile/T14735.hs b/testsuite/tests/typecheck/should_compile/T14735.hs
new file mode 100644
index 0000000..c48231b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T14735.hs
@@ -0,0 +1,30 @@
+{-# Language QuantifiedConstraints #-}
+{-# Language StandaloneDeriving #-}
+{-# Language DataKinds #-}
+{-# Language TypeOperators #-}
+{-# Language GADTs #-}
+{-# Language KindSignatures #-}
+{-# Language FlexibleInstances #-}
+{-# Language UndecidableInstances #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language RankNTypes #-}
+{-# Language ConstraintKinds #-}
+
+module T14735 where
+
+import Data.Kind
+
+data D c where
+ D :: c => D c
+
+newtype a :- b = S (a => D b)
+
+class C1 a b
+class C2 a b
+instance C1 a b => C2 a b
+
+class (forall xx. f xx) => Limit f
+instance (forall xx. f xx) => Limit f
+
+impl :: Limit (C1 a) :- Limit (C2 a)
+impl = S D
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 622ece0..c8000c9 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -592,3 +592,4 @@ test('T13032', normal, compile, [''])
test('T14273', normal, compile, ['-fdefer-type-errors -fno-max-valid-substitutions'])
test('T2893', normal, compile, [''])
test('T2893a', normal, compile, [''])
+test('T14735', normal, compile, [''])
More information about the ghc-commits
mailing list