[Git][ghc/ghc][wip/T16806] Use Data.IntMap.disjoint
Simon Jakobi
gitlab at gitlab.haskell.org
Wed Apr 1 08:04:45 UTC 2020
Simon Jakobi pushed to branch wip/T16806 at Glasgow Haskell Compiler / GHC
Commits:
d2dd3c54 by Simon Jakobi at 2020-04-01T10:04:13+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.
- - - - -
20 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/Stg/Lift/Analysis.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/DSet.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Set.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/GHC/Types/Var/Set.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/Stg/Lift/Analysis.hs
=====================================
@@ -533,7 +533,7 @@ closureGrowth expander sizer group abs_ids = go
go (ClosureSk _ clo_fvs rhs)
-- If no binder of the @group@ occurs free in the closure, the lifting
-- won't have any effect on it and we can omit the recursive call.
- | n_occs == 0 = 0
+ | group `varSetDisjointDVarSet` clo_fvs' = 0
-- Otherwise, we account the cost of allocating the closure and add it to
-- the closure growth of its RHS.
| otherwise = mkIntWithInf cost + go rhs
=====================================
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, intersectsOccSet, disjointOccSet,
filterOccSet,
-- * Tidying up
@@ -452,6 +452,7 @@ minusOccSet :: OccSet -> OccSet -> OccSet
elemOccSet :: OccName -> OccSet -> Bool
isEmptyOccSet :: OccSet -> Bool
intersectOccSet :: OccSet -> OccSet -> OccSet
+disjointOccSet :: OccSet -> OccSet -> Bool
intersectsOccSet :: OccSet -> OccSet -> Bool
filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet
@@ -466,7 +467,8 @@ minusOccSet = minusUniqSet
elemOccSet = elementOfUniqSet
isEmptyOccSet = isEmptyUniqSet
intersectOccSet = intersectUniqSets
-intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))
+disjointOccSet = disjointUniqSets
+intersectsOccSet s1 s2 = not (s1 `disjointOccSet` 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
=====================================
@@ -319,13 +319,13 @@ udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i
-- 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)
+intersectsUDFM x y = not (x `disjointUDFM` 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/DSet.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Types.Unique.DSet (
unionUniqDSets, unionManyUniqDSets,
minusUniqDSet, uniqDSetMinusUniqSet,
intersectUniqDSets, uniqDSetIntersectUniqSet,
+ uniqDSetDisjointUniqSet,
foldUniqDSet,
elementOfUniqDSet,
filterUniqDSet,
@@ -98,6 +99,10 @@ uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a
uniqDSetIntersectUniqSet xs ys
= UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys))
+uniqDSetDisjointUniqSet :: UniqDSet a -> UniqSet b -> Bool
+uniqDSetDisjointUniqSet xs ys
+ = disjointUdfmUfm (getUniqDSet xs) (getUniqSet ys)
+
foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b
foldUniqDSet c n (UniqDSet s) = foldUDFM c n s
=====================================
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
=====================================
@@ -507,7 +507,7 @@ plusMaybeVarEnv_C = plusMaybeUFM_C
delVarEnvList = delListFromUFM
delVarEnv = delFromUFM
minusVarEnv = minusUFM
-intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))
+intersectsVarEnv e1 e2 = not (e1 `disjointUFM` e2)
plusVarEnv = plusUFM
plusVarEnvList = plusUFMList
lookupVarEnv = lookupUFM
=====================================
compiler/GHC/Types/Var/Set.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Types.Var.Set (
elemDVarSet, dVarSetElems, subDVarSet,
unionDVarSet, unionDVarSets, mapUnionDVarSet,
intersectDVarSet, dVarSetIntersectVarSet,
- intersectsDVarSet, disjointDVarSet,
+ intersectsDVarSet, disjointDVarSet, varSetDisjointDVarSet,
isEmptyDVarSet, delDVarSet, delDVarSetList,
minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet,
dVarSetMinusVarSet, anyDVarSet, allDVarSet,
@@ -274,6 +274,9 @@ dVarSetIntersectVarSet = uniqDSetIntersectUniqSet
disjointDVarSet :: DVarSet -> DVarSet -> Bool
disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2)
+varSetDisjointDVarSet :: VarSet -> DVarSet -> Bool
+varSetDisjointDVarSet vs dvs = uniqDSetDisjointUniqSet dvs vs
+
-- | True if non-empty intersection
intersectsDVarSet :: DVarSet -> DVarSet -> Bool
intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2)
=====================================
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/d2dd3c5479b0a060b35af0a480512cf1848df6cc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d2dd3c5479b0a060b35af0a480512cf1848df6cc
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/20200401/0fa6f2fa/attachment-0001.html>
More information about the ghc-commits
mailing list