From 118a779c6e4cbc64a3381a3de1db249b070ed2b9 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Thu, 28 Nov 2019 16:01:51 +0100 Subject: 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. --- compiler/GHC/Core/Opt/Specialise.hs | 6 +++--- compiler/GHC/Core/TyCo/Subst.hs | 4 ++-- compiler/GHC/Core/Type.hs | 2 +- compiler/GHC/Rename/Expr.hs | 6 +++--- compiler/GHC/Tc/Errors/Hole.hs | 3 +-- compiler/GHC/Tc/Solver.hs | 2 +- compiler/GHC/Tc/TyCl/Build.hs | 3 +-- compiler/GHC/Types/Name/Env.hs | 2 +- compiler/GHC/Types/Name/Occurrence.hs | 4 +--- compiler/GHC/Types/Name/Set.hs | 6 ++++-- compiler/GHC/Types/Unique/DFM.hs | 8 ++------ compiler/GHC/Types/Unique/FM.hs | 2 +- compiler/GHC/Types/Unique/Set.hs | 4 ++++ compiler/GHC/Types/Var/Env.hs | 4 +--- compiler/ghc.cabal.in | 2 +- hadrian/src/Rules/Documentation.hs | 5 ++--- 16 files changed, 29 insertions(+), 34 deletions(-) diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 09af3d9d2d..ee48e9870c 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1141,7 +1141,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 @@ -2745,7 +2745,7 @@ filterCalls (CIS fn call_bag) dbs = extendVarSetList so_far (bindersOf bind) | 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) @@ -2776,7 +2776,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 diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index ed885bfdfd..0c8f77dfd8 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/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) diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index fe6d721a05..0359f31cbe 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -2115,7 +2115,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 diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 6ec473134d..101926c7f7 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -1335,7 +1335,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 @@ -1889,7 +1889,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 xbs pat body), fvs): rest) - | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) + | disjointNameSet bndrs fvs && not (isStrictPattern pat) = go lets ((L loc (BindStmt xbs pat body), fvs) : indep) bndrs' rest where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) @@ -1899,7 +1899,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 diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 7cbd8dbc0b..c764d7d3e3 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -648,8 +648,7 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ 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 diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 40266c3319..49f5c67e80 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -2411,7 +2411,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 diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index fa0c196504..cf490075af 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.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 ------------------------------------------------------ diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs index 500c58043d..daa6e20fae 100644 --- a/compiler/GHC/Types/Name/Env.hs +++ b/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) diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index d7f7cc8c9d..6a9967415e 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/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 @@ -449,7 +449,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 @@ -463,7 +462,6 @@ minusOccSet = minusUniqSet elemOccSet = elementOfUniqSet isEmptyOccSet = isEmptyUniqSet intersectOccSet = intersectUniqSets -intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) filterOccSet = filterUniqSet {- diff --git a/compiler/GHC/Types/Name/Set.hs b/compiler/GHC/Types/Name/Set.hs index c011bcbf23..be5bdeb297 100644 --- a/compiler/GHC/Types/Name/Set.hs +++ b/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 diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs index 8d79626c19..8f4d498064 100644 --- a/compiler/GHC/Types/Unique/DFM.hs +++ b/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 diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 4dedf468da..4fb4f80653 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/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 diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs index 24f8a40e9b..e752c237ec 100644 --- a/compiler/GHC/Types/Unique/Set.hs +++ b/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) diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index aea3982226..470644878d 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/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, - minusVarEnv, intersectsVarEnv, + minusVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, @@ -472,7 +472,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 @@ -502,7 +501,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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 166163f57b..c4cedb2c18 100644 --- a/compiler/ghc.cabal.in +++ b/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.17.*, diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs index 8d90357312..a673e2e074 100644 --- a/hadrian/src/Rules/Documentation.hs +++ b/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. -- cgit v1.2.1