Commit 4c6e69d5 authored by niteria's avatar niteria
Browse files

Document some benign nondeterminism

I've changed the functions to their nonDet equivalents and explained
why they're OK there. This allowed me to remove foldNameSet,
foldVarEnv, foldVarEnv_Directly, foldVarSet and foldUFM_Directly.

Test Plan: ./validate, there should be no change in behavior

Reviewers: simonpj, simonmar, austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2244

GHC Trac Issues: #4012
parent 8f7d0163
......@@ -69,7 +69,6 @@ import FieldLabel
import Class
import Name
import PrelNames
import NameEnv
import Var
import Outputable
import ListSetOps
......@@ -78,6 +77,7 @@ import BasicTypes
import FastString
import Module
import Binary
import UniqFM
import qualified Data.Data as Data
import qualified Data.Typeable
......@@ -1181,8 +1181,7 @@ isLegacyPromotableDataCon dc
= null (dataConEqSpec dc) -- no GADTs
&& null (dataConTheta dc) -- no context
&& not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors
&& all isLegacyPromotableTyCon (nameEnvElts $
tyConsOfType (dataConUserType dc))
&& allUFM isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc))
-- | Was this tycon promotable before GHC 8.0? That is, is it promotable
-- without -XTypeInType
......
......@@ -780,7 +780,10 @@ cleanUseDmd_maybe _ = Nothing
splitFVs :: Bool -- Thunk
-> DmdEnv -> (DmdEnv, DmdEnv)
splitFVs is_thunk rhs_fvs
| is_thunk = foldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
| is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
-- It's OK to use nonDetFoldUFM_Directly 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)
......@@ -1198,7 +1201,10 @@ We
-- Equality needed for fixpoints in DmdAnal
instance Eq DmdType where
(==) (DmdType fv1 ds1 res1)
(DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
(DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2
-- It's OK to use nonDetUFMToList here because we're testing for
-- equality and even though the lists will be in some arbitrary
-- Unique order, it is the same order for both
&& ds1 == ds2 && res1 == res2
lubDmdType :: DmdType -> DmdType -> DmdType
......@@ -1251,7 +1257,9 @@ instance Outputable DmdType where
else braces (fsep (map pp_elt fv_elts))]
where
pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
fv_elts = ufmToList fv
fv_elts = nonDetUFMToList fv
-- It's OK to use nonDetUFMToList here because we only do it for
-- pretty printing
emptyDmdEnv :: VarEnv Demand
emptyDmdEnv = emptyVarEnv
......
......@@ -13,7 +13,7 @@ module NameEnv (
-- ** Manipulating these environments
mkNameEnv,
emptyNameEnv, isEmptyNameEnv,
unitNameEnv, nameEnvElts, nameEnvUniqueElts,
unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,
extendNameEnvList, extendNameEnvList_C,
filterNameEnv, anyNameEnv,
......@@ -35,7 +35,6 @@ module NameEnv (
import Digraph
import Name
import Unique
import UniqFM
import UniqDFM
import Maybes
......@@ -89,7 +88,6 @@ emptyNameEnv :: NameEnv a
isEmptyNameEnv :: NameEnv a -> Bool
mkNameEnv :: [(Name,a)] -> NameEnv a
nameEnvElts :: NameEnv a -> [a]
nameEnvUniqueElts :: NameEnv a -> [(Unique, a)]
alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b
......@@ -123,7 +121,6 @@ plusNameEnv x y = plusUFM x y
plusNameEnv_C f x y = plusUFM_C f x y
extendNameEnv_C f x y z = addToUFM_C f x y z
mapNameEnv f x = mapUFM f x
nameEnvUniqueElts x = ufmToList x
extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b
extendNameEnvList_C x y z = addListToUFM_C x y z
delFromNameEnv x y = delFromUFM x y
......
......@@ -11,7 +11,7 @@ module NameSet (
-- ** Manipulating these sets
emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets,
minusNameSet, elemNameSet, nameSetElems, extendNameSet, extendNameSetList,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet,
intersectsNameSet, intersectNameSet,
nameSetAny, nameSetAll,
......@@ -59,7 +59,6 @@ nameSetElems :: NameSet -> [Name]
isEmptyNameSet :: NameSet -> Bool
delFromNameSet :: NameSet -> Name -> NameSet
delListFromNameSet :: NameSet -> [Name] -> NameSet
foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b
filterNameSet :: (Name -> Bool) -> NameSet -> NameSet
intersectNameSet :: NameSet -> NameSet -> NameSet
intersectsNameSet :: NameSet -> NameSet -> Bool
......@@ -78,7 +77,6 @@ minusNameSet = minusUniqSet
elemNameSet = elementOfUniqSet
nameSetElems = uniqSetToList
delFromNameSet = delOneFromUniqSet
foldNameSet = foldUniqSet
filterNameSet = filterUniqSet
intersectNameSet = intersectUniqSets
......
......@@ -9,7 +9,7 @@ module VarEnv (
-- ** Manipulating these environments
emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly,
elemVarEnv, varEnvElts, varEnvKeys, varEnvToList,
elemVarEnv, varEnvElts,
extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly,
extendVarEnvList,
plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv,
......@@ -18,7 +18,7 @@ module VarEnv (
lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv, foldVarEnv_Directly,
isEmptyVarEnv,
elemVarEnvByKey, lookupVarEnv_Directly,
filterVarEnv, filterVarEnv_Directly, restrictVarEnv,
partitionVarEnv,
......@@ -435,8 +435,6 @@ plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
varEnvElts :: VarEnv a -> [a]
varEnvKeys :: VarEnv a -> [Unique]
varEnvToList :: VarEnv a -> [(Unique, a)]
isEmptyVarEnv :: VarEnv a -> Bool
lookupVarEnv :: VarEnv a -> Var -> Maybe a
......@@ -445,8 +443,6 @@ lookupVarEnv_NF :: VarEnv a -> Var -> a
lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
elemVarEnv :: Var -> VarEnv a -> Bool
elemVarEnvByKey :: Unique -> VarEnv a -> Bool
foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
foldVarEnv_Directly :: (Unique -> a -> b -> b) -> b -> VarEnv a -> b
elemVarEnv = elemUFM
elemVarEnvByKey = elemUFM_Directly
......@@ -471,12 +467,8 @@ mkVarEnv = listToUFM
mkVarEnv_Directly= listToUFM_Directly
emptyVarEnv = emptyUFM
varEnvElts = eltsUFM
varEnvKeys = keysUFM
varEnvToList = ufmToList
unitVarEnv = unitUFM
isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
foldVarEnv_Directly = foldUFM_Directly
lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly
delVarEnv_Directly = delFromUFM_Directly
......
......@@ -16,7 +16,7 @@ module VarSet (
unionVarSet, unionVarSets, mapUnionVarSet,
intersectVarSet, intersectsVarSet, disjointVarSet,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
minusVarSet, filterVarSet,
varSetAny, varSetAll,
transCloVarSet, fixVarSet,
lookupVarSet, lookupVarSetByName,
......@@ -82,7 +82,6 @@ delVarSetList :: VarSet -> [Var] -> VarSet
minusVarSet :: VarSet -> VarSet -> VarSet
isEmptyVarSet :: VarSet -> Bool
mkVarSet :: [Var] -> VarSet
foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a
lookupVarSet :: VarSet -> Var -> Maybe Var
-- Returns the set element, which may be
-- (==) to the argument, but not the same as
......@@ -116,7 +115,6 @@ delVarSet = delOneFromUniqSet
delVarSetList = delListFromUniqSet
isEmptyVarSet = isEmptyUniqSet
mkVarSet = mkUniqSet
foldVarSet = foldUniqSet
lookupVarSet = lookupUniqSet
lookupVarSetByName = lookupUniqSet
sizeVarSet = sizeUniqSet
......
......@@ -44,6 +44,7 @@ import Control.Monad
import Name
import StgSyn
import Outputable
import UniqFM
-------------------------------------
-- Non-void types
......@@ -158,7 +159,8 @@ cgLookupPanic id
pprPanic "StgCmmEnv: variable not found"
(vcat [ppr id,
text "local binds for:",
vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
pprUFM local_binds $ \infos ->
vcat [ ppr (cg_id info) | info <- infos ]
])
......
......@@ -148,7 +148,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 = foldNameSet add_mv emptyModuleEnv used_names
ent_map = nonDetFoldUFM add_mv emptyModuleEnv used_names
-- nonDetFoldUFM 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
......
......@@ -212,7 +212,9 @@ allKnownKeyNames -- where templateHaskellNames are defined
namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
emptyUFM all_names
badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv
badNamesPairs = nameEnvUniqueElts badNamesEnv
badNamesPairs = nonDetUFMToList badNamesEnv
-- It's OK to use nonDetUFMToList here because the ordering only affects
-- the message when we get a panic
badNamesStrs = map pairToStr badNamesPairs
badNamesStr = unlines badNamesStrs
......
......@@ -1349,7 +1349,9 @@ depAnalTyClDecls rdr_env ds_w_fvs
toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents rdr_env ns
= foldNameSet add emptyNameSet ns
= nonDetFoldUFM add emptyNameSet ns
-- It's OK to use nonDetFoldUFM because we immediately forget the
-- ordering by creating a set
where
add n s = extendNameSet s (getParent rdr_env n)
......
......@@ -1129,7 +1129,8 @@ occAnalNonRecRhs env bndr rhs
not_stable = not (isStableUnfolding (idUnfolding bndr))
addIdOccs :: UsageDetails -> VarSet -> UsageDetails
addIdOccs usage id_set = foldVarSet addIdOcc usage id_set
addIdOccs usage id_set = nonDetFoldUFM addIdOcc usage id_set
-- It's OK to use nonDetFoldUFM here because addIdOcc commutes
addIdOcc :: Id -> UsageDetails -> UsageDetails
addIdOcc v u | isId v = addOneOcc u v NoOccInfo
......@@ -1594,7 +1595,9 @@ transClosureFV env
| no_change = env
| otherwise = transClosureFV (listToUFM new_fv_list)
where
(no_change, new_fv_list) = mapAccumL bump True (ufmToList env)
(no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)
-- It's OK to use nonDetUFMToList here because we'll forget the
-- ordering by creating a new set with listToUFM
bump no_change (b,fvs)
| no_change_here = (no_change, (b,fvs))
| otherwise = (False, (b,new_fvs))
......@@ -1615,7 +1618,8 @@ extendFvs env s
= (s `unionVarSet` extras, extras `subVarSet` s)
where
extras :: VarSet -- env(s)
extras = foldUFM unionVarSet emptyVarSet $
extras = nonDetFoldUFM unionVarSet emptyVarSet $
-- It's OK to use nonDetFoldUFM here because unionVarSet commutes
intersectUFM_C (\x _ -> x) env s
{-
......
......@@ -84,7 +84,7 @@ import UniqSupply
import Util
import Outputable
import FastString
import UniqDFM (udfmToUfm)
import UniqDFM
import FV
{-
......@@ -911,7 +911,8 @@ isFunction (_, AnnLam b e) | isId b = True
isFunction _ = False
countFreeIds :: DVarSet -> Int
countFreeIds = foldVarSet add 0 . udfmToUfm
countFreeIds = nonDetFoldUDFM add 0
-- It's OK to use nonDetFoldUDFM here because we're just counting things.
where
add :: Var -> Int -> Int
add v n | isId v = n+1
......
......@@ -568,7 +568,9 @@ matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es
kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst))
(tyVarKind tmpl_var)
to_co_env env = foldVarEnv_Directly to_co emptyVarEnv env
to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env
-- It's OK to use nonDetFoldUFM_Directly because we forget the
-- order immediately by creating a new env
to_co uniq expr env
| Just co <- exprToCoercion_maybe expr
= extendVarEnv_Directly env uniq co
......
......@@ -42,6 +42,7 @@ import Unify ( tcMatchTy )
import Util
import Var
import VarSet
import UniqFM
import BasicTypes ( IntWithInf, intGtLimit )
import ErrUtils ( emptyMessages )
import qualified GHC.LanguageExtensions as LangExt
......@@ -1367,7 +1368,9 @@ neededEvVars ev_binds initial_seeds
also_needs :: VarSet -> VarSet
also_needs needs
= foldVarSet add emptyVarSet needs
= nonDetFoldUFM add emptyVarSet needs
-- It's OK to use nonDetFoldUFM here because we immediately forget
-- about the ordering by creating a set
where
add v needs
| Just ev_bind <- lookupEvBind ev_binds v
......
......@@ -122,6 +122,7 @@ import PrelNames
import TysPrim ( eqPhantPrimTyCon )
import ListSetOps
import Maybes
import UniqFM
import Control.Monad (foldM)
import Control.Arrow ( first )
......@@ -1614,7 +1615,10 @@ liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubst selector subst lc_env
= composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst
where
pairs = varEnvToList lc_env
pairs = nonDetUFMToList lc_env
-- It's OK to use nonDetUFMToList here because we
-- immediately forget the ordering by creating
-- a VarEnv
(tpairs, cpairs) = partitionWith ty_or_co pairs
tenv = mkVarEnv_Directly tpairs
cenv = mkVarEnv_Directly cpairs
......
......@@ -2107,7 +2107,9 @@ checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
text "needInScope" <+> ppr needInScope )
a
where
substDomain = varEnvKeys tenv ++ varEnvKeys cenv
substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv
-- It's OK to use nonDetKeysUFM here, because we only use this list to
-- remove some elements from a set
needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos)
`delListFromUFM_Directly` substDomain
tysCosFVsInScope = needInScope `varSetInScope` in_scope
......
......@@ -36,6 +36,7 @@ import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv )
import Util
import Pair
import Outputable
import UniqFM
import Control.Monad
#if __GLASGOW_HASKELL__ > 710
......@@ -457,7 +458,9 @@ niFixTCvSubst tenv = f tenv
not_fixpoint = varSetAny in_domain range_tvs
in_domain tv = tv `elemVarEnv` tenv
range_tvs = foldVarEnv (unionVarSet . tyCoVarsOfType) emptyVarSet tenv
range_tvs = nonDetFoldUFM (unionVarSet . tyCoVarsOfType) emptyVarSet tenv
-- It's OK to use nonDetFoldUFM here because we
-- forget the order immediately by creating a set
subst = mkTvSubst (mkInScopeSet range_tvs) tenv
-- env' extends env by replacing any free type with
......@@ -467,7 +470,10 @@ niFixTCvSubst tenv = f tenv
setTyVarKind rtv $
substTy subst $
tyVarKind rtv)
| rtv <- varSetElems range_tvs
| rtv <- nonDetEltsUFM range_tvs
-- It's OK to use nonDetEltsUFM here
-- because we forget the order
-- immediatedly by putting it in VarEnv
, not (in_domain rtv) ]
subst' = mkTvSubst (mkInScopeSet range_tvs) tenv'
......@@ -476,7 +482,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
= foldVarSet (unionVarSet . get) emptyVarSet tvs
= nonDetFoldUFM (unionVarSet . get) emptyVarSet tvs
-- It's OK to nonDetFoldUFM here because we immediately forget the
-- ordering by creating a set.
where
get tv
| Just ty <- lookupVarEnv tsubst tv
......
......@@ -12,7 +12,7 @@ module FastStringEnv (
-- ** Manipulating these environments
mkFsEnv,
emptyFsEnv, unitFsEnv, fsEnvElts, fsEnvUniqueElts,
emptyFsEnv, unitFsEnv, fsEnvElts,
extendFsEnv_C, extendFsEnv_Acc, extendFsEnv,
extendFsEnvList, extendFsEnvList_C,
filterFsEnv,
......@@ -21,7 +21,6 @@ module FastStringEnv (
elemFsEnv, mapFsEnv,
) where
import Unique
import UniqFM
import Maybes
import FastString
......@@ -32,7 +31,6 @@ type FastStringEnv a = UniqFM a -- Domain is FastString
emptyFsEnv :: FastStringEnv a
mkFsEnv :: [(FastString,a)] -> FastStringEnv a
fsEnvElts :: FastStringEnv a -> [a]
fsEnvUniqueElts :: FastStringEnv a -> [(Unique, a)]
alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a
extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a
extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b
......@@ -63,7 +61,6 @@ plusFsEnv x y = plusUFM x y
plusFsEnv_C f x y = plusUFM_C f x y
extendFsEnv_C f x y z = addToUFM_C f x y z
mapFsEnv f x = mapUFM f x
fsEnvUniqueElts x = ufmToList x
extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b
extendFsEnvList_C x y z = addListToUFM_C x y z
delFromFsEnv x y = delFromUFM x y
......
......@@ -53,7 +53,8 @@ module UniqFM (
intersectUFM,
intersectUFM_C,
disjointUFM,
foldUFM, foldUFM_Directly, anyUFM, allUFM,
nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly,
anyUFM, allUFM,
mapUFM, mapUFM_Directly,
elemUFM, elemUFM_Directly,
filterUFM, filterUFM_Directly, partitionUFM,
......@@ -61,17 +62,15 @@ module UniqFM (
isNullUFM,
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
nonDetEltsUFM, eltsUFM, nonDetKeysUFM, keysUFM, splitUFM,
nonDetEltsUFM, eltsUFM, nonDetKeysUFM,
ufmToSet_Directly,
ufmToList, ufmToIntMap,
joinUFM, pprUniqFM, pprUFM, pluralUFM
nonDetUFMToList, ufmToList, ufmToIntMap,
pprUniqFM, pprUFM, pluralUFM
) where
import Unique ( Uniquable(..), Unique, getKey )
import Outputable
import Compiler.Hoopl hiding (Unique)
import qualified Data.IntMap as M
import qualified Data.IntSet as S
import Data.Typeable
......@@ -165,7 +164,6 @@ intersectUFM_C :: (elt1 -> elt2 -> elt3)
disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
......@@ -177,8 +175,6 @@ sizeUFM :: UniqFM elt -> Int
elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
elemUFM_Directly:: Unique -> UniqFM elt -> Bool
splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
-- Splits a UFM into things less than, equal to, and greater than the key
lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM_Directly -- when you've got the Unique already
:: UniqFM elt -> Unique -> Maybe elt
......@@ -186,7 +182,6 @@ lookupWithDefaultUFM
:: Uniquable key => UniqFM elt -> elt -> key -> elt
lookupWithDefaultUFM_Directly
:: UniqFM elt -> elt -> Unique -> elt
keysUFM :: UniqFM elt -> [Unique] -- Get the keys
eltsUFM :: UniqFM elt -> [elt]
ufmToSet_Directly :: UniqFM elt -> S.IntSet
ufmToList :: UniqFM elt -> [(Unique, elt)]
......@@ -274,7 +269,6 @@ 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)
filterUFM p (UFM m) = UFM (M.filter p m)
......@@ -286,13 +280,10 @@ sizeUFM (UFM m) = M.size m
elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
elemUFM_Directly u (UFM m) = M.member (getKey u) m
splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of
(less, equal, greater) -> (UFM less, equal, UFM greater)
lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
keysUFM (UFM m) = map getUnique $ M.keys m
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
......@@ -315,19 +306,27 @@ nonDetEltsUFM (UFM m) = M.elems m
nonDetKeysUFM :: UniqFM elt -> [Unique]
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.fold 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.foldWithKey (k . getUnique) z m
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
nonDetUFMToList :: UniqFM elt -> [(Unique, elt)]
nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
ufmToIntMap :: UniqFM elt -> M.IntMap elt
ufmToIntMap (UFM m) = m
-- Hoopl
joinUFM :: JoinFun v -> JoinFun (UniqFM v)
joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
where add k new_v (ch, joinmap) =
case lookupUFM_Directly joinmap k of
Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
(SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
(NoChange, _) -> (ch, joinmap)
{-
************************************************************************
* *
......@@ -343,7 +342,9 @@ pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
pprUniqFM ppr_elt ufm
= brackets $ fsep $ punctuate comma $
[ ppr uq <+> text ":->" <+> ppr_elt elt
| (uq, elt) <- ufmToList ufm ]
| (uq, elt) <- nonDetUFMToList ufm ]
-- It's OK to use nonDetUFMToList here because we only use it for
-- pretty-printing.
-- | Pretty-print a non-deterministic set.
-- The order of variables is non-deterministic and for pretty-printing that
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment