[Git][ghc/ghc][wip/T16806] Use Data.IntMap.disjoint
Simon Jakobi
gitlab at gitlab.haskell.org
Tue Apr 7 14:59:40 UTC 2020
Simon Jakobi pushed to branch wip/T16806 at Glasgow Haskell Compiler / GHC
Commits:
e102273d by Simon Jakobi at 2020-04-07T16:59:28+02:00
Use Data.IntMap.disjoint
Data.IntMap gained a dedicated `disjoint` function in containers-0.6.2.1.
This patch applies this function where appropriate in hopes of modest
compiler performance improvements.
Closes #16806.
- - - - -
17 changed files:
- compiler/GHC/Core/Op/Specialise.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Types/Module.hs
- compiler/GHC/Types/Name/Env.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Types/Name/Set.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Set.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/ghc.cabal.in
- compiler/iface/BuildTyCl.hs
- compiler/typecheck/TcHoleErrors.hs
- compiler/typecheck/TcSimplify.hs
- hadrian/src/Rules/Documentation.hs
Changes:
=====================================
compiler/GHC/Core/Op/Specialise.hs
=====================================
@@ -1173,7 +1173,7 @@ specCase env scrut' case_bndr [(con, args, rhs)]
is_flt_sc_arg var = isId var
&& not (isDeadBinder var)
&& isDictTy var_ty
- && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)
+ && tyCoVarsOfType var_ty `disjointVarSet` arg_set
where
var_ty = idType var
@@ -2489,7 +2489,7 @@ filterCalls (CIS fn call_bag) dbs
= extendVarSetList so_far (bindersOf db)
| otherwise = so_far
- ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)
+ ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set
----------------------
splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
@@ -2519,7 +2519,7 @@ deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
deleteCallsMentioning bs calls
= mapDVarEnv (ciSetFilter keep_call) calls
where
- keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)
+ keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
-- Remove calls *for* bs
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -383,8 +383,8 @@ extendTCvSubstList subst tvs tys
unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst
-- Works when the ranges are disjoint
unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)
- = ASSERT( not (tenv1 `intersectsVarEnv` tenv2)
- && not (cenv1 `intersectsVarEnv` cenv2) )
+ = ASSERT( tenv1 `disjointVarEnv` tenv2
+ && cenv1 `disjointVarEnv` cenv2 )
TCvSubst (in_scope1 `unionInScope` in_scope2)
(tenv1 `plusVarEnv` tenv2)
(cenv1 `plusVarEnv` cenv2)
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2112,7 +2112,7 @@ isValidJoinPointType arity ty
where
valid_under tvs arity ty
| arity == 0
- = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty)
+ = tvs `disjointVarSet` tyCoVarsOfType ty
| Just (t, ty') <- splitForAllTy_maybe ty
= valid_under (tvs `extendVarSet` t) (arity-1) ty'
| Just (_, res_ty) <- splitFunTy_maybe ty
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1350,7 +1350,7 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
= (reverse yeses, reverse noes)
where
(noes, yeses) = span not_needed (reverse dus)
- not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
+ not_needed (defs,_,_,_) = disjointNameSet defs uses
----------------------------------------------------
segsToStmts :: Stmt GhcRn body
@@ -1908,7 +1908,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- then we have actually done some splitting. Otherwise it will go into
-- an infinite loop (#14163).
go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
- | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
+ | disjointNameSet bndrs fvs && not (isStrictPattern pat)
= go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep)
bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
@@ -1918,7 +1918,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- TODO: perhaps we shouldn't do this if there are any strict bindings,
-- because we might be moving evaluation earlier.
go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)
- | isEmptyNameSet (bndrs `intersectNameSet` fvs)
+ | disjointNameSet bndrs fvs
= go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest
go _ [] _ _ = Nothing
go _ [_] _ _ = Nothing
=====================================
compiler/GHC/Types/Module.hs
=====================================
@@ -991,7 +991,7 @@ renameHoleUnitId' pkg_map env uid =
IndefUnitId{ indefUnitIdComponentId = cid
, indefUnitIdInsts = insts
, indefUnitIdFreeHoles = fh })
- -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)
+ -> if disjointUdfmUfm (getUniqDSet fh) env
then uid
-- Functorially apply the substitution to the instantiation,
-- then check the 'UnitInfoMap' to see if there is
=====================================
compiler/GHC/Types/Name/Env.hs
=====================================
@@ -140,7 +140,7 @@ delFromNameEnv x y = delFromUFM x y
delListFromNameEnv x y = delListFromUFM x y
filterNameEnv x y = filterUFM x y
anyNameEnv f x = foldUFM ((||) . f) False x
-disjointNameEnv x y = isNullUFM (intersectUFM x y)
+disjointNameEnv x y = disjointUFM x y
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)
=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -90,7 +90,7 @@ module GHC.Types.Name.Occurrence (
OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,
extendOccSetList,
unionOccSets, unionManyOccSets, minusOccSet, elemOccSet,
- isEmptyOccSet, intersectOccSet, intersectsOccSet,
+ isEmptyOccSet, intersectOccSet,
filterOccSet,
-- * Tidying up
@@ -452,7 +452,6 @@ minusOccSet :: OccSet -> OccSet -> OccSet
elemOccSet :: OccName -> OccSet -> Bool
isEmptyOccSet :: OccSet -> Bool
intersectOccSet :: OccSet -> OccSet -> OccSet
-intersectsOccSet :: OccSet -> OccSet -> Bool
filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet
emptyOccSet = emptyUniqSet
@@ -466,7 +465,6 @@ minusOccSet = minusUniqSet
elemOccSet = elementOfUniqSet
isEmptyOccSet = isEmptyUniqSet
intersectOccSet = intersectUniqSets
-intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))
filterOccSet = filterUniqSet
{-
=====================================
compiler/GHC/Types/Name/Set.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Types.Name.Set (
emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets,
minusNameSet, elemNameSet, extendNameSet, extendNameSetList,
delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet,
- intersectsNameSet, intersectNameSet,
+ intersectsNameSet, disjointNameSet, intersectNameSet,
nameSetAny, nameSetAll, nameSetElemsStable,
-- * Free variables
@@ -65,6 +65,7 @@ delListFromNameSet :: NameSet -> [Name] -> NameSet
filterNameSet :: (Name -> Bool) -> NameSet -> NameSet
intersectNameSet :: NameSet -> NameSet -> NameSet
intersectsNameSet :: NameSet -> NameSet -> Bool
+disjointNameSet :: NameSet -> NameSet -> Bool
-- ^ True if there is a non-empty intersection.
-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty
@@ -81,10 +82,11 @@ elemNameSet = elementOfUniqSet
delFromNameSet = delOneFromUniqSet
filterNameSet = filterUniqSet
intersectNameSet = intersectUniqSets
+disjointNameSet = disjointUniqSets
delListFromNameSet set ns = foldl' delFromNameSet set ns
-intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
+intersectsNameSet s1 s2 = not (s1 `disjointNameSet` s2)
nameSetAny :: (Name -> Bool) -> NameSet -> Bool
nameSetAny = uniqSetAny
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -45,7 +45,6 @@ module GHC.Types.Unique.DFM (
isNullUDFM,
sizeUDFM,
intersectUDFM, udfmIntersectUFM,
- intersectsUDFM,
disjointUDFM, disjointUdfmUfm,
equalKeysUDFM,
minusUDFM,
@@ -318,14 +317,11 @@ udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i
-- M.intersection is left biased, that means the result will only have
-- a subset of elements from the left set, so `i` is a good upper bound.
-intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool
-intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y)
-
disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool
-disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y)
+disjointUDFM (UDFM x _i) (UDFM y _j) = M.disjoint x y
disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool
-disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y))
+disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToIntMap y)
minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1
minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -241,7 +241,7 @@ intersectUFM_C
intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
-disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y)
+disjointUFM (UFM x) (UFM y) = M.disjoint x y
foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
foldUFM k z (UFM m) = M.foldr k z m
=====================================
compiler/GHC/Types/Unique/Set.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Types.Unique.Set (
unionUniqSets, unionManyUniqSets,
minusUniqSet, uniqSetMinusUFM,
intersectUniqSets,
+ disjointUniqSets,
restrictUniqSetToUFM,
uniqSetAny, uniqSetAll,
elementOfUniqSet,
@@ -105,6 +106,9 @@ minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t)
intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t)
+disjointUniqSets :: UniqSet a -> UniqSet a -> Bool
+disjointUniqSets (UniqSet s) (UniqSet t) = disjointUFM s t
+
restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a
restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.Types.Var.Env (
plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C,
plusVarEnvList, alterVarEnv,
delVarEnvList, delVarEnv, delVarEnv_Directly,
- minusVarEnv, intersectsVarEnv,
+ minusVarEnv,
lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
@@ -476,7 +476,6 @@ restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a
delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a
-intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool
plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a
@@ -507,7 +506,6 @@ plusMaybeVarEnv_C = plusMaybeUFM_C
delVarEnvList = delListFromUFM
delVarEnv = delFromUFM
minusVarEnv = minusUFM
-intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))
plusVarEnv = plusUFM
plusVarEnvList = plusUFMList
lookupVarEnv = lookupUFM
=====================================
compiler/ghc.cabal.in
=====================================
@@ -66,7 +66,7 @@ Library
bytestring >= 0.9 && < 0.11,
binary == 0.8.*,
time >= 1.4 && < 1.10,
- containers >= 0.5 && < 0.7,
+ containers >= 0.6.2.1 && < 0.7,
array >= 0.1 && < 0.6,
filepath >= 1 && < 1.5,
template-haskell == 2.16.*,
=====================================
compiler/iface/BuildTyCl.hs
=====================================
@@ -164,8 +164,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
-- stupid theta, taken from the TyCon
arg_tyvars = tyCoVarsOfTypes arg_tys
- in_arg_tys pred = not $ isEmptyVarSet $
- tyCoVarsOfType pred `intersectVarSet` arg_tyvars
+ in_arg_tys pred = tyCoVarsOfType pred `intersectsVarSet` arg_tyvars
------------------------------------------------------
=====================================
compiler/typecheck/TcHoleErrors.hs
=====================================
@@ -674,8 +674,7 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred
hole_fv_set = fvVarSet hole_fvs
anyFVMentioned :: Ct -> Bool
- anyFVMentioned ct = not $ isEmptyVarSet $
- ctFreeVarSet ct `intersectVarSet` hole_fv_set
+ anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set
-- We filter out those constraints that have no variables (since
-- they won't be solved by finding a type for the type variable
-- representing the hole) and also other holes, since we're not
=====================================
compiler/typecheck/TcSimplify.hs
=====================================
@@ -2415,7 +2415,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
is_floatable :: VarSet -> Ct -> Bool
is_floatable skols ct
- | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols)
+ | isDerivedCt ct = tyCoVarsOfCt ct `disjointVarSet` skols
| otherwise = not (ctEvId ct `elemVarSet` skols)
add_captured_ev_ids :: Cts -> VarSet -> VarSet
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -103,9 +103,8 @@ documentationRules = do
-- include toplevel html target unless we neither want
-- haddocks nor html pages produced by sphinx.
- ++ [ html | Set.size (doctargets `Set.intersection`
- Set.fromList [Haddocks, SphinxHTML]
- ) > 0 ]
+ ++ [ html | Haddocks `Set.member` doctargets
+ || SphinxHTML `Set.member` doctargets ]
-- include archives for whatever targets remain from
-- the --docs arguments we got.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e102273dd00d25453270e9d81df57047b1f9183f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e102273dd00d25453270e9d81df57047b1f9183f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200407/acccf3d0/attachment-0001.html>
More information about the ghc-commits
mailing list