summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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 647084baff..449f5154fc 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -134,6 +134,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 0528976a6b..fbd5be594b 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"
View Lorry Controller Status