summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2020-10-07 14:06:14 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-10-09 08:53:21 -0400
commitef950b19c04bc9c41920ecc9f94382653981d4bb (patch)
tree376288f99f961cb28736a9b966155a257269de2e
parente5c7c9c8578de1248826c21ebd08e475d094a552 (diff)
downloadhaskell-ef950b19c04bc9c41920ecc9f94382653981d4bb.tar.gz
Add TyCon Set/Env and use them in a few places.
Firstly this improves code clarity. But it also has performance benefits as we no longer go through the name of the TyCon to get at it's unique. In order to make this work the recursion check for TyCon has been moved into it's own module in order to avoid import cycles.
-rw-r--r--compiler/GHC/Core/Coercion.hs1
-rw-r--r--compiler/GHC/Core/Opt/Arity.hs3
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs6
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs1
-rw-r--r--compiler/GHC/Core/Predicate.hs1
-rw-r--r--compiler/GHC/Core/TyCon.hs81
-rw-r--r--compiler/GHC/Core/TyCon/Env.hs140
-rw-r--r--compiler/GHC/Core/TyCon/RecWalk.hs99
-rw-r--r--compiler/GHC/Core/TyCon/Set.hs73
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver.hs1
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs1
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs3
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs49
-rw-r--r--compiler/GHC/Types/Literal.hs1
-rw-r--r--compiler/GHC/Types/RepType.hs1
-rw-r--r--compiler/ghc.cabal.in3
-rw-r--r--testsuite/tests/parser/should_run/CountParserDeps.hs2
17 files changed, 357 insertions, 109 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index b8737c43a1..381e80d07a 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -135,6 +135,7 @@ import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.Tidy
import GHC.Core.Type
import GHC.Core.TyCon
+import GHC.Core.TyCon.RecWalk
import GHC.Core.Coercion.Axiom
import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType )
import GHC.Types.Var
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 1526be01ca..d223a79870 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -52,7 +52,8 @@ import GHC.Core.Type as Type
import GHC.Core.Coercion as Type
import GHC.Core.DataCon
-import GHC.Core.TyCon ( initRecTc, checkRecTc, tyConArity )
+import GHC.Core.TyCon ( tyConArity )
+import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc )
import GHC.Core.Predicate ( isDictTy )
import GHC.Core.Multiplicity
import GHC.Types.Var.Set
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 30645a0259..ab36ad8f22 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -31,7 +31,7 @@ import GHC.Core.DataCon
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.Rules
import GHC.Core.Type hiding ( substTy )
-import GHC.Core.TyCon ( tyConName )
+import GHC.Core.TyCon ( tyConUnique )
import GHC.Core.Multiplicity
import GHC.Types.Id
import GHC.Core.Ppr ( pprParendExpr )
@@ -56,7 +56,7 @@ import GHC.Types.Unique.FM
import GHC.Utils.Monad
import Control.Monad ( zipWithM )
import Data.List
-import GHC.Builtin.Names ( specTyConName )
+import GHC.Builtin.Names ( specTyConKey )
import GHC.Unit.Module
import Data.Ord( comparing )
@@ -983,7 +983,7 @@ forceSpecArgTy env ty
forceSpecArgTy env ty
| Just (tycon, tys) <- splitTyConApp_maybe ty
, tycon /= funTyCon
- = tyConName tycon == specTyConName
+ = tyConUnique tycon == specTyConKey
|| any (forceSpecArgTy env) tys
forceSpecArgTy _ _ = False
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 8cc0eaa503..231faa0d44 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -40,6 +40,7 @@ import GHC.Core.Coercion
import GHC.Core.FamInstEnv
import GHC.Types.Basic ( Boxity(..) )
import GHC.Core.TyCon
+import GHC.Core.TyCon.RecWalk
import GHC.Types.Unique.Supply
import GHC.Types.Unique
import GHC.Data.Maybe
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index 89dc9a9e71..a19f129161 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -34,6 +34,7 @@ import GHC.Prelude
import GHC.Core.Type
import GHC.Core.Class
import GHC.Core.TyCon
+import GHC.Core.TyCon.RecWalk
import GHC.Types.Var
import GHC.Core.Coercion
import GHC.Core.Multiplicity ( scaledThing )
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index fc6aaf7d7b..919407376e 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -126,10 +126,6 @@ module GHC.Core.TyCon(
primRepsCompatible,
primRepCompatible,
- -- * Recursion breaking
- RecTcChecker, initRecTc, defaultRecTcMaxBound,
- setRecTcMaxBound, checkRecTc
-
) where
#include "HsVersions.h"
@@ -2710,83 +2706,6 @@ instance Binary Injectivity where
_ -> do { xs <- get bh
; return (Injective xs) } }
-{-
-************************************************************************
-* *
- Walking over recursive TyCons
-* *
-************************************************************************
-
-Note [Expanding newtypes and products]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When expanding a type to expose a data-type constructor, we need to be
-careful about newtypes, lest we fall into an infinite loop. Here are
-the key examples:
-
- newtype Id x = MkId x
- newtype Fix f = MkFix (f (Fix f))
- newtype T = MkT (T -> T)
-
- Type Expansion
- --------------------------
- T T -> T
- Fix Maybe Maybe (Fix Maybe)
- Id (Id Int) Int
- Fix Id NO NO NO
-
-Notice that
- * We can expand T, even though it's recursive.
- * We can expand Id (Id Int), even though the Id shows up
- twice at the outer level, because Id is non-recursive
-
-So, when expanding, we keep track of when we've seen a recursive
-newtype at outermost level; and bail out if we see it again.
-
-We sometimes want to do the same for product types, so that the
-strictness analyser doesn't unbox infinitely deeply.
-
-More precisely, we keep a *count* of how many times we've seen it.
-This is to account for
- data instance T (a,b) = MkT (T a) (T b)
-Then (#10482) if we have a type like
- T (Int,(Int,(Int,(Int,Int))))
-we can still unbox deeply enough during strictness analysis.
-We have to treat T as potentially recursive, but it's still
-good to be able to unwrap multiple layers.
-
-The function that manages all this is checkRecTc.
--}
-
-data RecTcChecker = RC !Int (NameEnv Int)
- -- The upper bound, and the number of times
- -- we have encountered each TyCon
-
--- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.
-initRecTc :: RecTcChecker
-initRecTc = RC defaultRecTcMaxBound emptyNameEnv
-
--- | The default upper bound (100) for the number of times a 'RecTcChecker' is
--- allowed to encounter each 'TyCon'.
-defaultRecTcMaxBound :: Int
-defaultRecTcMaxBound = 100
--- Should we have a flag for this?
-
--- | Change the upper bound for the number of times a 'RecTcChecker' is allowed
--- to encounter each 'TyCon'.
-setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker
-setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts
-
-checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
--- Nothing => Recursion detected
--- Just rec_tcs => Keep going
-checkRecTc (RC bound rec_nts) tc
- = case lookupNameEnv rec_nts tc_name of
- Just n | n >= bound -> Nothing
- | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1)))
- Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1))
- where
- tc_name = tyConName tc
-
-- | Returns whether or not this 'TyCon' is definite, or a hole
-- that may be filled in at some later point. See Note [Skolem abstract data]
tyConSkolem :: TyCon -> Bool
diff --git a/compiler/GHC/Core/TyCon/Env.hs b/compiler/GHC/Core/TyCon/Env.hs
new file mode 100644
index 0000000000..f2ec25ba0d
--- /dev/null
+++ b/compiler/GHC/Core/TyCon/Env.hs
@@ -0,0 +1,140 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TyConEnv]{@TyConEnv@: tyCon environments}
+-}
+
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+module GHC.Core.TyCon.Env (
+ -- * TyCon environment (map)
+ TyConEnv,
+
+ -- ** Manipulating these environments
+ mkTyConEnv, mkTyConEnvWith,
+ emptyTyConEnv, isEmptyTyConEnv,
+ unitTyConEnv, nameEnvElts,
+ extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv,
+ extendTyConEnvList, extendTyConEnvList_C,
+ filterTyConEnv, anyTyConEnv,
+ plusTyConEnv, plusTyConEnv_C, plusTyConEnv_CD, plusTyConEnv_CD2, alterTyConEnv,
+ lookupTyConEnv, lookupTyConEnv_NF, delFromTyConEnv, delListFromTyConEnv,
+ elemTyConEnv, mapTyConEnv, disjointTyConEnv,
+
+ DTyConEnv,
+
+ emptyDTyConEnv,
+ lookupDTyConEnv,
+ delFromDTyConEnv, filterDTyConEnv,
+ mapDTyConEnv,
+ adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv,
+ ) where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Types.Unique.FM
+import GHC.Types.Unique.DFM
+import GHC.Core.TyCon (TyCon)
+
+import GHC.Data.Maybe
+
+{-
+************************************************************************
+* *
+\subsection{TyCon environment}
+* *
+************************************************************************
+-}
+
+-- | TyCon Environment
+type TyConEnv a = UniqFM TyCon a -- Domain is TyCon
+
+emptyTyConEnv :: TyConEnv a
+isEmptyTyConEnv :: TyConEnv a -> Bool
+mkTyConEnv :: [(TyCon,a)] -> TyConEnv a
+mkTyConEnvWith :: (a -> TyCon) -> [a] -> TyConEnv a
+nameEnvElts :: TyConEnv a -> [a]
+alterTyConEnv :: (Maybe a-> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a
+extendTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyCon -> a -> TyConEnv a
+extendTyConEnv_Acc :: (a->b->b) -> (a->b) -> TyConEnv b -> TyCon -> a -> TyConEnv b
+extendTyConEnv :: TyConEnv a -> TyCon -> a -> TyConEnv a
+plusTyConEnv :: TyConEnv a -> TyConEnv a -> TyConEnv a
+plusTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a
+plusTyConEnv_CD :: (a->a->a) -> TyConEnv a -> a -> TyConEnv a -> a -> TyConEnv a
+plusTyConEnv_CD2 :: (Maybe a->Maybe a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a
+extendTyConEnvList :: TyConEnv a -> [(TyCon,a)] -> TyConEnv a
+extendTyConEnvList_C :: (a->a->a) -> TyConEnv a -> [(TyCon,a)] -> TyConEnv a
+delFromTyConEnv :: TyConEnv a -> TyCon -> TyConEnv a
+delListFromTyConEnv :: TyConEnv a -> [TyCon] -> TyConEnv a
+elemTyConEnv :: TyCon -> TyConEnv a -> Bool
+unitTyConEnv :: TyCon -> a -> TyConEnv a
+lookupTyConEnv :: TyConEnv a -> TyCon -> Maybe a
+lookupTyConEnv_NF :: TyConEnv a -> TyCon -> a
+filterTyConEnv :: (elt -> Bool) -> TyConEnv elt -> TyConEnv elt
+anyTyConEnv :: (elt -> Bool) -> TyConEnv elt -> Bool
+mapTyConEnv :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2
+disjointTyConEnv :: TyConEnv a -> TyConEnv a -> Bool
+
+nameEnvElts x = eltsUFM x
+emptyTyConEnv = emptyUFM
+isEmptyTyConEnv = isNullUFM
+unitTyConEnv x y = unitUFM x y
+extendTyConEnv x y z = addToUFM x y z
+extendTyConEnvList x l = addListToUFM x l
+lookupTyConEnv x y = lookupUFM x y
+alterTyConEnv = alterUFM
+mkTyConEnv l = listToUFM l
+mkTyConEnvWith f = mkTyConEnv . map (\a -> (f a, a))
+elemTyConEnv x y = elemUFM x y
+plusTyConEnv x y = plusUFM x y
+plusTyConEnv_C f x y = plusUFM_C f x y
+plusTyConEnv_CD f x d y b = plusUFM_CD f x d y b
+plusTyConEnv_CD2 f x y = plusUFM_CD2 f x y
+extendTyConEnv_C f x y z = addToUFM_C f x y z
+mapTyConEnv f x = mapUFM f x
+extendTyConEnv_Acc x y z a b = addToUFM_Acc x y z a b
+extendTyConEnvList_C x y z = addListToUFM_C x y z
+delFromTyConEnv x y = delFromUFM x y
+delListFromTyConEnv x y = delListFromUFM x y
+filterTyConEnv x y = filterUFM x y
+anyTyConEnv f x = foldUFM ((||) . f) False x
+disjointTyConEnv x y = disjointUFM x y
+
+lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n)
+
+-- | Deterministic TyCon Environment
+--
+-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why
+-- we need DTyConEnv.
+type DTyConEnv a = UniqDFM TyCon a
+
+emptyDTyConEnv :: DTyConEnv a
+emptyDTyConEnv = emptyUDFM
+
+lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a
+lookupDTyConEnv = lookupUDFM
+
+delFromDTyConEnv :: DTyConEnv a -> TyCon -> DTyConEnv a
+delFromDTyConEnv = delFromUDFM
+
+filterDTyConEnv :: (a -> Bool) -> DTyConEnv a -> DTyConEnv a
+filterDTyConEnv = filterUDFM
+
+mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b
+mapDTyConEnv = mapUDFM
+
+adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a
+adjustDTyConEnv = adjustUDFM
+
+alterDTyConEnv :: (Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a
+alterDTyConEnv = alterUDFM
+
+extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a
+extendDTyConEnv = addToUDFM
diff --git a/compiler/GHC/Core/TyCon/RecWalk.hs b/compiler/GHC/Core/TyCon/RecWalk.hs
new file mode 100644
index 0000000000..09ba6402ac
--- /dev/null
+++ b/compiler/GHC/Core/TyCon/RecWalk.hs
@@ -0,0 +1,99 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+Check for recursive type constructors.
+
+-}
+
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
+
+module GHC.Core.TyCon.RecWalk (
+
+ -- * Recursion breaking
+ RecTcChecker, initRecTc, defaultRecTcMaxBound,
+ setRecTcMaxBound, checkRecTc
+
+ ) where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Core.TyCon
+import GHC.Core.TyCon.Env
+
+{-
+************************************************************************
+* *
+ Walking over recursive TyCons
+* *
+************************************************************************
+
+Note [Expanding newtypes and products]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When expanding a type to expose a data-type constructor, we need to be
+careful about newtypes, lest we fall into an infinite loop. Here are
+the key examples:
+
+ newtype Id x = MkId x
+ newtype Fix f = MkFix (f (Fix f))
+ newtype T = MkT (T -> T)
+
+ Type Expansion
+ --------------------------
+ T T -> T
+ Fix Maybe Maybe (Fix Maybe)
+ Id (Id Int) Int
+ Fix Id NO NO NO
+
+Notice that
+ * We can expand T, even though it's recursive.
+ * We can expand Id (Id Int), even though the Id shows up
+ twice at the outer level, because Id is non-recursive
+
+So, when expanding, we keep track of when we've seen a recursive
+newtype at outermost level; and bail out if we see it again.
+
+We sometimes want to do the same for product types, so that the
+strictness analyser doesn't unbox infinitely deeply.
+
+More precisely, we keep a *count* of how many times we've seen it.
+This is to account for
+ data instance T (a,b) = MkT (T a) (T b)
+Then (#10482) if we have a type like
+ T (Int,(Int,(Int,(Int,Int))))
+we can still unbox deeply enough during strictness analysis.
+We have to treat T as potentially recursive, but it's still
+good to be able to unwrap multiple layers.
+
+The function that manages all this is checkRecTc.
+-}
+
+data RecTcChecker = RC !Int (TyConEnv Int)
+ -- The upper bound, and the number of times
+ -- we have encountered each TyCon
+
+-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.
+initRecTc :: RecTcChecker
+initRecTc = RC defaultRecTcMaxBound emptyTyConEnv
+
+-- | The default upper bound (100) for the number of times a 'RecTcChecker' is
+-- allowed to encounter each 'TyCon'.
+defaultRecTcMaxBound :: Int
+defaultRecTcMaxBound = 100
+-- Should we have a flag for this?
+
+-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed
+-- to encounter each 'TyCon'.
+setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker
+setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts
+
+checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
+-- Nothing => Recursion detected
+-- Just rec_tcs => Keep going
+checkRecTc (RC bound rec_nts) tc
+ = case lookupTyConEnv rec_nts tc of
+ Just n | n >= bound -> Nothing
+ | otherwise -> Just (RC bound (extendTyConEnv rec_nts tc (n+1)))
+ Nothing -> Just (RC bound (extendTyConEnv rec_nts tc 1))
diff --git a/compiler/GHC/Core/TyCon/Set.hs b/compiler/GHC/Core/TyCon/Set.hs
new file mode 100644
index 0000000000..40beac6c58
--- /dev/null
+++ b/compiler/GHC/Core/TyCon/Set.hs
@@ -0,0 +1,73 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+-}
+
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
+
+module GHC.Core.TyCon.Set (
+ -- * TyCons set type
+ TyConSet,
+
+ -- ** Manipulating these sets
+ emptyTyConSet, unitTyConSet, mkTyConSet, unionTyConSet, unionTyConSets,
+ minusTyConSet, elemTyConSet, extendTyConSet, extendTyConSetList,
+ delFromTyConSet, delListFromTyConSet, isEmptyTyConSet, filterTyConSet,
+ intersectsTyConSet, disjointTyConSet, intersectTyConSet,
+ nameSetAny, nameSetAll
+ ) where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Types.Unique.Set
+import GHC.Core.TyCon (TyCon)
+
+type TyConSet = UniqSet TyCon
+
+emptyTyConSet :: TyConSet
+unitTyConSet :: TyCon -> TyConSet
+extendTyConSetList :: TyConSet -> [TyCon] -> TyConSet
+extendTyConSet :: TyConSet -> TyCon -> TyConSet
+mkTyConSet :: [TyCon] -> TyConSet
+unionTyConSet :: TyConSet -> TyConSet -> TyConSet
+unionTyConSets :: [TyConSet] -> TyConSet
+minusTyConSet :: TyConSet -> TyConSet -> TyConSet
+elemTyConSet :: TyCon -> TyConSet -> Bool
+isEmptyTyConSet :: TyConSet -> Bool
+delFromTyConSet :: TyConSet -> TyCon -> TyConSet
+delListFromTyConSet :: TyConSet -> [TyCon] -> TyConSet
+filterTyConSet :: (TyCon -> Bool) -> TyConSet -> TyConSet
+intersectTyConSet :: TyConSet -> TyConSet -> TyConSet
+intersectsTyConSet :: TyConSet -> TyConSet -> Bool
+-- ^ True if there is a non-empty intersection.
+-- @s1 `intersectsTyConSet` s2@ doesn't compute @s2@ if @s1@ is empty
+disjointTyConSet :: TyConSet -> TyConSet -> Bool
+
+isEmptyTyConSet = isEmptyUniqSet
+emptyTyConSet = emptyUniqSet
+unitTyConSet = unitUniqSet
+mkTyConSet = mkUniqSet
+extendTyConSetList = addListToUniqSet
+extendTyConSet = addOneToUniqSet
+unionTyConSet = unionUniqSets
+unionTyConSets = unionManyUniqSets
+minusTyConSet = minusUniqSet
+elemTyConSet = elementOfUniqSet
+delFromTyConSet = delOneFromUniqSet
+filterTyConSet = filterUniqSet
+intersectTyConSet = intersectUniqSets
+disjointTyConSet = disjointUniqSets
+
+
+delListFromTyConSet set ns = foldl' delFromTyConSet set ns
+
+intersectsTyConSet s1 s2 = not (isEmptyTyConSet (s1 `intersectTyConSet` s2))
+
+nameSetAny :: (TyCon -> Bool) -> TyConSet -> Bool
+nameSetAny = uniqSetAny
+
+nameSetAll :: (TyCon -> Bool) -> TyConSet -> Bool
+nameSetAll = uniqSetAll
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
index 3fc1471835..1126fadc3b 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -67,6 +67,7 @@ import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.TyCon
+import GHC.Core.TyCon.RecWalk
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim (tYPETyCon)
import GHC.Core.TyCo.Rep
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 5f392e6028..ed55e6c943 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -58,6 +58,7 @@ import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Core.DataCon
import GHC.Core.TyCon
+import GHC.Core.TyCon.RecWalk
import GHC.Tc.Utils.TcType
import GHC.Builtin.Names
import GHC.Driver.Session
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 10c577e723..a524493b94 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -174,6 +174,7 @@ import GHC.Core.Predicate
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
+import GHC.Core.TyCon.Env
import GHC.Data.Maybe
import GHC.Core.Map
@@ -2640,7 +2641,7 @@ delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
delFunEq m tc tys = delTcApp m (getUnique tc) tys
------------------------------
-type ExactFunEqMap a = UniqFM TyCon (ListMap TypeMap a)
+type ExactFunEqMap a = TyConEnv (ListMap TypeMap a)
emptyExactFunEqs :: ExactFunEqMap a
emptyExactFunEqs = emptyUFM
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 2e8b5124fc..031faebed0 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -50,12 +50,13 @@ import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Env
-import GHC.Types.Name.Set hiding (unitFV)
import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var.Env
import GHC.Types.Var.Set
+import GHC.Types.Unique.Set
+import GHC.Core.TyCon.Set
import GHC.Core.Coercion ( ltRole )
import GHC.Types.Basic
import GHC.Types.SrcLoc
@@ -156,7 +157,11 @@ newtype SynCycleM a = SynCycleM {
runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
deriving (Functor)
-type SynCycleState = NameSet
+-- TODO: TyConSet is implemented as IntMap over uniques.
+-- But we could get away with something based on IntSet
+-- since we only check membershib, but never extract the
+-- elements.
+type SynCycleState = TyConSet
instance Applicative SynCycleM where
pure x = SynCycleM $ \state -> Right (x, state)
@@ -174,12 +179,12 @@ failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
-- | Test if a 'Name' is acyclic, short-circuiting if we've
-- seen it already.
-checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
-checkNameIsAcyclic n m = SynCycleM $ \s ->
- if n `elemNameSet` s
+checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()
+checkTyConIsAcyclic tc m = SynCycleM $ \s ->
+ if tc `elemTyConSet` s
then Right ((), s) -- short circuit
else case runSynCycleM m s of
- Right ((), s') -> Right ((), extendNameSet s' n)
+ Right ((), s') -> Right ((), extendTyConSet s' tc)
Left err -> Left err
-- | Checks if any of the passed in 'TyCon's have cycles.
@@ -189,7 +194,7 @@ checkNameIsAcyclic n m = SynCycleM $ \s ->
-- can give better error messages.
checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles this_uid tcs tyclds = do
- case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of
+ case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of
Left (loc, err) -> setSrcSpan loc $ failWithTc err
Right _ -> return ()
where
@@ -198,15 +203,15 @@ checkSynCycles this_uid tcs tyclds = do
-- Short circuit if we've already seen this Name and concluded
-- it was acyclic.
- go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+ go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
go so_far seen_tcs tc =
- checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc
+ checkTyConIsAcyclic tc $ go' so_far seen_tcs tc
-- Expand type synonyms, complaining if you find the same
-- type synonym a second time.
- go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+ go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
go' so_far seen_tcs tc
- | n `elemNameSet` so_far
+ | tc `elemTyConSet` so_far
= failSynCycleM (getSrcSpan (head seen_tcs)) $
sep [ text "Cycle in type synonym declarations:"
, nest 2 (vcat (map ppr_decl seen_tcs)) ]
@@ -221,7 +226,7 @@ checkSynCycles this_uid tcs tyclds = do
isInteractiveModule mod)
= return ()
| Just ty <- synTyConRhs_maybe tc =
- go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty
+ go_ty (extendTyConSet so_far tc) (tc:seen_tcs) ty
| otherwise = return ()
where
n = tyConName tc
@@ -234,7 +239,7 @@ checkSynCycles this_uid tcs tyclds = do
where
n = tyConName tc
- go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()
+ go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
go_ty so_far seen_tcs ty =
mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)
@@ -284,11 +289,13 @@ and now expand superclasses for constraint (C Id):
Each step expands superclasses one layer, and clearly does not terminate.
-}
+type ClassSet = UniqSet Class
+
checkClassCycles :: Class -> Maybe SDoc
-- Nothing <=> ok
-- Just err <=> possible cycle error
checkClassCycles cls
- = do { (definite_cycle, err) <- go (unitNameSet (getName cls))
+ = do { (definite_cycle, err) <- go (unitUniqSet cls)
cls (mkTyVarTys (classTyVars cls))
; let herald | definite_cycle = text "Superclass cycle for"
| otherwise = text "Potential superclass cycle for"
@@ -304,12 +311,12 @@ checkClassCycles cls
-- NB: this code duplicates TcType.transSuperClasses, but
-- with more error message generation clobber
-- Make sure the two stay in sync.
- go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+ go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go so_far cls tys = firstJusts $
map (go_pred so_far) $
immSuperClasses cls tys
- go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)
+ go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
-- Nothing <=> ok
-- Just (True, err) <=> definite cycle
-- Just (False, err) <=> possible cycle
@@ -322,7 +329,7 @@ checkClassCycles cls
| otherwise
= Nothing
- go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
+ go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc so_far pred tc tys
| isFamilyTyCon tc
= Just (False, hang (text "one of whose superclass constraints is headed by a type family:")
@@ -332,18 +339,16 @@ checkClassCycles cls
| otherwise -- Equality predicate, for example
= Nothing
- go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+ go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go_cls so_far cls tys
- | cls_nm `elemNameSet` so_far
+ | cls `elementOfUniqSet` so_far
= Just (True, text "one of whose superclasses is" <+> quotes (ppr cls))
| isCTupleClass cls
= go so_far cls tys
| otherwise
- = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys
+ = do { (b,err) <- go (so_far `addOneToUniqSet` cls) cls tys
; return (b, text "one of whose superclasses is" <+> quotes (ppr cls)
$$ err) }
- where
- cls_nm = getName cls
{-
************************************************************************
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index 97ab69563a..b208a45751 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -646,6 +646,7 @@ absentLiteralOf :: TyCon -> Maybe Literal
-- 2. This would need to return a type application to a literal
absentLiteralOf tc = lookupUFM absent_lits tc
+-- We do not use TyConEnv here to avoid import cycles.
absent_lits :: UniqFM TyCon Literal
absent_lits = listToUFM_Directly
-- Explicitly construct the mape from the known
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index 98ba865a95..0ef8cfe9c9 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -30,6 +30,7 @@ import GHC.Core.DataCon
import GHC.Builtin.Names
import GHC.Core.Coercion
import GHC.Core.TyCon
+import GHC.Core.TyCon.RecWalk
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Builtin.Types.Prim
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index ec7972d082..d12c2ca45e 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -531,6 +531,9 @@ Library
GHC.Core.Multiplicity
GHC.Core.UsageEnv
GHC.Core.TyCon
+ GHC.Core.TyCon.Env
+ GHC.Core.TyCon.Set
+ GHC.Core.TyCon.RecWalk
GHC.Core.Coercion.Axiom
GHC.Core.Type
GHC.Core.TyCo.Rep
diff --git a/testsuite/tests/parser/should_run/CountParserDeps.hs b/testsuite/tests/parser/should_run/CountParserDeps.hs
index 5c7cb0eef3..bf84f2a0ac 100644
--- a/testsuite/tests/parser/should_run/CountParserDeps.hs
+++ b/testsuite/tests/parser/should_run/CountParserDeps.hs
@@ -28,7 +28,7 @@ main = do
[libdir] <- getArgs
modules <- parserDeps libdir
let num = sizeUniqSet modules
- max_num = 203
+ max_num = 205
min_num = max_num - 10 -- so that we don't forget to change the number
-- when the number of dependencies decreases
-- putStrLn $ "Found " ++ show num ++ " parser module dependencies"