Upgrade UniqSet to a newtype
authorDavid Feuer <david.feuer@gmail.com>
Wed, 1 Mar 2017 18:47:39 +0000 (13:47 -0500)
committerDavid Feuer <David.Feuer@gmail.com>
Wed, 1 Mar 2017 18:47:41 +0000 (13:47 -0500)
The fundamental problem with `type UniqSet = UniqFM` is that `UniqSet`
has a key invariant `UniqFM` does not. For example, `fmap` over
`UniqSet` will generally produce nonsense.

* Upgrade `UniqSet` from a type synonym to a newtype.

* Remove unused and shady `extendVarSet_C` and `addOneToUniqSet_C`.

* Use cached unique in `tyConsOfType` by replacing
  `unitNameEnv (tyConName tc) tc` with `unitUniqSet tc`.

Reviewers: austin, hvr, goldfire, simonmar, niteria, bgamari

Reviewed By: niteria

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3146

47 files changed:
compiler/basicTypes/DataCon.hs
compiler/basicTypes/NameSet.hs
compiler/basicTypes/RdrName.hs
compiler/basicTypes/VarEnv.hs
compiler/basicTypes/VarSet.hs
compiler/cmm/PprC.hs
compiler/coreSyn/CoreFVs.hs
compiler/coreSyn/CoreSubst.hs
compiler/coreSyn/CoreSyn.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsUsage.hs
compiler/ghci/Debugger.hs
compiler/ghci/RtClosureInspect.hs
compiler/iface/MkIface.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
compiler/nativeGen/RegAlloc/Graph/Main.hs
compiler/nativeGen/RegAlloc/Graph/Spill.hs
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/rename/RnBinds.hs
compiler/rename/RnSource.hs
compiler/simplCore/OccurAnal.hs
compiler/stranal/DmdAnal.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcTyDecls.hs
compiler/typecheck/TcValidity.hs
compiler/types/TyCoRep.hs
compiler/types/Type.hs
compiler/types/Unify.hs
compiler/utils/GraphColor.hs
compiler/utils/GraphOps.hs
compiler/utils/GraphPpr.hs
compiler/utils/UniqDSet.hs
compiler/utils/UniqFM.hs
compiler/utils/UniqSet.hs
compiler/vectorise/Vectorise/Env.hs
compiler/vectorise/Vectorise/Type/Classify.hs
testsuite/tests/callarity/unittest/CallArity1.hs

index 96c3772..43bcf75 100644 (file)
@@ -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
index 0ab4ec0..57de81c 100644 (file)
@@ -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
 
 {-
index 23c6d68..3a4324b 100644 (file)
@@ -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
index 3177abb..e22c207 100644 (file)
@@ -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
index f6d82fd..8877f64 100644 (file)
@@ -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)
index 811d908..dba8ca6 100644 (file)
@@ -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)
 
index 511ffc1..5997a9c 100644 (file)
@@ -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
index 043d3c3..590d870 100644 (file)
@@ -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
index 2616e6f..31fbd12 100644 (file)
@@ -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
index f686b68..c3be555 100644 (file)
@@ -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
index da29ac0..8c4cf12 100644 (file)
@@ -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
index 95d734e..b40dd5c 100644 (file)
@@ -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
index b63c1c9..a5b791a 100644 (file)
@@ -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
index 27bb9e0..7b1e3e2 100644 (file)
@@ -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
index 1464531..424891f 100644 (file)
@@ -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]
index c3df743..5731f18 100644 (file)
@@ -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]
index e819fe8..0853845 100644 (file)
@@ -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` ()
index 0704e53..9a3808a 100644 (file)
@@ -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'
index 03da772..0811147 100644 (file)
@@ -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
index efa1cd1..0817b39 100644 (file)
@@ -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
 
index 81e0c5e..204de84 100644 (file)
@@ -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
index 0551297..b772188 100644 (file)
@@ -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
index 4b00ed6..e387f82 100644 (file)
@@ -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]
 
 
index f6a22f5..f8b3347 100644 (file)
@@ -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)
 
index 3e46274..601d45b 100644 (file)
@@ -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
index 949cbf1..3aaa1f3 100644 (file)
@@ -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
index 38dc6e3..9271eda 100644 (file)
@@ -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
index 5586abe..bb20b43 100644 (file)
@@ -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
     ]
index 4455c9b..006b01c 100644 (file)
@@ -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.
 
index 3d2a105..6c9b5a2 100644 (file)
@@ -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
index 56cc711..58c0e21 100644 (file)
@@ -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.
 
index 4e6097b..2502c6e 100644 (file)
@@ -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
index 51bd273..73398a8 100644 (file)
@@ -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
index 626a1e8..c518101 100644 (file)
@@ -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
index 6f9c3fa..4a56bbe 100644 (file)
@@ -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
 
 {-
index 6b693ef..967e6f7 100644 (file)
@@ -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
 
 
index 6c01c74..5a2431c 100644 (file)
@@ -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,
index 517358d..77fe5d8 100644 (file)
@@ -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.
index 056ce0d..492125b 100644 (file)
@@ -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
 
index 0985797..3677e51 100644 (file)
@@ -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
index f527684..a40e105 100644 (file)
@@ -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
 
index 90e9996..4e8c7ed 100644 (file)
@@ -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
index 49ceb89..8214f17 100644 (file)
@@ -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
index 6f58652..ede900a 100644 (file)
@@ -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
index faaad69..8f1a0a0 100644 (file)
@@ -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
index 98d9042..a1215fd 100644 (file)
@@ -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.
index 12a56ad..6b9591e 100644 (file)
@@ -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)