[commit: ghc] master: Add uniqSetAny and uniqSetAll and use them (3c426b0)
git at git.haskell.org
git at git.haskell.org
Thu Apr 28 20:30:03 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/3c426b0552dffa82f1663f2eca19188afe247865/ghc
>---------------------------------------------------------------
commit 3c426b0552dffa82f1663f2eca19188afe247865
Author: Bartosz Nitka <niteria at gmail.com>
Date: Thu Apr 28 13:32:39 2016 -0700
Add uniqSetAny and uniqSetAll and use them
There are couple of places where we do `foldUniqSet` just to
compute `any` or `all`. `foldUniqSet` is non-deterministic in the
general case and `any` and `all` also read nicer.
Test Plan: ./validate
Reviewers: simonmar, goldfire, simonpj, bgamari, austin
Reviewed By: simonpj
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2156
GHC Trac Issues: #4012
>---------------------------------------------------------------
3c426b0552dffa82f1663f2eca19188afe247865
compiler/basicTypes/NameSet.hs | 7 +++++++
compiler/basicTypes/VarSet.hs | 7 +++++++
compiler/rename/RnSource.hs | 3 +--
compiler/specialise/Rules.hs | 2 +-
compiler/typecheck/TcBinds.hs | 2 +-
compiler/typecheck/TcErrors.hs | 2 +-
compiler/types/Unify.hs | 4 ++--
compiler/utils/UniqFM.hs | 10 +++++++++-
compiler/utils/UniqSet.hs | 8 +++++++-
9 files changed, 36 insertions(+), 9 deletions(-)
diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs
index 574c3a4..b332fe2 100644
--- a/compiler/basicTypes/NameSet.hs
+++ b/compiler/basicTypes/NameSet.hs
@@ -13,6 +13,7 @@ module NameSet (
minusNameSet, elemNameSet, nameSetElems, extendNameSet, extendNameSetList,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
intersectsNameSet, intersectNameSet,
+ nameSetAny, nameSetAll,
-- * Free variables
FreeVars,
@@ -85,6 +86,12 @@ delListFromNameSet set ns = foldl delFromNameSet set ns
intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
+nameSetAny :: (Name -> Bool) -> NameSet -> Bool
+nameSetAny = uniqSetAny
+
+nameSetAll :: (Name -> Bool) -> NameSet -> Bool
+nameSetAll = uniqSetAll
+
{-
************************************************************************
* *
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index f61bbbe..57369f3 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -17,6 +17,7 @@ module VarSet (
intersectVarSet, intersectsVarSet, disjointVarSet,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
+ varSetAny, varSetAll,
transCloVarSet, fixVarSet,
lookupVarSet, lookupVarSetByName,
mapVarSet, sizeVarSet, seqVarSet,
@@ -134,6 +135,12 @@ intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
disjointVarSet s1 s2 = disjointUFM s1 s2
subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)
+varSetAny :: (Var -> Bool) -> VarSet -> Bool
+varSetAny = uniqSetAny
+
+varSetAll :: (Var -> Bool) -> VarSet -> Bool
+varSetAll = uniqSetAll
+
fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set
-> VarSet -> VarSet
-- (fixVarSet f s) repeatedly applies f to the set s,
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index eb1494f..f92bae9 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1420,8 +1420,7 @@ addBootDeps ds_w_fvs
| otherwise = pr
has_local_imports fvs
- = foldNameSet ((||) . nameIsHomePackageImport this_mod)
- False fvs
+ = nameSetAny (nameIsHomePackageImport this_mod) fvs
; return (add_boot_deps ds_w_fvs) }
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index 3adad1c..f9f195f 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -855,7 +855,7 @@ match_alts _ _ _ _
------------------------------------------
okToFloat :: RnEnv2 -> VarSet -> Bool
okToFloat rn_env bind_fvs
- = foldVarSet ((&&) . not_captured) True bind_fvs
+ = varSetAll not_captured bind_fvs
where
not_captured fv = not (inRnEnvR rn_env fv)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index ac19061..aef80a8 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -1973,7 +1973,7 @@ isClosedBndrGroup binds = do
fvs _ = emptyNameSet
is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
- is_closed_ns type_env ns b = foldNameSet ((&&) . is_closed_id type_env) b ns
+ is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns
-- ns are the Names referred to from the RHS of this bind
is_closed_id :: TcTypeEnv -> Name -> Bool
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index b51a267..78320c4 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -2328,7 +2328,7 @@ pprPotentials dflags sty herald insts
-- are lexically in scope; these instances are likely
-- to be more useful
inst_in_scope :: ClsInst -> Bool
- inst_in_scope cls_inst = foldNameSet ((&&) . name_in_scope) True $
+ inst_in_scope cls_inst = nameSetAll name_in_scope $
orphNamesOfTypes (is_tys cls_inst)
name_in_scope name
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index dadb8e3..381f948 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -454,7 +454,7 @@ niFixTCvSubst tenv = f tenv
| not_fixpoint = f (mapVarEnv (substTy subst') tenv)
| otherwise = subst
where
- not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs
+ not_fixpoint = varSetAny in_domain range_tvs
in_domain tv = tv `elemVarEnv` tenv
range_tvs = foldVarEnv (unionVarSet . tyCoVarsOfType) emptyVarSet tenv
@@ -1140,7 +1140,7 @@ ty_co_match menv subst ty co lkco rkco
= noneSet (\v -> elemVarEnv v env) set
noneSet :: (Var -> Bool) -> VarSet -> Bool
- noneSet f = foldVarSet (\v rest -> rest && (not $ f v)) True
+ noneSet f = varSetAll (not . f)
ty_co_match menv subst ty co lkco rkco
| CastTy ty' co' <- ty
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 10cc179..ed82fee 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -56,7 +56,7 @@ module UniqFM (
intersectUFM,
intersectUFM_C,
disjointUFM,
- foldUFM, foldUFM_Directly,
+ foldUFM, foldUFM_Directly, anyUFM, allUFM,
mapUFM, mapUFM_Directly,
elemUFM, elemUFM_Directly,
filterUFM, filterUFM_Directly, partitionUFM,
@@ -275,6 +275,8 @@ intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)
foldUFM k z (UFM m) = M.fold k z m
+
+
foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
mapUFM f (UFM m) = UFM (M.map f m)
mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
@@ -298,6 +300,12 @@ eltsUFM (UFM m) = M.elems m
ufmToSet_Directly (UFM m) = M.keysSet m
ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
+anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+anyUFM p (UFM m) = M.fold ((||) . p) False m
+
+allUFM :: (elt -> Bool) -> UniqFM elt -> Bool
+allUFM p (UFM m) = M.fold ((&&) . p) True m
+
ufmToIntMap :: UniqFM elt -> M.IntMap elt
ufmToIntMap (UFM m) = m
diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs
index a3d503f..c1d19b3 100644
--- a/compiler/utils/UniqSet.hs
+++ b/compiler/utils/UniqSet.hs
@@ -22,7 +22,7 @@ module UniqSet (
unionUniqSets, unionManyUniqSets,
minusUniqSet,
intersectUniqSets,
- foldUniqSet,
+ foldUniqSet, uniqSetAny, uniqSetAll,
mapUniqSet,
elementOfUniqSet,
elemUniqSet_Directly,
@@ -113,3 +113,9 @@ sizeUniqSet = sizeUFM
isEmptyUniqSet = isNullUFM
lookupUniqSet = lookupUFM
uniqSetToList = eltsUFM
+
+uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool
+uniqSetAny = anyUFM
+
+uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool
+uniqSetAll = allUFM
More information about the ghc-commits
mailing list