diff options
author | David Feuer <david.feuer@gmail.com> | 2017-03-01 13:47:39 -0500 |
---|---|---|
committer | David Feuer <David.Feuer@gmail.com> | 2017-03-01 13:47:41 -0500 |
commit | cbe569a56e2a82bb93a008beb56869d9a6a1d047 (patch) | |
tree | 4143ecfabf7b171159c2980e545fe66e0118e1f0 | |
parent | 701256df88c61a2eee4cf00a59e61ef76a57b4b4 (diff) | |
download | haskell-cbe569a56e2a82bb93a008beb56869d9a6a1d047.tar.gz |
Upgrade UniqSet to a newtype
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, 321 insertions, 230 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 96c37727da..43bcf75bb4 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 0ab4ec0749..57de81cb44 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 23c6d6833d..3a4324b352 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 3177abb814..e22c207858 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 f6d82fdcd1..8877f64080 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 811d9083f3..dba8ca6e8c 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 511ffc1c9f..5997a9c4b6 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 043d3c3674..590d870946 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 2616e6f605..31fbd12979 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 f686b68947..c3be55504b 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 da29ac0e6a..8c4cf1205f 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 95d734ea5d..b40dd5cd89 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 b63c1c94b2..a5b791a151 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 27bb9e0021..7b1e3e21b4 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 1464531e72..424891fe77 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 c3df743454..5731f18234 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 e819fe8870..08538453f7 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 0704e53102..9a3808ad9a 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 03da772819..0811147eda 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 efa1cd11e2..0817b3941a 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 81e0c5e091..204de846ae 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 055129703b..b7721880c3 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 4b00ed6cd6..e387f82420 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 f6a22f5df2..f8b3347ca5 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 3e462744e1..601d45b90e 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 949cbf16e9..3aaa1f3d47 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 38dc6e333e..9271eda8c5 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 5586abe290..bb20b43892 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 4455c9bd6a..006b01ca92 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 3d2a1058ac..6c9b5a2b1c 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 56cc711195..58c0e21819 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 4e6097bd62..2502c6e865 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 51bd273f07..73398a8e76 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 626a1e8cfc..c518101638 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 6f9c3fafb1..4a56bbea7a 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 6b693ef97b..967e6f7268 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 6c01c741b0..5a2431c5a2 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 517358d482..77fe5d805f 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 056ce0daa4..492125b787 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 0985797571..3677e517b5 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 f5276842aa..a40e1058d0 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 90e9996d1a..4e8c7ed97f 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 49ceb89d90..8214f1704b 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 6f58652f80..ede900a842 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 faaad69ba7..8f1a0a0662 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 98d9042482..a1215fd8c0 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 12a56add85..6b9591e6a1 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) |