[Git][ghc/ghc][wip/sjakobi/nondetfolds] Improve some folds over Uniq[D]FM
Simon Jakobi
gitlab at gitlab.haskell.org
Thu Apr 2 17:15:27 UTC 2020
Simon Jakobi pushed to branch wip/sjakobi/nondetfolds at Glasgow Haskell Compiler / GHC
Commits:
5006a7e1 by Simon Jakobi at 2020-04-02T19:15:05+02:00
Improve some folds over Uniq[D]FM
* Replace some non-deterministic lazy folds with
strict folds.
* Replace some O(n log n) folds in deterministic order
with O(n) non-deterministic folds.
* Replace some folds with set-operations on the underlying
IntMaps.
This reduces max residency when compiling
`nofib/spectral/simple/Main.hs` with -O0 by about 1%.
Maximum residency when compiling Cabal also seems reduced on the
order of 3-9%.
- - - - -
21 changed files:
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/Op/OccurAnal.hs
- compiler/GHC/Core/Op/SetLevels.hs
- compiler/GHC/Core/Op/Specialise.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Rename/Source.hs
- compiler/GHC/Stg/Lift/Analysis.hs
- compiler/GHC/Types/Demand.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/typecheck/TcEvidence.hs
- compiler/typecheck/TcSimplify.hs
- compiler/typecheck/TcType.hs
- compiler/utils/GraphOps.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
=====================================
@@ -554,8 +554,9 @@ delAssoc :: (Uniquable a)
delAssoc a m
| Just aSet <- lookupUFM m a
, m1 <- delFromUFM m a
- = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
- -- It's OK to use nonDetFoldUFM here because deletion is commutative
+ = nonDetStrictFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
+ -- It's OK to use a non-deterministic fold here because deletion is
+ -- commutative
| otherwise = m
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -380,8 +380,8 @@ famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts]
-- See Note [FamInstEnv determinism]
famInstEnvSize :: FamInstEnv -> Int
-famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0
- -- It's OK to use nonDetFoldUDFM here since we're just computing the
+famInstEnvSize = nonDetStrictFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0
+ -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the
-- size.
familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
=====================================
compiler/GHC/Core/Op/OccurAnal.hs
=====================================
@@ -2243,8 +2243,8 @@ extendFvs env s
= (s `unionVarSet` extras, extras `subVarSet` s)
where
extras :: VarSet -- env(s)
- extras = nonDetFoldUFM unionVarSet emptyVarSet $
- -- It's OK to use nonDetFoldUFM here because unionVarSet commutes
+ extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $
+ -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes
intersectUFM_C (\x _ -> x) env (getUniqSet s)
{-
@@ -2565,8 +2565,8 @@ addManyOcc v u | isId v = addManyOccId u v
-- (Same goes for INLINE.)
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
-addManyOccs usage id_set = nonDetFoldUniqSet addManyOcc usage id_set
- -- It's OK to use nonDetFoldUFM here because addManyOcc commutes
+addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set
+ -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes
delDetails :: UsageDetails -> Id -> UsageDetails
delDetails ud bndr
=====================================
compiler/GHC/Core/Op/SetLevels.hs
=====================================
@@ -83,7 +83,7 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var
import GHC.Types.Var.Set
-import GHC.Types.Unique.Set ( nonDetFoldUniqSet )
+import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet )
import GHC.Types.Unique.DSet ( getUniqDSet )
import GHC.Types.Var.Env
import GHC.Types.Literal ( litIsTrivial )
@@ -1469,8 +1469,8 @@ isFunction (_, AnnLam b e) | isId b = True
isFunction _ = False
countFreeIds :: DVarSet -> Int
-countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet
- -- It's OK to use nonDetFoldUDFM here because we're just counting things.
+countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet
+ -- It's OK to use nonDetStrictFoldUDFM here because we're just counting things.
where
add :: Var -> Int -> Int
add v n | isId v = n+1
@@ -1581,12 +1581,14 @@ placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
maxFvLevel max_me env var_set
- = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set
+ = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set
+ -- It's OK to use a non-deterministic fold here because maxIn commutes.
maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
-- Same but for TyCoVarSet
maxFvLevel' max_me env var_set
- = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
+ = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
+ -- It's OK to use a non-deterministic fold here because maxIn commutes.
maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
=====================================
compiler/GHC/Core/Op/Specialise.hs
=====================================
@@ -2177,8 +2177,8 @@ unionCallInfoSet (CIS f calls1) (CIS _ calls2) =
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs calls =
- nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls
- -- It's OK to use nonDetFoldUDFM here because we forget the ordering
+ nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls
+ -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering
-- immediately by converting to a nondeterministic set.
callInfoFVs :: CallInfoSet -> VarSet
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -441,7 +441,7 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView
closeOverKinds :: TyCoVarSet -> TyCoVarSet
-- For each element of the input set,
-- add the deep free variables of its kind
-closeOverKinds vs = nonDetFoldVarSet do_one vs vs
+closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs
where
do_one v acc = appEndo (deep_ty (varType v)) acc
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -658,9 +658,9 @@ 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
- = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs
- -- It's OK to nonDetFoldUFM here because we immediately forget the
- -- ordering by creating a set.
+ = nonDetStrictFoldUniqSet (unionVarSet . get) emptyVarSet tvs
+ -- It's OK to use a non-deterministic fold here because we immediately forget
+ -- the ordering by creating a set.
where
get tv
| Just ty <- lookupVarEnv tsubst tv
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -260,9 +260,9 @@ 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 = nonDetFoldUniqSet add_mv emptyModuleEnv used_names
- -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName
- -- in ent_hashs
+ ent_map = nonDetStrictFoldUniqSet add_mv emptyModuleEnv used_names
+ -- nonDetStrictFoldUniqSet is OK here. If you follow the logic, we sort by
+ -- OccName in ent_hashs
where
add_mv name mv_map
| isWiredInName name = mv_map -- ignore wired-in names
=====================================
compiler/GHC/Rename/Source.hs
=====================================
@@ -1422,8 +1422,8 @@ depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents rdr_env ns
- = nonDetFoldUniqSet add emptyNameSet ns
- -- It's OK to use nonDetFoldUFM because we immediately forget the
+ = nonDetStrictFoldUniqSet add emptyNameSet ns
+ -- It's OK to use a non-deterministic fold because we immediately forget the
-- ordering by creating a set
where
add n s = extendNameSet s (getParent rdr_env n)
=====================================
compiler/GHC/Stg/Lift/Analysis.hs
=====================================
@@ -545,7 +545,8 @@ closureGrowth expander sizer group abs_ids = go
-- we lift @f@
newbies = abs_ids `minusDVarSet` clo_fvs'
-- Lifting @f@ removes @f@ from the closure but adds all @newbies@
- cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs
+ cost = nonDetStrictFoldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs
+ -- Using a non-deterministic fold is OK here because addition is commutative.
go (RhsSk body_dmd body)
-- The conservative assumption would be that
-- 1. Every RHS with positive growth would be called multiple times,
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -785,16 +785,23 @@ cleanUseDmd_maybe _ = Nothing
splitFVs :: Bool -- Thunk
-> DmdEnv -> (DmdEnv, DmdEnv)
splitFVs is_thunk rhs_fvs
- | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
- -- It's OK to use nonDetFoldUFM_Directly because we
+ | is_thunk = strictPairToTuple $
+ nonDetStrictFoldUFM_Directly add (emptyVarEnv :*: emptyVarEnv) rhs_fvs
+ -- It's OK to use a non-deterministic fold because we
-- immediately forget the ordering by putting the elements
-- in the envs again
| otherwise = partitionVarEnv isWeakDmd rhs_fvs
where
- add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)
- | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)
- | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })
- , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) )
+ add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv :*: sig_fv)
+ | Lazy <- s = addToUFM_Directly lazy_fv uniq dmd :*: sig_fv
+ | otherwise = addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })
+ :*:
+ addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs })
+
+data StrictPair a b = !a :*: !b
+
+strictPairToTuple :: StrictPair a b -> (a, b)
+strictPairToTuple (x :*: y) = (x, y)
data TypeShape = TsFun TypeShape
| TsProd [TypeShape]
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -50,14 +50,14 @@ module GHC.Types.Unique.DFM (
equalKeysUDFM,
minusUDFM,
listToUDFM,
- udfmMinusUFM,
+ udfmMinusUFM, ufmMinusUDFM,
partitionUDFM,
anyUDFM, allUDFM,
pprUniqDFM, pprUDFM,
udfmToList,
udfmToUfm,
- nonDetFoldUDFM,
+ nonDetStrictFoldUDFM,
alwaysUnsafeUfmToUdfm,
) where
@@ -72,7 +72,7 @@ import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
import qualified Data.Semigroup as Semi
-import GHC.Types.Unique.FM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)
+import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
-- Note [Deterministic UniqFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -272,12 +272,14 @@ elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
foldUDFM k z m = foldr k z (eltsUDFM m)
--- | Performs a nondeterministic fold over the UniqDFM.
+-- | Performs a nondeterministic strict fold over the UniqDFM.
-- It's O(n), same as the corresponding function on `UniqFM`.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
-nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m
+nonDetStrictFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
+nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m
+ where
+ k' acc (TaggedVal v _) = k v acc
eltsUDFM :: UniqDFM elt -> [elt]
eltsUDFM (UDFM m _i) =
@@ -337,6 +339,9 @@ udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i
-- M.difference returns a subset of a left set, so `i` is a good upper
-- bound.
+ufmMinusUDFM :: UniqFM elt1 -> UniqDFM elt2 -> UniqFM elt1
+ufmMinusUDFM x (UDFM y _i) = unsafeIntMapToUFM (M.difference (ufmToIntMap x) y)
+
-- | Partition UniqDFM into two UniqDFMs according to the predicate
partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt)
partitionUDFM p (UDFM m i) =
@@ -349,8 +354,7 @@ delListFromUDFM = foldl' delFromUDFM
-- | This allows for lossy conversion from UniqDFM to UniqFM
udfmToUfm :: UniqDFM elt -> UniqFM elt
-udfmToUfm (UDFM m _i) =
- listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m]
+udfmToUfm (UDFM m _i) = unsafeIntMapToUFM (M.map taggedFst m)
listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt
listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM
=====================================
compiler/GHC/Types/Unique/DSet.hs
=====================================
@@ -26,7 +26,7 @@ module GHC.Types.Unique.DSet (
unionUniqDSets, unionManyUniqDSets,
minusUniqDSet, uniqDSetMinusUniqSet,
intersectUniqDSets, uniqDSetIntersectUniqSet,
- foldUniqDSet,
+ nonDetStrictFoldUniqDSet,
elementOfUniqDSet,
filterUniqDSet,
sizeUniqDSet,
@@ -98,8 +98,11 @@ uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a
uniqDSetIntersectUniqSet xs ys
= UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys))
-foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b
-foldUniqDSet c n (UniqDSet s) = foldUDFM c n s
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetStrictFoldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b
+nonDetStrictFoldUniqDSet f acc (UniqDSet s) = nonDetStrictFoldUDFM f acc s
elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool
elementOfUniqDSet k = elemUDFM k . getUniqDSet
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -56,7 +56,7 @@ module GHC.Types.Unique.FM (
intersectUFM_C,
disjointUFM,
equalKeysUFM,
- nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly,
+ nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_Directly,
anyUFM, allUFM, seqEltsUFM,
mapUFM, mapUFM_Directly,
elemUFM, elemUFM_Directly,
@@ -67,7 +67,7 @@ module GHC.Types.Unique.FM (
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
nonDetEltsUFM, eltsUFM, nonDetKeysUFM,
ufmToSet_Directly,
- nonDetUFMToList, ufmToIntMap,
+ nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM,
pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM
) where
@@ -318,14 +318,14 @@ nonDetKeysUFM (UFM m) = map getUnique $ M.keys m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
-nonDetFoldUFM k z (UFM m) = M.foldr k z m
+nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
+nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
-nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m
+nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
@@ -359,6 +359,9 @@ instance Traversable NonDetUniqFM where
ufmToIntMap :: UniqFM elt -> M.IntMap elt
ufmToIntMap (UFM m) = m
+unsafeIntMapToUFM :: M.IntMap elt -> UniqFM elt
+unsafeIntMapToUFM = UFM
+
-- Determines whether two 'UniqFM's contain the same keys.
equalKeysUFM :: UniqFM a -> UniqFM b -> Bool
equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2
=====================================
compiler/GHC/Types/Unique/Set.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Types.Unique.Set (
delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,
delListFromUniqSet_Directly,
unionUniqSets, unionManyUniqSets,
- minusUniqSet, uniqSetMinusUFM,
+ minusUniqSet, uniqSetMinusUFM, uniqSetMinusUDFM,
intersectUniqSets,
restrictUniqSetToUFM,
uniqSetAny, uniqSetAll,
@@ -42,12 +42,12 @@ module GHC.Types.Unique.Set (
unsafeUFMToUniqSet,
nonDetEltsUniqSet,
nonDetKeysUniqSet,
- nonDetFoldUniqSet,
- nonDetFoldUniqSet_Directly
+ nonDetStrictFoldUniqSet,
) where
import GhcPrelude
+import GHC.Types.Unique.DFM
import GHC.Types.Unique.FM
import GHC.Types.Unique
import Data.Coerce
@@ -111,6 +111,9 @@ restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m)
uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a
uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t)
+uniqSetMinusUDFM :: UniqSet a -> UniqDFM b -> UniqSet a
+uniqSetMinusUDFM (UniqSet s) t = UniqSet (ufmMinusUDFM s t)
+
elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet a (UniqSet s) = elemUFM a s
@@ -159,14 +162,8 @@ nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet'
-- 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
-nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s
-
--- 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
-nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s
+nonDetStrictFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a
+nonDetStrictFoldUniqSet c n (UniqSet s) = nonDetStrictFoldUFM c n s
-- See Note [UniqSet invariant]
mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -33,7 +33,7 @@ module GHC.Types.Var.Env (
extendDVarEnv, extendDVarEnv_C,
extendDVarEnvList,
lookupDVarEnv, elemDVarEnv,
- isEmptyDVarEnv, foldDVarEnv,
+ isEmptyDVarEnv, foldDVarEnv, nonDetStrictFoldDVarEnv,
mapDVarEnv, filterDVarEnv,
modifyDVarEnv,
alterDVarEnv,
@@ -583,6 +583,12 @@ lookupDVarEnv = lookupUDFM
foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b
foldDVarEnv = foldUDFM
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetStrictFoldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b
+nonDetStrictFoldDVarEnv = nonDetStrictFoldUDFM
+
mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b
mapDVarEnv = mapUDFM
=====================================
compiler/GHC/Types/Var/Set.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Types.Var.Set (
sizeVarSet, seqVarSet,
elemVarSetByKey, partitionVarSet,
pluralVarSet, pprVarSet,
- nonDetFoldVarSet,
+ nonDetStrictFoldVarSet,
-- * Deterministic Var set types
DVarSet, DIdSet, DTyVarSet, DTyCoVarSet,
@@ -36,7 +36,9 @@ module GHC.Types.Var.Set (
intersectDVarSet, dVarSetIntersectVarSet,
intersectsDVarSet, disjointDVarSet,
isEmptyDVarSet, delDVarSet, delDVarSetList,
- minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet,
+ minusDVarSet,
+ nonDetStrictFoldDVarSet,
+ filterDVarSet, mapDVarSet,
dVarSetMinusVarSet, anyDVarSet, allDVarSet,
transCloDVarSet,
sizeDVarSet, seqDVarSet,
@@ -152,8 +154,11 @@ allVarSet = uniqSetAll
mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
mapVarSet = mapUniqSet
-nonDetFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a
-nonDetFoldVarSet = nonDetFoldUniqSet
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetStrictFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a
+nonDetStrictFoldVarSet = nonDetStrictFoldUniqSet
fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set
-> VarSet -> VarSet
@@ -290,8 +295,11 @@ minusDVarSet = minusUniqDSet
dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet
dVarSetMinusVarSet = uniqDSetMinusUniqSet
-foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a
-foldDVarSet = foldUniqDSet
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetStrictFoldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a
+nonDetStrictFoldDVarSet = nonDetStrictFoldUniqDSet
anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool
anyDVarSet p = anyUDFM p . getUniqDSet
=====================================
compiler/typecheck/TcEvidence.hs
=====================================
@@ -15,8 +15,12 @@ module TcEvidence (
-- * Evidence bindings
TcEvBinds(..), EvBindsVar(..),
EvBindMap(..), emptyEvBindMap, extendEvBinds,
- lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
+ lookupEvBind, evBindMapBinds,
+ foldEvBindMap, nonDetStrictFoldEvBindMap,
+ filterEvBindMap,
isEmptyEvBindMap,
+ evBindMapToVarSet,
+ varSetMinusEvBindMap,
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
evBindVar, isCoEvBindsVar,
@@ -55,6 +59,8 @@ module TcEvidence (
import GhcPrelude
+import GHC.Types.Unique.DFM
+import GHC.Types.Unique.FM
import GHC.Types.Var
import GHC.Core.Coercion.Axiom
import GHC.Core.Coercion
@@ -496,10 +502,22 @@ evBindMapBinds = foldEvBindMap consBag emptyBag
foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a
foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs)
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+nonDetStrictFoldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a
+nonDetStrictFoldEvBindMap k z bs = nonDetStrictFoldDVarEnv k z (ev_bind_varenv bs)
+
filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap
filterEvBindMap k (EvBindMap { ev_bind_varenv = env })
= EvBindMap { ev_bind_varenv = filterDVarEnv k env }
+evBindMapToVarSet :: EvBindMap -> VarSet
+evBindMapToVarSet (EvBindMap dve) = unsafeUFMToUniqSet (mapUFM evBindVar (udfmToUfm dve))
+
+varSetMinusEvBindMap :: VarSet -> EvBindMap -> VarSet
+varSetMinusEvBindMap vs (EvBindMap dve) = vs `uniqSetMinusUDFM` dve
+
instance Outputable EvBindMap where
ppr (EvBindMap m) = ppr m
@@ -851,8 +869,8 @@ findNeededEvVars ev_binds seeds
= transCloVarSet also_needs seeds
where
also_needs :: VarSet -> VarSet
- also_needs needs = nonDetFoldUniqSet add emptyVarSet needs
- -- It's OK to use nonDetFoldUFM here because we immediately
+ also_needs needs = nonDetStrictFoldUniqSet add emptyVarSet needs
+ -- It's OK to use a non-deterministic fold here because we immediately
-- forget about the ordering by creating a set
add :: Var -> VarSet -> VarSet
=====================================
compiler/typecheck/TcSimplify.hs
=====================================
@@ -1862,11 +1862,13 @@ neededEvVars implic@(Implic { ic_given = givens
; tcvs <- TcS.getTcEvTyCoVars ev_binds_var
; let seeds1 = foldr add_implic_seeds old_needs implics
- seeds2 = foldEvBindMap add_wanted seeds1 ev_binds
+ seeds2 = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds
+ -- It's OK to use a non-deterministic fold here
+ -- because add_wanted is commutative
seeds3 = seeds2 `unionVarSet` tcvs
need_inner = findNeededEvVars ev_binds seeds3
live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds
- need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds
+ need_outer = varSetMinusEvBindMap need_inner live_ev_binds
`delVarSetList` givens
; TcS.setTcEvBindsMap ev_binds_var live_ev_binds
@@ -1890,9 +1892,6 @@ neededEvVars implic@(Implic { ic_given = givens
| is_given = ev_var `elemVarSet` needed
| otherwise = True -- Keep all wanted bindings
- del_ev_bndr :: EvBind -> VarSet -> VarSet
- del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v
-
add_wanted :: EvBind -> VarSet -> VarSet
add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs
| is_given = needs -- Add the rhs vars of the Wanted bindings only
@@ -2381,7 +2380,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
seed_skols = mkVarSet skols `unionVarSet`
mkVarSet given_ids `unionVarSet`
foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
- foldEvBindMap add_one_bind emptyVarSet binds
+ evBindMapToVarSet binds
-- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
-- Include the EvIds of any non-floating constraints
@@ -2406,9 +2405,6 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) }
where
- add_one_bind :: EvBind -> VarSet -> VarSet
- add_one_bind bind acc = extendVarSet acc (evBindVar bind)
-
add_non_flt_ct :: Ct -> VarSet -> VarSet
add_non_flt_ct ct acc | isDerivedCt ct = acc
| otherwise = extendVarSet acc (ctEvId ct)
=====================================
compiler/typecheck/TcType.hs
=====================================
@@ -703,7 +703,9 @@ tcTyVarLevel tv
tcTypeLevel :: TcType -> TcLevel
-- Max level of any free var of the type
tcTypeLevel ty
- = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty)
+ = nonDetStrictFoldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty)
+ -- It's safe to use a non-deterministic fold because `maxTcLevel` is
+ -- commutative.
where
add v lvl
| isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v
=====================================
compiler/utils/GraphOps.hs
=====================================
@@ -63,8 +63,8 @@ addNode k node graph
= let
-- add back conflict edges from other nodes to this one
map_conflict =
- nonDetFoldUniqSet
- -- It's OK to use nonDetFoldUFM here because the
+ nonDetStrictFoldUniqSet
+ -- It's OK to use a non-deterministic fold here because the
-- operation is commutative
(adjustUFM_C (\n -> n { nodeConflicts =
addOneToUniqSet (nodeConflicts n) k}))
@@ -73,8 +73,8 @@ addNode k node graph
-- add back coalesce edges from other nodes to this one
map_coalesce =
- nonDetFoldUniqSet
- -- It's OK to use nonDetFoldUFM here because the
+ nonDetStrictFoldUniqSet
+ -- It's OK to use a non-deterministic fold here because the
-- operation is commutative
(adjustUFM_C (\n -> n { nodeCoalesce =
addOneToUniqSet (nodeCoalesce n) k}))
@@ -476,9 +476,9 @@ 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 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
- -- It's OK to use nonDetFoldUFM here because the operation
- -- is commutative
+ fm2 = nonDetStrictFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
+ -- It's OK to use a non-deterministic fold here because the
+ -- operation is commutative
$ nodeCoalesce node
in fm2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5006a7e1088511af71ef009debcbf97bb7e801a4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5006a7e1088511af71ef009debcbf97bb7e801a4
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/20200402/33baf51a/attachment-0001.html>
More information about the ghc-commits
mailing list