diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 96c37727da6d9cd71988126907bc88c0a695e7ed..43bcf75bb4003d5bd479a9ddcacd8e4936a498d1 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -79,7 +79,6 @@ import FastString
import Module
import Binary
import UniqSet
-import UniqFM
import Unique( mkAlphaTyVarUnique )
import qualified Data.Data as Data
@@ -1202,7 +1201,7 @@ isLegacyPromotableDataCon dc
= null (dataConEqSpec dc) -- no GADTs
&& null (dataConTheta dc) -- no context
&& not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors
- && allUFM isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc))
+ && uniqSetAll isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc))
-- | Was this tycon promotable before GHC 8.0? That is, is it promotable
-- without -XTypeInType
diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs
index 0ab4ec0749f8d121c7c2e602305447b7db1525c5..57de81cb4494d8b845eb971b399d9236e3210a21 100644
--- a/compiler/basicTypes/NameSet.hs
+++ b/compiler/basicTypes/NameSet.hs
@@ -35,7 +35,6 @@ module NameSet (
import Name
import UniqSet
-import UniqFM
import Data.List (sortBy)
{-
@@ -96,8 +95,8 @@ nameSetAll = uniqSetAll
-- See Note [Deterministic UniqFM] to learn about nondeterminism
nameSetElemsStable :: NameSet -> [Name]
nameSetElemsStable ns =
- sortBy stableNameCmp $ nonDetEltsUFM ns
- -- It's OK to use nonDetEltsUFM here because we immediately sort
+ sortBy stableNameCmp $ nonDetEltsUniqSet ns
+ -- It's OK to use nonDetEltsUniqSet here because we immediately sort
-- with stableNameCmp
{-
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 23c6d6833de38b4877554161b4e27d96d2f3279e..3a4324b35229917aa424f0519411aeb9b82a5239 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -77,6 +77,7 @@ import FieldLabel
import Outputable
import Unique
import UniqFM
+import UniqSet
import Util
import NameEnv
@@ -346,7 +347,7 @@ instance Outputable LocalRdrEnv where
= hang (text "LocalRdrEnv {")
2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env
, text "in_scope ="
- <+> pprUFM ns (braces . pprWithCommas ppr)
+ <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr)
] <+> char '}')
where
ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name
diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs
index 3177abb8147a8ba80f0504e6486b519f9c3b0c99..e22c207858f7ab3b702f13b0209abd6f7496302b 100644
--- a/compiler/basicTypes/VarEnv.hs
+++ b/compiler/basicTypes/VarEnv.hs
@@ -9,7 +9,7 @@ module VarEnv (
-- ** Manipulating these environments
emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly,
- elemVarEnv,
+ elemVarEnv, disjointVarEnv,
extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly,
extendVarEnvList,
plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C,
@@ -76,6 +76,7 @@ module VarEnv (
import OccName
import Var
import VarSet
+import UniqSet
import UniqFM
import UniqDFM
import Unique
@@ -94,26 +95,21 @@ import Outputable
-- | A set of variables that are in scope at some point
-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides
-- the motivation for this abstraction.
-data InScopeSet = InScope (VarEnv Var) {-# UNPACK #-} !Int
- -- The (VarEnv Var) is just a VarSet. But we write it like
- -- this to remind ourselves that you can look up a Var in
- -- the InScopeSet. Typically the InScopeSet contains the
+data InScopeSet = InScope VarSet {-# UNPACK #-} !Int
+ -- We store a VarSet here, but we use this for lookups rather than
+ -- just membership tests. Typically the InScopeSet contains the
-- canonical version of the variable (e.g. with an informative
-- unfolding), so this lookup is useful.
--
- -- INVARIANT: the VarEnv maps (the Unique of) a variable to
- -- a variable with the same Unique. (This was not
- -- the case in the past, when we had a grevious hack
- -- mapping var1 to var2.
- --
-- The Int is a kind of hash-value used by uniqAway
-- For example, it might be the size of the set
-- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
instance Outputable InScopeSet where
ppr (InScope s _) =
- text "InScope" <+> braces (fsep (map (ppr . Var.varName) (nonDetEltsUFM s)))
- -- It's OK to use nonDetEltsUFM here because it's
+ text "InScope" <+>
+ braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s)))
+ -- It's OK to use nonDetEltsUniqSet here because it's
-- only for pretty printing
-- In-scope sets get big, and with -dppr-debug
-- the output is overwhelming
@@ -121,42 +117,43 @@ instance Outputable InScopeSet where
emptyInScopeSet :: InScopeSet
emptyInScopeSet = InScope emptyVarSet 1
-getInScopeVars :: InScopeSet -> VarEnv Var
+getInScopeVars :: InScopeSet -> VarSet
getInScopeVars (InScope vs _) = vs
-mkInScopeSet :: VarEnv Var -> InScopeSet
+mkInScopeSet :: VarSet -> InScopeSet
mkInScopeSet in_scope = InScope in_scope 1
extendInScopeSet :: InScopeSet -> Var -> InScopeSet
-extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n + 1)
+extendInScopeSet (InScope in_scope n) v
+ = InScope (extendVarSet in_scope v) (n + 1)
extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
extendInScopeSetList (InScope in_scope n) vs
- = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
+ = InScope (foldl (\s v -> extendVarSet s v) in_scope vs)
(n + length vs)
-extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
+extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet
extendInScopeSetSet (InScope in_scope n) vs
- = InScope (in_scope `plusVarEnv` vs) (n + sizeUFM vs)
+ = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs)
delInScopeSet :: InScopeSet -> Var -> InScopeSet
-delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
+delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n
elemInScopeSet :: Var -> InScopeSet -> Bool
-elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope
+elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope
-- | Look up a variable the 'InScopeSet'. This lets you map from
-- the variable's identity (unique) to its full value.
lookupInScope :: InScopeSet -> Var -> Maybe Var
-lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v
+lookupInScope (InScope in_scope _) v = lookupVarSet in_scope v
lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
lookupInScope_Directly (InScope in_scope _) uniq
- = lookupVarEnv_Directly in_scope uniq
+ = lookupVarSet_Directly in_scope uniq
unionInScope :: InScopeSet -> InScopeSet -> InScopeSet
unionInScope (InScope s1 _) (InScope s2 n2)
- = InScope (s1 `plusVarEnv` s2) n2
+ = InScope (s1 `unionVarSet` s2) n2
varSetInScope :: VarSet -> InScopeSet -> Bool
varSetInScope vars (InScope s1 _) = vars `subVarSet` s1
@@ -240,9 +237,9 @@ mkRnEnv2 vars = RV2 { envL = emptyVarEnv
, envR = emptyVarEnv
, in_scope = vars }
-addRnInScopeSet :: RnEnv2 -> VarEnv Var -> RnEnv2
+addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2
addRnInScopeSet env vs
- | isEmptyVarEnv vs = env
+ | isEmptyVarSet vs = env
| otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs }
rnInScope :: Var -> RnEnv2 -> Bool
@@ -462,9 +459,11 @@ lookupVarEnv_NF :: VarEnv a -> Var -> a
lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
elemVarEnv :: Var -> VarEnv a -> Bool
elemVarEnvByKey :: Unique -> VarEnv a -> Bool
+disjointVarEnv :: VarEnv a -> VarEnv a -> Bool
elemVarEnv = elemUFM
elemVarEnvByKey = elemUFM_Directly
+disjointVarEnv = disjointUFM
alterVarEnv = alterUFM
extendVarEnv = addToUFM
extendVarEnv_C = addToUFM_C
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index f6d82fdcd1b382591c4d1ee6c22f7e8ac1ca1ffd..8877f64080d7926cdf5b4ae180d79514f40bd313 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -11,7 +11,7 @@ module VarSet (
-- ** Manipulating these sets
emptyVarSet, unitVarSet, mkVarSet,
- extendVarSet, extendVarSetList, extendVarSet_C,
+ extendVarSet, extendVarSetList,
elemVarSet, subVarSet,
unionVarSet, unionVarSets, mapUnionVarSet,
intersectVarSet, intersectsVarSet, disjointVarSet,
@@ -19,7 +19,7 @@ module VarSet (
minusVarSet, filterVarSet,
anyVarSet, allVarSet,
transCloVarSet, fixVarSet,
- lookupVarSet, lookupVarSetByName,
+ lookupVarSet_Directly, lookupVarSet, lookupVarSetByName,
sizeVarSet, seqVarSet,
elemVarSetByKey, partitionVarSet,
pluralVarSet, pprVarSet,
@@ -91,13 +91,13 @@ delVarSetList :: VarSet -> [Var] -> VarSet
minusVarSet :: VarSet -> VarSet -> VarSet
isEmptyVarSet :: VarSet -> Bool
mkVarSet :: [Var] -> VarSet
+lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var
lookupVarSet :: VarSet -> Var -> Maybe Var
-- Returns the set element, which may be
-- (==) to the argument, but not the same as
lookupVarSetByName :: VarSet -> Name -> Maybe Var
sizeVarSet :: VarSet -> Int
filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
-extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet
delVarSetByKey :: VarSet -> Unique -> VarSet
elemVarSetByKey :: Unique -> VarSet -> Bool
@@ -123,11 +123,11 @@ delVarSet = delOneFromUniqSet
delVarSetList = delListFromUniqSet
isEmptyVarSet = isEmptyUniqSet
mkVarSet = mkUniqSet
+lookupVarSet_Directly = lookupUniqSet_Directly
lookupVarSet = lookupUniqSet
lookupVarSetByName = lookupUniqSet
sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet
-extendVarSet_C = addOneToUniqSet_C
delVarSetByKey = delOneFromUniqSet_Directly
elemVarSetByKey = elemUniqSet_Directly
partitionVarSet = partitionUniqSet
@@ -136,7 +136,7 @@ mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs
-- See comments with type signatures
intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
-disjointVarSet s1 s2 = disjointUFM s1 s2
+disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2)
subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)
anyVarSet :: (Var -> Bool) -> VarSet -> Bool
@@ -190,7 +190,7 @@ seqVarSet s = sizeVarSet s `seq` ()
-- | Determines the pluralisation suffix appropriate for the length of a set
-- in the same way that plural from Outputable does for lists.
pluralVarSet :: VarSet -> SDoc
-pluralVarSet = pluralUFM
+pluralVarSet = pluralUFM . getUniqSet
-- | Pretty-print a non-deterministic set.
-- The order of variables is non-deterministic and for pretty-printing that
@@ -207,7 +207,7 @@ pprVarSet :: VarSet -- ^ The things to be pretty printed
-- elements
-> SDoc -- ^ 'SDoc' where the things have been pretty
-- printed
-pprVarSet = pprUFM
+pprVarSet = pprUFM . getUniqSet
-- Deterministic VarSet
-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need
@@ -311,7 +311,7 @@ extendDVarSetList = addListToUniqDSet
-- | Convert a DVarSet to a VarSet by forgeting the order of insertion
dVarSetToVarSet :: DVarSet -> VarSet
-dVarSetToVarSet = udfmToUfm
+dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm
-- | transCloVarSet for DVarSet
transCloDVarSet :: (DVarSet -> DVarSet)
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 811d9083f35996498edfb9542e99cd772d06e4a1..dba8ca6e8cc509e19795e96e6afe104cb69e5a33 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -985,7 +985,7 @@ is_cishCC JavaScriptCallConv = False
--
pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
pprTempAndExternDecls stmts
- = (pprUFM temps (vcat . map pprTempDecl),
+ = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),
vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
where (temps, lbls) = runTE (mapM_ te_BB stmts)
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index 511ffc1c9ffaf04c611319ed95979c84bfe3613f..5997a9c4b67ed1590bf179f007172e5bf15a0d9c 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -66,7 +66,8 @@ import CoreSyn
import Id
import IdInfo
import NameSet
-import UniqFM
+import UniqSet
+import Unique (Uniquable (..))
import Literal ( literalType )
import Name
import VarSet
@@ -476,7 +477,8 @@ idRuleRhsVars is_active id
, ru_rhs = rhs, ru_act = act })
| is_active act
-- See Note [Finding rule RHS free vars] in OccAnal.hs
- = delFromUFM fvs fn -- Note [Rule free var hack]
+ = delOneFromUniqSet_Directly fvs (getUnique fn)
+ -- Note [Rule free var hack]
where
fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
get_fvs _ = noFVs
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 043d3c367490fb4bcdd6a66e607ed0636fcd8b8e..590d87094652f7689b403667a1c4f2539d936345 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -876,7 +876,7 @@ simpleOptPgm dflags this_mod binds rules vects
; return (reverse binds', rules', vects') }
where
occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
- rules vects emptyVarEnv binds
+ rules vects emptyVarSet binds
(final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
final_subst = soe_subst final_env
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 2616e6f6056d0076b980dc8f821e4d2f22c27da2..31fbd12979821084f01305780994f644207e6d0b 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -114,7 +114,7 @@ import BasicTypes
import DynFlags
import Outputable
import Util
-import UniqFM
+import UniqSet
import SrcLoc ( RealSrcSpan, containsSpan )
import Binary
@@ -1038,7 +1038,7 @@ chooseOrphanAnchor local_names
| isEmptyNameSet local_names = IsOrphan
| otherwise = NotOrphan (minimum occs)
where
- occs = map nameOccName $ nonDetEltsUFM local_names
+ occs = map nameOccName $ nonDetEltsUniqSet local_names
-- It's OK to use nonDetEltsUFM here, see comments above
instance Binary IsOrphan where
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index f686b689471105038f2ae539aba985e72c1567cf..c3be55504b8310730c6266607efff8ea00ddd422 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -51,6 +51,7 @@ import ListSetOps( assocMaybe )
import Data.List
import Util
import UniqDFM
+import UniqSet
data DsCmdEnv = DsCmdEnv {
arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
@@ -375,7 +376,7 @@ dsCmd ids local_vars stack_ty res_ty
res_ty
core_make_arg
core_arrow,
- exprFreeIdsDSet core_arg `udfmIntersectUFM` local_vars)
+ exprFreeIdsDSet core_arg `udfmIntersectUFM` (getUniqSet local_vars))
-- D, xs |- fun :: a t1 t2
-- D, xs |- arg :: t1
@@ -404,7 +405,7 @@ dsCmd ids local_vars stack_ty res_ty
core_make_pair
(do_app ids arg_ty res_ty),
(exprsFreeIdsDSet [core_arrow, core_arg])
- `udfmIntersectUFM` local_vars)
+ `udfmIntersectUFM` getUniqSet local_vars)
-- D; ys |-a cmd : (t,stk) --> t'
-- D, xs |- exp :: t
@@ -437,7 +438,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
core_map
core_cmd,
free_vars `unionDVarSet`
- (exprFreeIdsDSet core_arg `udfmIntersectUFM` local_vars))
+ (exprFreeIdsDSet core_arg `udfmIntersectUFM` getUniqSet local_vars))
-- D; ys |-a cmd : stk t'
-- -----------------------------------------------
@@ -474,7 +475,7 @@ dsCmd ids local_vars stack_ty res_ty
-- match the old environment and stack against the input
select_code <- matchEnvStack env_ids stack_id param_code
return (do_premap ids in_ty in_ty' res_ty select_code core_body,
- free_vars `udfmMinusUFM` pat_vars)
+ free_vars `udfmMinusUFM` getUniqSet pat_vars)
dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
= dsLCmd ids local_vars stack_ty res_ty cmd env_ids
@@ -506,7 +507,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
then_ty = envStackType then_ids stack_ty
else_ty = envStackType else_ids stack_ty
sum_ty = mkTyConApp either_con [then_ty, else_ty]
- fvs_cond = exprFreeIdsDSet core_cond `udfmIntersectUFM` local_vars
+ fvs_cond = exprFreeIdsDSet core_cond `udfmIntersectUFM` getUniqSet local_vars
core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id)
core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)
@@ -602,7 +603,7 @@ dsCmd ids local_vars stack_ty res_ty
core_matches <- matchEnvStack env_ids stack_id core_body
return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
- exprFreeIdsDSet core_body `udfmIntersectUFM` local_vars)
+ exprFreeIdsDSet core_body `udfmIntersectUFM` getUniqSet local_vars)
-- D; ys |-a cmd : stk --> t
-- ----------------------------------
@@ -627,7 +628,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids
res_ty
core_map
core_body,
- exprFreeIdsDSet core_binds `udfmIntersectUFM` local_vars)
+ exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)
-- D; xs |-a ss : t
-- ----------------------------------
@@ -879,7 +880,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
do_compose ids before_c_ty after_c_ty out_ty
(do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
do_arr ids after_c_ty out_ty proj_expr,
- fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` pat_vars))
+ fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` getUniqSet pat_vars))
-- D; xs' |-a do { ss } : t
-- --------------------------------------
@@ -896,7 +897,7 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy out_ids)
core_map,
- exprFreeIdsDSet core_binds `udfmIntersectUFM` local_vars)
+ exprFreeIdsDSet core_binds `udfmIntersectUFM` getUniqSet local_vars)
-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
-- D; xs' |-a do { ss' } : t
@@ -1015,7 +1016,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
rec_id <- newSysLocalDs rec_ty
let
- env1_id_set = fv_stmts `udfmMinusUFM` rec_id_set
+ env1_id_set = fv_stmts `udfmMinusUFM` getUniqSet rec_id_set
env1_ids = dVarSetElems env1_id_set
env1_ty = mkBigCoreVarTupTy env1_ids
in_pair_ty = mkCorePairTy env1_ty rec_ty
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
index da29ac0e6ab9f8bac0523e44aa9a112194edbdad..8c4cf1205f989ee2513ebe70383b4a019aa10c8e 100644
--- a/compiler/deSugar/DsUsage.hs
+++ b/compiler/deSugar/DsUsage.hs
@@ -15,7 +15,7 @@ import NameSet
import Module
import Outputable
import Util
-import UniqFM
+import UniqSet
import UniqDFM
import ListSetOps
import Fingerprint
@@ -108,7 +108,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
-- ent_map groups together all the things imported and used
-- from a particular module
ent_map :: ModuleEnv [OccName]
- ent_map = nonDetFoldUFM add_mv emptyModuleEnv used_names
+ ent_map = nonDetFoldUniqSet add_mv emptyModuleEnv used_names
-- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName
-- in ent_hashs
where
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 95d734ea5da76209d12add9aad0fb38f5aa71484..b40dd5cd897b7106c044757ab333905a927a0deb 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -27,7 +27,7 @@ import IfaceEnv( newInteractiveBinder )
import Name
import Var hiding ( varName )
import VarSet
-import UniqFM
+import UniqSet
import Type
import GHC
import Outputable
@@ -100,11 +100,11 @@ pprintClosureCommand bindThings force str = do
my_tvs = termTyCoVars t
tvs = env_tvs `minusVarSet` my_tvs
tyvarOccName = nameOccName . tyVarName
- tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUFM tvs))
- -- It's OK to use nonDetEltsUFM here because initTidyOccEnv
+ tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
+ -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
-- forgets the ordering immediately by creating an env
- , env_tvs `intersectVarSet` my_tvs)
- return$ mapTermType (snd . tidyOpenType tidyEnv) t
+ , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
+ return $ mapTermType (snd . tidyOpenType tidyEnv) t
-- | Give names, and bind in the interactive environment, to all the suspensions
-- included (inductively) in a term
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b63c1c94b21b8b27c545a5de541d07a0b8cdd37c..a5b791a1511437dbfb861583785a7a5e746f7651 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -46,7 +46,6 @@ import TcEnv
import TyCon
import Name
-import VarEnv
import Util
import VarSet
import BasicTypes ( Boxity(..) )
@@ -307,12 +306,12 @@ mapTermTypeM f = foldTermM TermFoldM {
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = foldTerm TermFold {
fTerm = \ty _ _ tt ->
- tyCoVarsOfType ty `plusVarEnv` concatVarEnv tt,
+ tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
- fPrim = \ _ _ -> emptyVarEnv,
- fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `plusVarEnv` t,
- fRefWrap = \ty t -> tyCoVarsOfType ty `plusVarEnv` t}
- where concatVarEnv = foldr plusVarEnv emptyVarEnv
+ fPrim = \ _ _ -> emptyVarSet,
+ fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
+ fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
+ where concatVarEnv = foldr unionVarSet emptyVarSet
----------------------------------
-- Pretty printing of terms
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 27bb9e002150f8434937d160d00b66df2f0b51dc..7b1e3e21b4cf7bc35af56adbec382ea94ed1eeb2 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -104,7 +104,7 @@ import Maybes
import Binary
import Fingerprint
import Exception
-import UniqFM
+import UniqSet
import UniqDFM
import Packages
@@ -453,7 +453,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
-- filtering must be on the semantic module!
-- See Note [Identity versus semantic module]
. filter ((== semantic_mod) . name_module)
- . nonDetEltsUFM
+ . nonDetEltsUniqSet
-- It's OK to use nonDetEltsUFM as localOccs is only
-- used to construct the edges and
-- stronglyConnCompFromEdgedVertices is deterministic
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 1464531e721f24ada78a8874689264285c9a629a..424891fe776693c014e05064c13d0b84d6c43056 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -447,7 +447,7 @@ getGlobalPtr llvmLbl = do
-- will be generated anymore!
generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
generateExternDecls = do
- delayed <- fmap nonDetEltsUFM $ getEnv envAliases
+ delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
index c3df74345446cc308039d80cfd141a48b5e001e2..5731f18234407dddc9ef32b3f5f42f331f0d218a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
@@ -89,7 +89,7 @@ worst :: (RegClass -> UniqSet Reg)
worst regsOfClass regAlias neighbors classN classC
= let regAliasS regs = unionManyUniqSets
$ map regAlias
- $ nonDetEltsUFM regs
+ $ nonDetEltsUniqSet regs
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
@@ -126,7 +126,7 @@ bound regsOfClass regAlias classN classesC
regsC_aliases
= unionManyUniqSets
- $ map (regAliasS . regsOfClass) classesC
+ $ map (regAliasS . getUniqSet . regsOfClass) classesC
overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
@@ -155,5 +155,5 @@ powersetL = map concat . mapM (\x -> [[],[x]])
-- | powersetLS (list of sets)
powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
-powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUFM s
+powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s
-- See Note [Unique Determinism and code generation]
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index e819fe8870e192ffbf8fd1f7eb601e0552ed4fe4..08538453f740ee344d82f22f37da34c6cf937f41 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -111,7 +111,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
( text "It looks like the register allocator is stuck in an infinite loop."
$$ text "max cycles = " <> int maxSpinCount
$$ text "regsFree = " <> (hcat $ punctuate space $ map ppr
- $ nonDetEltsUFM $ unionManyUniqSets
+ $ nonDetEltsUniqSet $ unionManyUniqSets
$ nonDetEltsUFM regsFree)
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
@@ -316,15 +316,15 @@ graphAddConflictSet
graphAddConflictSet set graph
= let virtuals = mkUniqSet
- [ vr | RegVirtual vr <- nonDetEltsUFM set ]
+ [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
graph1 = Color.addConflicts virtuals classOfVirtualReg graph
graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
graph1
[ (vr, rr)
- | RegVirtual vr <- nonDetEltsUFM set
- , RegReal rr <- nonDetEltsUFM set]
+ | RegVirtual vr <- nonDetEltsUniqSet set
+ , RegReal rr <- nonDetEltsUniqSet set]
-- See Note [Unique Determinism and code generation]
in graph2
@@ -419,11 +419,11 @@ seqNode node
= seqVirtualReg (Color.nodeId node)
`seq` seqRegClass (Color.nodeClass node)
`seq` seqMaybeRealReg (Color.nodeColor node)
- `seq` (seqVirtualRegList (nonDetEltsUFM (Color.nodeConflicts node)))
- `seq` (seqRealRegList (nonDetEltsUFM (Color.nodeExclusions node)))
+ `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node)))
+ `seq` (seqRealRegList (nonDetEltsUniqSet (Color.nodeExclusions node)))
`seq` (seqRealRegList (Color.nodePreference node))
- `seq` (seqVirtualRegList (nonDetEltsUFM (Color.nodeCoalesce node)))
- -- It's OK to use nonDetEltsUFM for seq
+ `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node)))
+ -- It's OK to use nonDetEltsUniqSet for seq
seqVirtualReg :: VirtualReg -> ()
seqVirtualReg reg = reg `seq` ()
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index 0704e531023924e60babd3fc38180b26683e334b..9a3808ad9aff5a3745f00255dca17d87662ab127 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -61,9 +61,9 @@ regSpill platform code slotsFree regs
| otherwise
= do
-- Allocate a slot for each of the spilled regs.
- let slots = take (sizeUniqSet regs) $ nonDetEltsUFM slotsFree
+ let slots = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
let regSlotMap = listToUFM
- $ zip (nonDetEltsUFM regs) slots
+ $ zip (nonDetEltsUniqSet regs) slots
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
@@ -141,7 +141,7 @@ regSpill_top platform regSlotMap cmm
moreSlotsLive = IntSet.fromList
$ catMaybes
$ map (lookupUFM regSlotMap)
- $ nonDetEltsUFM regsLive
+ $ nonDetEltsUniqSet regsLive
-- See Note [Unique Determinism and code generation]
slotMap'
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index 03da772819719c6eadd2faa83169919213f7cb9a..0811147eda1934ef1163b3a5cd6aec8993edd290 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -413,7 +413,7 @@ intersects assocs = foldl1' intersectAssoc assocs
findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
findRegOfSlot assoc slot
| close <- closeAssoc (SSlot slot) assoc
- , Just (SReg reg) <- find isStoreReg $ nonDetEltsUFM close
+ , Just (SReg reg) <- find isStoreReg $ nonDetEltsUniqSet close
-- See Note [Unique Determinism and code generation]
= Just reg
@@ -549,7 +549,7 @@ delAssoc :: (Uniquable a)
delAssoc a m
| Just aSet <- lookupUFM m a
, m1 <- delFromUFM m a
- = nonDetFoldUFM (\x m -> delAssoc1 x a m) m1 aSet
+ = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
-- It's OK to use nonDetFoldUFM here because deletion is commutative
| otherwise = m
@@ -582,7 +582,7 @@ closeAssoc a assoc
= closeAssoc' assoc emptyUniqSet (unitUniqSet a)
where
closeAssoc' assoc visited toVisit
- = case nonDetEltsUFM toVisit of
+ = case nonDetEltsUniqSet toVisit of
-- See Note [Unique Determinism and code generation]
-- nothing else to visit, we're done
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index efa1cd11e27e71e40ca1ff83ccea997f8861d114..0817b3941a772659d7f314abc934e274552c0210 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -108,7 +108,7 @@ slurpSpillCostInfo platform cmm
countLIs rsLiveEntry (LiveInstr instr (Just live) : lis)
= do
-- Increment the lifetime counts for regs live on entry to this instr.
- mapM_ incLifetime $ nonDetEltsUFM rsLiveEntry
+ mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
@@ -140,7 +140,7 @@ slurpSpillCostInfo platform cmm
-- | Take all the virtual registers from this set.
takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
takeVirtuals set = mkUniqSet
- [ vr | RegVirtual vr <- nonDetEltsUFM set ]
+ [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
-- See Note [Unique Determinism and code generation]
@@ -260,7 +260,7 @@ nodeDegree classOfVirtualReg graph reg
, virtConflicts
<- length
$ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)
- $ nonDetEltsUFM
+ $ nonDetEltsUniqSet
-- See Note [Unique Determinism and code generation]
$ nodeConflicts node
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
index 81e0c5e091e7a19cc57bb7e462aa879e5eb6f98a..204de846ae496d403ca4867b324cda9fcb5ca977 100644
--- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -13,7 +13,7 @@ import Reg
import GraphBase
-import UniqFM
+import UniqSet
import Platform
import Panic
@@ -56,10 +56,10 @@ accSqueeze
:: Int
-> Int
-> (reg -> Int)
- -> UniqFM reg
+ -> UniqSet reg
-> Int
-accSqueeze count maxCount squeeze ufm = acc count (nonDetEltsUFM ufm)
+accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us)
-- See Note [Unique Determinism and code generation]
where acc count [] = count
acc count _ | count >= maxCount = count
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 055129703b5fd8add96ff3b16597ccbf809de5d3..b7721880c33889643a22adc019229eee6f43dad4 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -352,7 +352,7 @@ initBlock id block_live
setFreeRegsR (frInitFreeRegs platform)
Just live ->
setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
- [ r | RegReal r <- nonDetEltsUFM live ]
+ [ r | RegReal r <- nonDetEltsUniqSet live ]
-- See Note [Unique Determinism and code generation]
setAssigR emptyRegMap
@@ -446,8 +446,8 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
return (new_instrs, [])
_ -> genRaInsn block_live new_instrs id instr
- (nonDetEltsUFM $ liveDieRead live)
- (nonDetEltsUFM $ liveDieWrite live)
+ (nonDetEltsUniqSet $ liveDieRead live)
+ (nonDetEltsUniqSet $ liveDieWrite live)
-- See Note [Unique Determinism and code generation]
raInsn _ _ _ instr
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 4b00ed6cd6fd9d0e7cc48019433b35b62b91c350..e387f824203ce2ee9354ec24375ee33640ef2119 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -40,7 +40,7 @@ import Instruction
import BlockId
import Hoopl
-import Cmm hiding (RegSet)
+import Cmm hiding (RegSet, emptyRegSet)
import PprCmm()
import Digraph
@@ -66,6 +66,9 @@ type RegMap a = UniqFM a
emptyRegMap :: UniqFM a
emptyRegMap = emptyUFM
+emptyRegSet :: RegSet
+emptyRegSet = emptyUniqSet
+
type BlockMap a = LabelMap a
@@ -220,7 +223,8 @@ instance Outputable instr
where pprRegs :: SDoc -> RegSet -> SDoc
pprRegs name regs
| isEmptyUniqSet regs = empty
- | otherwise = name <> (pprUFM regs (hcat . punctuate space . map ppr))
+ | otherwise = name <>
+ (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr))
instance Outputable LiveInfo where
ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)
@@ -573,7 +577,7 @@ patchEraseLive patchF cmm
= let
patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set
-- See Note [Unique Determinism and code generation]
- blockMap' = mapMap patchRegSet blockMap
+ blockMap' = mapMap (patchRegSet . getUniqSet) blockMap
info' = LiveInfo static id (Just blockMap') mLiveSlots
in CmmProc info' label live $ map patchSCC sccs
@@ -629,9 +633,9 @@ patchRegsLiveInstr patchF li
(patchRegsOfInstr instr patchF)
(Just live
{ -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
- liveBorn = mkUniqSet $ map patchF $ nonDetEltsUFM $ liveBorn live
- , liveDieRead = mkUniqSet $ map patchF $ nonDetEltsUFM $ liveDieRead live
- , liveDieWrite = mkUniqSet $ map patchF $ nonDetEltsUFM $ liveDieWrite live })
+ liveBorn = mapUniqSet patchF $ liveBorn live
+ , liveDieRead = mapUniqSet patchF $ liveDieRead live
+ , liveDieWrite = mapUniqSet patchF $ liveDieWrite live })
-- See Note [Unique Determinism and code generation]
@@ -758,7 +762,7 @@ checkIsReverseDependent sccs'
= let dests = slurpJumpDestsOfBlock block
blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
badDests = dests `minusUniqSet` blocksSeen'
- in case nonDetEltsUFM badDests of
+ in case nonDetEltsUniqSet badDests of
-- See Note [Unique Determinism and code generation]
[] -> go blocksSeen' sccs
bad : _ -> Just bad
@@ -767,7 +771,7 @@ checkIsReverseDependent sccs'
= let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
badDests = dests `minusUniqSet` blocksSeen'
- in case nonDetEltsUFM badDests of
+ in case nonDetEltsUniqSet badDests of
-- See Note [Unique Determinism and code generation]
[] -> go blocksSeen' sccs
bad : _ -> Just bad
@@ -861,7 +865,7 @@ livenessSCCs platform blockmap done
= a' == b'
where a' = map f $ mapToList a
b' = map f $ mapToList b
- f (key,elt) = (key, nonDetEltsUFM elt)
+ f (key,elt) = (key, nonDetEltsUniqSet elt)
-- See Note [Unique Determinism and code generation]
@@ -989,7 +993,7 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
targetLiveRegs target
= case mapLookup target blockmap of
Just ra -> ra
- Nothing -> emptyRegMap
+ Nothing -> emptyRegSet
live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
@@ -998,8 +1002,8 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
-- registers that are live only in the branch targets should
-- be listed as dying here.
live_branch_only = live_from_branch `minusUniqSet` liveregs
- r_dying_br = nonDetEltsUFM (mkUniqSet r_dying `unionUniqSets`
- live_branch_only)
+ r_dying_br = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
+ live_branch_only)
-- See Note [Unique Determinism and code generation]
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index f6a22f5df2725277f205754becb1b2928c15ac12..f8b3347ca533a9bb4fbc12a8a31934d88c194fc4 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -48,7 +48,7 @@ import Bag
import Util
import Outputable
import FastString
-import UniqFM
+import UniqSet
import Maybes ( orElse )
import qualified GHC.LanguageExtensions as LangExt
@@ -528,8 +528,8 @@ depAnalBinds binds_w_dus
= (map get_binds sccs, map get_du sccs)
where
sccs = depAnal (\(_, defs, _) -> defs)
- (\(_, _, uses) -> nonDetEltsUFM uses)
- -- It's OK to use nonDetEltsUFM here as explained in
+ (\(_, _, uses) -> nonDetEltsUniqSet uses)
+ -- It's OK to use nonDetEltsUniqSet here as explained in
-- Note [depAnal determinism] in NameEnv.
(bagToList binds_w_dus)
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 3e462744e12591ac79a6725fb622f88306e33bfe..601d45b90e5bc10333908edfac5448732cbac6a6 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -51,7 +51,7 @@ import HscTypes ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
import Digraph ( SCC, flattenSCC, flattenSCCs
, stronglyConnCompFromEdgedVerticesUniq )
-import UniqFM
+import UniqSet
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
@@ -1348,7 +1348,7 @@ depAnalTyClDecls :: GlobalRdrEnv
depAnalTyClDecls rdr_env ds_w_fvs
= stronglyConnCompFromEdgedVerticesUniq edges
where
- edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUFM fvs))
+ edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUniqSet fvs))
| (d, fvs) <- ds_w_fvs ]
-- It's OK to use nonDetEltsUFM here as
-- stronglyConnCompFromEdgedVertices is still deterministic
@@ -1357,7 +1357,7 @@ depAnalTyClDecls rdr_env ds_w_fvs
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents rdr_env ns
- = nonDetFoldUFM add emptyNameSet ns
+ = nonDetFoldUniqSet add emptyNameSet ns
-- It's OK to use nonDetFoldUFM because we immediately forget the
-- ordering by creating a set
where
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index 949cbf16e9444c990731ada8a965aa0fe7467d47..3aaa1f3d473773917d87ee0aecc4e7824a6d9fcb 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -40,6 +40,7 @@ import Digraph ( SCC(..), Node
, stronglyConnCompFromEdgedVerticesUniqR )
import Unique
import UniqFM
+import UniqSet
import Util
import Outputable
import Data.List
@@ -88,7 +89,8 @@ occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds
-- Note [Preventing loops due to imported functions rules]
imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv
- [ mapVarEnv (const maps_to) (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)
+ [ mapVarEnv (const maps_to) $
+ getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)
| imp_rule <- imp_rules
, not (isBuiltinRule imp_rule) -- See Note [Plugin rules]
, let maps_to = exprFreeIds (ru_rhs imp_rule)
@@ -1221,8 +1223,8 @@ makeNode :: OccEnv -> ImpRuleEdges -> VarSet
-> (Var, CoreExpr) -> LetrecNode
-- See Note [Recursive bindings: the grand plan]
makeNode env imp_rule_edges bndr_set (bndr, rhs)
- = (details, varUnique bndr, nonDetKeysUFM node_fvs)
- -- It's OK to use nonDetKeysUFM here as stronglyConnCompFromEdgedVerticesR
+ = (details, varUnique bndr, nonDetKeysUniqSet node_fvs)
+ -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR
-- is still deterministic with edges in nondeterministic order as
-- explained in Note [Deterministic SCC] in Digraph.
where
@@ -1297,8 +1299,8 @@ mkLoopBreakerNodes lvl bndr_set body_uds details_s
[ (nd_bndr nd, nd_uds nd, nd_rhs_bndrs nd)
| nd <- details_s ]
mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr'
- = (nd', varUnique bndr, nonDetKeysUFM lb_deps)
- -- It's OK to use nonDetKeysUFM here as
+ = (nd', varUnique bndr, nonDetKeysUniqSet lb_deps)
+ -- It's OK to use nonDetKeysUniqSet here as
-- stronglyConnCompFromEdgedVerticesR is still deterministic with edges
-- in nondeterministic order as explained in
-- Note [Deterministic SCC] in Digraph.
@@ -2196,7 +2198,7 @@ extendFvs env s
extras :: VarSet -- env(s)
extras = nonDetFoldUFM unionVarSet emptyVarSet $
-- It's OK to use nonDetFoldUFM here because unionVarSet commutes
- intersectUFM_C (\x _ -> x) env s
+ intersectUFM_C (\x _ -> x) env (getUniqSet s)
{-
************************************************************************
@@ -2435,7 +2437,7 @@ mkOneOcc env id int_cxt arity
, occ_one_br = True
, occ_int_cxt = int_cxt
, occ_tail = AlwaysTailCalled arity }
- | id `elemVarEnv` occ_gbl_scrut env
+ | id `elemVarSet` occ_gbl_scrut env
= singleton noOccInfo
| otherwise
@@ -2451,7 +2453,7 @@ addOneOcc ud id info
plus_zapped old new = doZapping ud id old `addOccInfo` new
addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails
-addManyOccsSet usage id_set = nonDetFoldUFM addManyOccs usage id_set
+addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set
-- It's OK to use nonDetFoldUFM here because addManyOccs commutes
-- Add several occurrences, assumed not to be tail calls
@@ -2500,7 +2502,7 @@ v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud
udFreeVars :: VarSet -> UsageDetails -> VarSet
-- Find the subset of bndrs that are mentioned in uds
-udFreeVars bndrs ud = intersectUFM_C (\b _ -> b) bndrs (ud_env ud)
+udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud)
-------------------
-- Auxiliary functions for UsageDetails implementation
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 38dc6e333ec1ab0b4b177209c5f146ad6a97421d..9271eda8c582a918874c4ff4b6ce2de900d8bf50 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -35,6 +35,7 @@ import TysPrim ( realWorldStatePrimTy )
import ErrUtils ( dumpIfSet_dyn )
import Name ( getName, stableNameCmp )
import Data.Function ( on )
+import UniqSet
{-
************************************************************************
@@ -717,7 +718,7 @@ unitDmdType :: DmdEnv -> DmdType
unitDmdType dmd_env = DmdType dmd_env [] topRes
coercionDmdEnv :: Coercion -> DmdEnv
-coercionDmdEnv co = mapVarEnv (const topDmd) (coVarsOfCo co)
+coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
-- The VarSet from coVarsOfCo is really a VarEnv Var
addVarDmd :: DmdType -> Var -> Demand -> DmdType
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 5586abe2900d91123d6aab0520aca5af60594be3..bb20b43892b364379c65c96dd8f88c671440095c 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -61,6 +61,7 @@ import PrelNames( ipClassName )
import TcValidity (checkValidType)
import Unique (getUnique)
import UniqFM
+import UniqSet
import qualified GHC.LanguageExtensions as LangExt
import ConLike
@@ -546,7 +547,7 @@ type BKey = Int -- Just number off the bindings
mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
-- See Note [Polymorphic recursion] in HsBinds.
mkEdges sig_fn binds
- = [ (bind, key, [key | n <- nonDetEltsUFM (bind_fvs (unLoc bind)),
+ = [ (bind, key, [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
Just key <- [lookupNameEnv key_map n], no_sig n ])
| (bind, key) <- keyd_binds
]
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 4455c9bd6af69392dfcaffacca897883d3899f17..006b01ca92af59affd170576e57b277f663cec83 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -62,7 +62,7 @@ import Outputable
import FastString
import SrcLoc
import Data.IORef( IORef )
-import UniqFM
+import UniqSet
{-
Note [TcCoercions]
@@ -808,9 +808,9 @@ sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
- = (b, var, nonDetEltsUFM (evVarsOfTerm term `unionVarSet`
+ = (b, var, nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`
coVarsOfType (varType var)))
- -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
+ -- 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.
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 3d2a1058ac457cdb9a347bb3174bb5c8455f1111..6c9b5a2b1c2333f76d45e538a72473b82d5a9b71 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -70,7 +70,7 @@ import Outputable
import FastString
import Control.Monad
import Class(classTyCon)
-import UniqFM ( nonDetEltsUFM )
+import UniqSet ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt
import Data.Function
@@ -616,9 +616,9 @@ tcExpr (HsStatic fvs expr) res_ty
) $
tcPolyExprNC expr expr_ty
-- Check that the free variables of the static form are closed.
- -- It's OK to use nonDetEltsUFM here as the only side effects of
+ -- It's OK to use nonDetEltsUniqSet here as the only side effects of
-- checkClosedInStaticForm are error messages.
- ; mapM_ checkClosedInStaticForm $ nonDetEltsUFM fvs
+ ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
-- Require the type of the argument to be Typeable.
-- The evidence is not used, but asking the constraint ensures that
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 56cc7111954f7117b22890461b5d74c948b7bf09..58c0e218195262758b1f4338a539fce6e1296b98 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -115,7 +115,7 @@ import FastString
import SrcLoc
import Bag
import Pair
-import UniqFM
+import UniqSet
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
@@ -1280,8 +1280,8 @@ zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv
zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet
zonkTyCoVarsAndFV tycovars =
- tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUFM tycovars)
- -- It's OK to use nonDetEltsUFM here because we immediately forget about
+ tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)
+ -- It's OK to use nonDetEltsUniqSet here because we immediately forget about
-- the ordering by turning it into a nondeterministic set and the order
-- of zonking doesn't matter for determinism.
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 4e6097bd62e0973fa0bec9334c834b2ec3d15a64..2502c6e865d47488ab87d3ff4455c2347d7ba521 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -169,6 +169,7 @@ import Data.List ( foldl', partition )
#ifdef DEBUG
import Digraph
+import UniqSet
#endif
{-
@@ -2422,7 +2423,7 @@ checkForCyclicBinds ev_binds_map
is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)
edges :: [(EvBind, EvVar, [EvVar])]
- edges = [ (bind, bndr, nonDetEltsUFM (evVarsOfTerm rhs))
+ edges = [ (bind, bndr, nonDetEltsUniqSet (evVarsOfTerm rhs))
| bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
-- It's OK to use nonDetEltsUFM here as
-- stronglyConnCompFromEdgedVertices is still deterministic even
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 51bd273f071f46cd379e8b5e08e79225466a81df..73398a8e76ba60cc5a6efd560b20d81aab1c2990 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -44,7 +44,7 @@ import Unify ( tcMatchTyKi )
import Util
import Var
import VarSet
-import UniqFM
+import UniqSet
import BasicTypes ( IntWithInf, intGtLimit )
import ErrUtils ( emptyMessages )
import qualified GHC.LanguageExtensions as LangExt
@@ -689,8 +689,8 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
-- promoteTyVar ignores coercion variables
; outer_tclvl <- TcM.getTcLevel
- ; mapM_ (promoteTyVar outer_tclvl) (nonDetEltsUFM promote_tkvs)
- -- It's OK to use nonDetEltsUFM here because promoteTyVar is
+ ; mapM_ (promoteTyVar outer_tclvl) (nonDetEltsUniqSet promote_tkvs)
+ -- It's OK to use nonDetEltsUniqSet here because promoteTyVar is
-- commutative
-- Emit an implication constraint for the
@@ -1436,7 +1436,7 @@ neededEvVars (ev_binds, tcvs) initial_seeds
also_needs :: VarSet -> VarSet
also_needs needs
- = nonDetFoldUFM add emptyVarSet needs
+ = nonDetFoldUniqSet add emptyVarSet needs
-- It's OK to use nonDetFoldUFM here because we immediately forget
-- about the ordering by creating a set
where
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 626a1e8cfce4ba093560b475a62fef4454403ff2..c518101638e48c2096afed0538368b482ca416bf 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -43,6 +43,7 @@ import ConLike
import DataCon
import Name
import NameEnv
+import NameSet hiding (unitFV)
import RdrName ( mkVarUnqual )
import Id
import IdInfo
@@ -180,7 +181,7 @@ checkNameIsAcyclic n m = SynCycleM $ \s ->
-- can give better error messages.
checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl Name] -> TcM ()
checkSynCycles this_uid tcs tyclds = do
- case runSynCycleM (mapM_ (go emptyNameEnv []) tcs) emptyNameEnv of
+ case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of
Left (loc, err) -> setSrcSpan loc $ failWithTc err
Right _ -> return ()
where
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 6f9c3fafb1517242bdcf9f721e6df99fb311d1d9..4a56bbea7a16f35de2a4a09639d2a46651d80dc3 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -48,7 +48,7 @@ import FamInst ( makeInjectivityErrors )
import Name
import VarEnv
import VarSet
-import UniqFM
+import UniqSet
import Var ( TyVarBndr(..), mkTyVar )
import ErrUtils
import DynFlags
@@ -1899,8 +1899,8 @@ checkValidInferredKinds orig_kvs out_of_scope extra
where
(env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs
- (env, _) = tidyTyCoVarBndrs env1 (nonDetEltsUFM out_of_scope)
- -- It's OK to use nonDetEltsUFM here because it's only used for
+ (env, _) = tidyTyCoVarBndrs env1 (nonDetEltsUniqSet out_of_scope)
+ -- It's OK to use nonDetEltsUniqSet here because it's only used for
-- generating the error message
{-
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 6b693ef97bfe9cc5e85f210c0bad56a828be6e6d..967e6f72686373bb27a94868578e897fd793ec4b 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -167,6 +167,7 @@ import Pair
import UniqSupply
import Util
import UniqFM
+import UniqSet
-- libraries
import qualified Data.Data as Data hiding ( TyCon )
@@ -1535,8 +1536,8 @@ coVarsOfCos cos = mapUnionVarSet coVarsOfCo cos
-- | Add the kind variables free in the kinds of the tyvars in the given set.
-- Returns a non-deterministic set.
closeOverKinds :: TyVarSet -> TyVarSet
-closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUFM
- -- It's OK to use nonDetEltsUFM here because we immediately forget
+closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet
+ -- It's OK to use nonDetEltsUniqSet here because we immediately forget
-- about the ordering by returning a set.
-- | Given a list of tyvars returns a deterministic FV computation that
@@ -2107,7 +2108,7 @@ checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
-- It's OK to use nonDetKeysUFM here, because we only use this list to
-- remove some elements from a set
needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos)
- `delListFromUFM_Directly` substDomain
+ `delListFromUniqSet_Directly` substDomain
tysCosFVsInScope = needInScope `varSetInScope` in_scope
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 6c01c741b0bbace0dc22154d0b7e1e0f4ab46db0..5a2431c5a29081d690ac09032ce727d6c0c240af 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -215,7 +215,7 @@ import TyCoRep
import Var
import VarEnv
import VarSet
-import NameEnv
+import UniqSet
import Class
import TyCon
@@ -2365,51 +2365,51 @@ resultIsLevPoly = isTypeLevPoly . snd . splitPiTys
-- | All type constructors occurring in the type; looking through type
-- synonyms, but not newtypes.
-- When it finds a Class, it returns the class TyCon.
-tyConsOfType :: Type -> NameEnv TyCon
+tyConsOfType :: Type -> UniqSet TyCon
tyConsOfType ty
= go ty
where
- go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
+ go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim
go ty | Just ty' <- coreView ty = go ty'
- go (TyVarTy {}) = emptyNameEnv
- go (LitTy {}) = emptyNameEnv
- go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys
- go (AppTy a b) = go a `plusNameEnv` go b
- go (FunTy a b) = go a `plusNameEnv` go b `plusNameEnv` go_tc funTyCon
- go (ForAllTy (TvBndr tv _) ty) = go ty `plusNameEnv` go (tyVarKind tv)
- go (CastTy ty co) = go ty `plusNameEnv` go_co co
+ go (TyVarTy {}) = emptyUniqSet
+ go (LitTy {}) = emptyUniqSet
+ go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys
+ go (AppTy a b) = go a `unionUniqSets` go b
+ go (FunTy a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon
+ go (ForAllTy (TvBndr tv _) ty) = go ty `unionUniqSets` go (tyVarKind tv)
+ go (CastTy ty co) = go ty `unionUniqSets` go_co co
go (CoercionTy co) = go_co co
go_co (Refl _ ty) = go ty
- go_co (TyConAppCo _ tc args) = go_tc tc `plusNameEnv` go_cos args
- go_co (AppCo co arg) = go_co co `plusNameEnv` go_co arg
- go_co (ForAllCo _ kind_co co) = go_co kind_co `plusNameEnv` go_co co
- go_co (FunCo _ co1 co2) = go_co co1 `plusNameEnv` go_co co2
- go_co (CoVarCo {}) = emptyNameEnv
- go_co (AxiomInstCo ax _ args) = go_ax ax `plusNameEnv` go_cos args
- go_co (UnivCo p _ t1 t2) = go_prov p `plusNameEnv` go t1 `plusNameEnv` go t2
+ go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args
+ go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg
+ go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co
+ go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2
+ go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args
+ go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2
+ go_co (CoVarCo {}) = emptyUniqSet
go_co (SymCo co) = go_co co
- go_co (TransCo co1 co2) = go_co co1 `plusNameEnv` go_co co2
+ go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2
go_co (NthCo _ co) = go_co co
go_co (LRCo _ co) = go_co co
- go_co (InstCo co arg) = go_co co `plusNameEnv` go_co arg
- go_co (CoherenceCo co1 co2) = go_co co1 `plusNameEnv` go_co co2
+ go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg
+ go_co (CoherenceCo co1 co2) = go_co co1 `unionUniqSets` go_co co2
go_co (KindCo co) = go_co co
go_co (SubCo co) = go_co co
go_co (AxiomRuleCo _ cs) = go_cos cs
- go_prov UnsafeCoerceProv = emptyNameEnv
+ go_prov UnsafeCoerceProv = emptyUniqSet
go_prov (PhantomProv co) = go_co co
go_prov (ProofIrrelProv co) = go_co co
- go_prov (PluginProv _) = emptyNameEnv
- go_prov (HoleProv _) = emptyNameEnv
+ go_prov (PluginProv _) = emptyUniqSet
+ go_prov (HoleProv _) = emptyUniqSet
-- this last case can happen from the tyConsOfType used from
-- checkTauTvUpdate
- go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
- go_cos cos = foldr (plusNameEnv . go_co) emptyNameEnv cos
+ go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys
+ go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos
- go_tc tc = unitNameEnv (tyConName tc) tc
+ go_tc tc = unitUniqSet tc
go_ax ax = go_tc $ coAxiomTyCon ax
-- | Find the result 'Kind' of a type synonym,
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index 517358d482b47ed0d3b20a4862cfd4ac06e21b4e..77fe5d805f714a9513ed7f466c92c1eede943c07 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -39,6 +39,7 @@ import Util
import Pair
import Outputable
import UniqFM
+import UniqSet
import Control.Monad
#if __GLASGOW_HASKELL__ > 710
@@ -537,8 +538,8 @@ niFixTCvSubst tenv = f tenv
setTyVarKind rtv $
substTy subst $
tyVarKind rtv)
- | rtv <- nonDetEltsUFM range_tvs
- -- It's OK to use nonDetEltsUFM here
+ | rtv <- nonDetEltsUniqSet range_tvs
+ -- It's OK to use nonDetEltsUniqSet here
-- because we forget the order
-- immediatedly by putting it in VarEnv
, not (in_domain rtv) ]
@@ -549,7 +550,7 @@ niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet
-- remembering that the substitution isn't necessarily idempotent
-- This is used in the occurs check, before extending the substitution
niSubstTvSet tsubst tvs
- = nonDetFoldUFM (unionVarSet . get) emptyVarSet tvs
+ = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs
-- It's OK to nonDetFoldUFM here because we immediately forget the
-- ordering by creating a set.
where
@@ -1095,10 +1096,10 @@ umRnBndr2 v1 v2 thing = UM $ \env state ->
let rn_env' = rnBndr2 (um_rn_env env) v1 v2 in
unUM thing (env { um_rn_env = rn_env' }) state
-checkRnEnv :: (RnEnv2 -> VarSet) -> VarSet -> UM ()
+checkRnEnv :: (RnEnv2 -> VarEnv Var) -> VarSet -> UM ()
checkRnEnv get_set varset = UM $ \env state ->
let env_vars = get_set (um_rn_env env) in
- if isEmptyVarSet env_vars || varset `disjointVarSet` env_vars
+ if isEmptyVarEnv env_vars || (getUniqSet varset `disjointVarEnv` env_vars)
-- NB: That isEmptyVarSet is a critical optimization; it
-- means we don't have to calculate the free vars of
-- the type, often saving quite a bit of allocation.
diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs
index 056ce0daa4aef4a9c9b472f948a1f7d533cbd9b5..492125b787b2b9728f2428d0e7478cdef2c615be 100644
--- a/compiler/utils/GraphColor.hs
+++ b/compiler/utils/GraphColor.hs
@@ -309,7 +309,7 @@ selectColor colors graph u
Just nsConflicts
= sequence
$ map (lookupNode graph)
- $ nonDetEltsUFM
+ $ nonDetEltsUniqSet
$ nodeConflicts node
-- See Note [Unique Determinism and code generation]
@@ -356,7 +356,7 @@ selectColor colors graph u
-- it wasn't a preference, but it was still ok
| not $ isEmptyUniqSet colors_ok
- , c : _ <- nonDetEltsUFM colors_ok
+ , c : _ <- nonDetEltsUniqSet colors_ok
-- See Note [Unique Determinism and code generation]
= Just c
diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 0985797571d025dde144da69e655bb26b2884127..3677e517b5ba73092f72d09144e462bec83dadcd 100644
--- a/compiler/utils/GraphOps.hs
+++ b/compiler/utils/GraphOps.hs
@@ -59,7 +59,7 @@ addNode k node graph
= let
-- add back conflict edges from other nodes to this one
map_conflict =
- nonDetFoldUFM
+ nonDetFoldUniqSet
-- It's OK to use nonDetFoldUFM here because the
-- operation is commutative
(adjustUFM_C (\n -> n { nodeConflicts =
@@ -69,7 +69,7 @@ addNode k node graph
-- add back coalesce edges from other nodes to this one
map_coalesce =
- nonDetFoldUFM
+ nonDetFoldUniqSet
-- It's OK to use nonDetFoldUFM here because the
-- operation is commutative
(adjustUFM_C (\n -> n { nodeCoalesce =
@@ -89,11 +89,11 @@ delNode k graph
| Just node <- lookupNode graph k
= let -- delete conflict edges from other nodes to this one.
graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
- $ nonDetEltsUFM (nodeConflicts node)
+ $ nonDetEltsUniqSet (nodeConflicts node)
-- delete coalesce edge from other nodes to this one.
graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
- $ nonDetEltsUFM (nodeCoalesce node)
+ $ nonDetEltsUniqSet (nodeCoalesce node)
-- See Note [Unique Determinism and code generation]
-- delete the node
@@ -182,7 +182,7 @@ addConflicts
addConflicts conflicts getClass
-- just a single node, but no conflicts, create the node anyway.
- | (u : []) <- nonDetEltsUFM conflicts
+ | (u : []) <- nonDetEltsUniqSet conflicts
= graphMapModify
$ adjustWithDefaultUFM
id
@@ -191,8 +191,8 @@ addConflicts conflicts getClass
| otherwise
= graphMapModify
- $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm
- $ nonDetEltsUFM conflicts)
+ $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm
+ $ nonDetEltsUniqSet conflicts
-- See Note [Unique Determinism and code generation]
@@ -318,7 +318,7 @@ coalesceGraph' aggressive triv graph kkPairsAcc
--
cList = [ (nodeId node1, k2)
| node1 <- cNodes
- , k2 <- nonDetEltsUFM $ nodeCoalesce node1 ]
+ , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ]
-- See Note [Unique Determinism and code generation]
-- do the coalescing, returning the new graph and a list of pairs of keys
@@ -472,7 +472,7 @@ freezeNode k
else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
-- If the edge isn't actually in the coelesce set then just ignore it.
- fm2 = nonDetFoldUFM (adjustUFM_C (freezeEdge k)) fm1
+ fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
-- It's OK to use nonDetFoldUFM here because the operation
-- is commutative
$ nodeCoalesce node
@@ -568,7 +568,7 @@ validateGraph doc isColored graph
, not $ isEmptyUniqSet badEdges
= pprPanic "GraphOps.validateGraph"
( text "Graph has edges that point to non-existent nodes"
- $$ text " bad edges: " <> pprUFM badEdges (vcat . map ppr)
+ $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)
$$ doc )
-- Check that no conflicting nodes have the same color
@@ -609,7 +609,7 @@ checkNode
checkNode graph node
| Just color <- nodeColor node
, Just neighbors <- sequence $ map (lookupNode graph)
- $ nonDetEltsUFM $ nodeConflicts node
+ $ nonDetEltsUniqSet $ nodeConflicts node
-- See Note [Unique Determinism and code generation]
, neighbourColors <- catMaybes $ map nodeColor neighbors
diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs
index f5276842aa4f7111d5b387c79c2117816dc1b043..a40e1058d0bd16b1f1ae74fce2eae0a09261941b 100644
--- a/compiler/utils/GraphPpr.hs
+++ b/compiler/utils/GraphPpr.hs
@@ -87,7 +87,7 @@ dotNode colorMap triv node
excludes
= hcat $ punctuate space
$ map (\n -> text "-" <> ppr n)
- $ nonDetEltsUFM $ nodeExclusions node
+ $ nonDetEltsUniqSet $ nodeExclusions node
-- See Note [Unique Determinism and code generation]
preferences
@@ -146,13 +146,13 @@ dotNodeEdges visited node
| otherwise
= let dconflicts
= map (dotEdgeConflict (nodeId node))
- $ nonDetEltsUFM
+ $ nonDetEltsUniqSet
-- See Note [Unique Determinism and code generation]
$ minusUniqSet (nodeConflicts node) visited
dcoalesces
= map (dotEdgeCoalesce (nodeId node))
- $ nonDetEltsUFM
+ $ nonDetEltsUniqSet
-- See Note [Unique Determinism and code generation]
$ minusUniqSet (nodeCoalesce node) visited
diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs
index 90e9996d1aca43281b68541c31f6d3a034b93513..4e8c7ed97ff5652a835435373394ae6b1279cad8 100644
--- a/compiler/utils/UniqDSet.hs
+++ b/compiler/utils/UniqDSet.hs
@@ -70,7 +70,7 @@ minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a
minusUniqDSet = minusUDFM
uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a
-uniqDSetMinusUniqSet = udfmMinusUFM
+uniqDSetMinusUniqSet xs ys = udfmMinusUFM xs (getUniqSet ys)
intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a
intersectUniqDSets = intersectUDFM
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 49ceb89d903da059c711d51e5f1dc1f0d6907529..8214f1704bc734aa578762b283c020f355d61e5f 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -233,7 +233,7 @@ plusUFMList = foldl' plusUFM emptyUFM
minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
-intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
+intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
intersectUFM_C
diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs
index 6f58652f8094533c2014725da8591956616b6cb1..ede900a842e61f6d4d9ea66b8b36ea5bda4e777d 100644
--- a/compiler/utils/UniqSet.hs
+++ b/compiler/utils/UniqSet.hs
@@ -8,33 +8,54 @@ Based on @UniqFMs@ (as you would expect).
Basically, the things need to be in class @Uniquable@.
-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module UniqSet (
-- * Unique set type
UniqSet, -- type synonym for UniqFM a
+ getUniqSet,
+ pprUniqSet,
-- ** Manipulating these sets
emptyUniqSet,
unitUniqSet,
mkUniqSet,
- addOneToUniqSet, addOneToUniqSet_C, addListToUniqSet,
+ addOneToUniqSet, addListToUniqSet,
delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,
+ delListFromUniqSet_Directly,
unionUniqSets, unionManyUniqSets,
- minusUniqSet,
+ minusUniqSet, uniqSetMinusUFM,
intersectUniqSets,
+ restrictUniqSetToUFM,
uniqSetAny, uniqSetAll,
elementOfUniqSet,
elemUniqSet_Directly,
filterUniqSet,
+ filterUniqSet_Directly,
sizeUniqSet,
isEmptyUniqSet,
lookupUniqSet,
- partitionUniqSet
+ lookupUniqSet_Directly,
+ partitionUniqSet,
+ mapUniqSet,
+ unsafeUFMToUniqSet,
+ nonDetEltsUniqSet,
+ nonDetKeysUniqSet,
+ nonDetFoldUniqSet,
+ nonDetFoldUniqSet_Directly
) where
import UniqFM
import Unique
+import Data.Coerce
+import Outputable
import Data.Foldable (foldl')
+import Data.Data
+#if __GLASGOW_HASKELL__ >= 801
+import qualified Data.Semigroup
+#endif
{-
************************************************************************
@@ -49,26 +70,45 @@ unitUniqSet :: Uniquable a => a -> UniqSet a
mkUniqSet :: Uniquable a => [a] -> UniqSet a
addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
-addOneToUniqSet_C :: Uniquable a => (a -> a -> a) -> UniqSet a -> a -> UniqSet a
addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a
delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
+delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a
unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
unionManyUniqSets :: [UniqSet a] -> UniqSet a
minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
+restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a
+uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a
elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
elemUniqSet_Directly :: Unique -> UniqSet a -> Bool
filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a
+filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt
partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a)
sizeUniqSet :: UniqSet a -> Int
isEmptyUniqSet :: UniqSet a -> Bool
lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b
+lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a
+
+nonDetEltsUniqSet :: UniqSet elt -> [elt]
+nonDetKeysUniqSet :: UniqSet elt -> [Unique]
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a
+
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a
+
+mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
{-
************************************************************************
@@ -87,36 +127,74 @@ lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b
-- that only updated the values and it's been removed, because it broke
-- the invariant.
-type UniqSet a = UniqFM a
-
-emptyUniqSet = emptyUFM
-unitUniqSet x = unitUFM x x
+newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} deriving Data
+getUniqSet :: UniqSet a -> UniqFM a
+getUniqSet = getUniqSet'
+
+-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@
+-- assuming, without checking, that it maps each 'Unique' to a value
+-- that has that 'Unique'. See Note [Unsound mapUniqSet].
+unsafeUFMToUniqSet :: UniqFM a -> UniqSet a
+unsafeUFMToUniqSet = UniqSet
+
+instance Outputable a => Outputable (UniqSet a) where
+ ppr = pprUniqSet ppr
+#if __GLASGOW_HASKELL__ >= 801
+instance Data.Semigroup.Semigroup (UniqSet a) where
+ (<>) = mappend
+#endif
+instance Monoid (UniqSet a) where
+ mempty = UniqSet mempty
+ UniqSet s `mappend` UniqSet t = UniqSet (s `mappend` t)
+
+pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc
+pprUniqSet f (UniqSet s) = pprUniqFM f s
+
+emptyUniqSet = UniqSet emptyUFM
+unitUniqSet x = UniqSet $ unitUFM x x
mkUniqSet = foldl' addOneToUniqSet emptyUniqSet
-addOneToUniqSet set x = addToUFM set x x
-addOneToUniqSet_C f set x = addToUFM_C f set x x
+addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x)
addListToUniqSet = foldl' addOneToUniqSet
-delOneFromUniqSet = delFromUFM
-delOneFromUniqSet_Directly = delFromUFM_Directly
-delListFromUniqSet = delListFromUFM
+delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a)
+delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u)
+delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l)
+delListFromUniqSet_Directly (UniqSet s) l =
+ UniqSet (delListFromUFM_Directly s l)
+
+unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t)
-unionUniqSets = plusUFM
unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet
-minusUniqSet = minusUFM
-intersectUniqSets = intersectUFM
-elementOfUniqSet = elemUFM
-elemUniqSet_Directly = elemUFM_Directly
-filterUniqSet = filterUFM
-partitionUniqSet = partitionUFM
+minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t)
+uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)
-sizeUniqSet = sizeUFM
-isEmptyUniqSet = isNullUFM
-lookupUniqSet = lookupUFM
+
+intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t)
+restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)
+
+elementOfUniqSet a (UniqSet s) = elemUFM a s
+elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s
+filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s)
+filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s)
+
+partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s)
+
+sizeUniqSet (UniqSet s) = sizeUFM s
+isEmptyUniqSet (UniqSet s) = isNullUFM s
+lookupUniqSet (UniqSet s) k = lookupUFM s k
+lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k
uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool
-uniqSetAny = anyUFM
+uniqSetAny p (UniqSet s) = anyUFM p s
uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool
-uniqSetAll = allUFM
+uniqSetAll p (UniqSet s) = allUFM p s
+
+nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s
+nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s
+nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet'
+nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet'
+
+mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index faaad69ba7d34587dfb8e6da70e523e59d5e6cee..8f1a0a0662e99a7a5e89078ec2437810d5f8d2c2 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -31,6 +31,7 @@ import Name
import NameEnv
import FastString
import UniqDFM
+import UniqSet
import Data.Maybe
@@ -210,7 +211,7 @@ modVectInfo env mg_ids mg_tyCons vectDecls info
, vectInfoTyCon = mk_env tyCons (global_tycons env)
, vectInfoDataCon = mk_env dataCons (global_datacons env)
, vectInfoParallelVars = (global_parallel_vars env `minusDVarSet` vectInfoParallelVars info)
- `udfmIntersectUFM` (mkVarSet ids)
+ `udfmIntersectUFM` (getUniqSet $ mkVarSet ids)
, vectInfoParallelTyCons = global_parallel_tycons env `minusNameSet` vectInfoParallelTyCons info
}
where
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 98d90424829c7bd71e755963508ddd77c1635b72..a1215fd8c0a370aac16f55df63af899c342ccec7 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -67,15 +67,15 @@ classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyC
refs = ds `delListFromUniqSet` tcs
-- the tycons that directly or indirectly depend on parallel arrays
- tcs_par | anyUFM ((`elemNameSet` parTyCons) . tyConName) refs = tcs
+ tcs_par | uniqSetAny ((`elemNameSet` parTyCons) . tyConName) refs = tcs
| otherwise = []
pts' = pts `extendNameSetList` map tyConName tcs_par
- can_convert = (isNullUFM (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `minusUFM` cs))
+ can_convert = (isEmptyUniqSet (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `uniqSetMinusUFM` cs))
&& all convertable tcs)
|| isShowClass tcs
- must_convert = anyUFM id (intersectUFM_C const cs refs)
+ must_convert = anyUFM id (intersectUFM_C const cs (getUniqSet refs))
&& (not . isShowClass $ tcs)
-- We currently admit Haskell 2011-style data and newtype declarations as well as type
@@ -98,9 +98,9 @@ type TyConGroup = ([TyCon], UniqSet TyCon)
tyConGroups :: [TyCon] -> [TyConGroup]
tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges)
where
- edges = [((tc, ds), tc, nonDetEltsUFM ds) | tc <- tcs
+ edges = [((tc, ds), tc, nonDetEltsUniqSet ds) | tc <- tcs
, let ds = tyConsOfTyCon tc]
- -- It's OK to use nonDetEltsUFM here as
+ -- 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.
diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs
index 12a56add850c840f74996c469fdd5caa86bd8429..6b9591e6a1523a9abd0dd3647aeab92bbc3b0fc1 100644
--- a/testsuite/tests/callarity/unittest/CallArity1.hs
+++ b/testsuite/tests/callarity/unittest/CallArity1.hs
@@ -19,7 +19,7 @@ import System.Environment( getArgs )
import VarSet
import PprCore
import Unique
-import UniqFM
+import UniqSet
import CoreLint
import FastString
@@ -175,8 +175,8 @@ main = do
putMsg dflags (text n <> char ':')
-- liftIO $ putMsg dflags (ppr e)
let e' = callArityRHS e
- let bndrs = nonDetEltsUFM (allBoundIds e')
- -- It should be OK to use nonDetEltsUFM here, if it becomes a
+ let bndrs = nonDetEltsUniqSet (allBoundIds e')
+ -- It should be OK to use nonDetEltsUniqSet here, if it becomes a
-- problem we should use DVarSet
-- liftIO $ putMsg dflags (ppr e')
forM_ bndrs $ \v -> putMsg dflags $ nest 4 $ ppr v <+> ppr (idCallArity v)