Commit 4c6e69d5 authored by niteria's avatar niteria

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 ...@@ -69,7 +69,6 @@ import FieldLabel
import Class import Class
import Name import Name
import PrelNames import PrelNames
import NameEnv
import Var import Var
import Outputable import Outputable
import ListSetOps import ListSetOps
...@@ -78,6 +77,7 @@ import BasicTypes ...@@ -78,6 +77,7 @@ import BasicTypes
import FastString import FastString
import Module import Module
import Binary import Binary
import UniqFM
import qualified Data.Data as Data import qualified Data.Data as Data
import qualified Data.Typeable import qualified Data.Typeable
...@@ -1181,8 +1181,7 @@ isLegacyPromotableDataCon dc ...@@ -1181,8 +1181,7 @@ isLegacyPromotableDataCon dc
= null (dataConEqSpec dc) -- no GADTs = null (dataConEqSpec dc) -- no GADTs
&& null (dataConTheta dc) -- no context && null (dataConTheta dc) -- no context
&& not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors && not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors
&& all isLegacyPromotableTyCon (nameEnvElts $ && allUFM isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc))
tyConsOfType (dataConUserType dc))
-- | Was this tycon promotable before GHC 8.0? That is, is it promotable -- | Was this tycon promotable before GHC 8.0? That is, is it promotable
-- without -XTypeInType -- without -XTypeInType
......
...@@ -780,7 +780,10 @@ cleanUseDmd_maybe _ = Nothing ...@@ -780,7 +780,10 @@ cleanUseDmd_maybe _ = Nothing
splitFVs :: Bool -- Thunk splitFVs :: Bool -- Thunk
-> DmdEnv -> (DmdEnv, DmdEnv) -> DmdEnv -> (DmdEnv, DmdEnv)
splitFVs is_thunk rhs_fvs 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 | otherwise = partitionVarEnv isWeakDmd rhs_fvs
where where
add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)
...@@ -1198,7 +1201,10 @@ We ...@@ -1198,7 +1201,10 @@ We
-- Equality needed for fixpoints in DmdAnal -- Equality needed for fixpoints in DmdAnal
instance Eq DmdType where instance Eq DmdType where
(==) (DmdType fv1 ds1 res1) (==) (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 && ds1 == ds2 && res1 == res2
lubDmdType :: DmdType -> DmdType -> DmdType lubDmdType :: DmdType -> DmdType -> DmdType
...@@ -1251,7 +1257,9 @@ instance Outputable DmdType where ...@@ -1251,7 +1257,9 @@ instance Outputable DmdType where
else braces (fsep (map pp_elt fv_elts))] else braces (fsep (map pp_elt fv_elts))]
where where
pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd 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 :: VarEnv Demand
emptyDmdEnv = emptyVarEnv emptyDmdEnv = emptyVarEnv
......
...@@ -13,7 +13,7 @@ module NameEnv ( ...@@ -13,7 +13,7 @@ module NameEnv (
-- ** Manipulating these environments -- ** Manipulating these environments
mkNameEnv, mkNameEnv,
emptyNameEnv, isEmptyNameEnv, emptyNameEnv, isEmptyNameEnv,
unitNameEnv, nameEnvElts, nameEnvUniqueElts, unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,
extendNameEnvList, extendNameEnvList_C, extendNameEnvList, extendNameEnvList_C,
filterNameEnv, anyNameEnv, filterNameEnv, anyNameEnv,
...@@ -35,7 +35,6 @@ module NameEnv ( ...@@ -35,7 +35,6 @@ module NameEnv (
import Digraph import Digraph
import Name import Name
import Unique
import UniqFM import UniqFM
import UniqDFM import UniqDFM
import Maybes import Maybes
...@@ -89,7 +88,6 @@ emptyNameEnv :: NameEnv a ...@@ -89,7 +88,6 @@ emptyNameEnv :: NameEnv a
isEmptyNameEnv :: NameEnv a -> Bool isEmptyNameEnv :: NameEnv a -> Bool
mkNameEnv :: [(Name,a)] -> NameEnv a mkNameEnv :: [(Name,a)] -> NameEnv a
nameEnvElts :: NameEnv a -> [a] nameEnvElts :: NameEnv a -> [a]
nameEnvUniqueElts :: NameEnv a -> [(Unique, a)]
alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> 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 extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b
...@@ -123,7 +121,6 @@ plusNameEnv x y = plusUFM x y ...@@ -123,7 +121,6 @@ plusNameEnv x y = plusUFM x y
plusNameEnv_C f x y = plusUFM_C f x y plusNameEnv_C f x y = plusUFM_C f x y
extendNameEnv_C f x y z = addToUFM_C f x y z extendNameEnv_C f x y z = addToUFM_C f x y z
mapNameEnv f x = mapUFM f x mapNameEnv f x = mapUFM f x
nameEnvUniqueElts x = ufmToList x
extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b
extendNameEnvList_C x y z = addListToUFM_C x y z extendNameEnvList_C x y z = addListToUFM_C x y z
delFromNameEnv x y = delFromUFM x y delFromNameEnv x y = delFromUFM x y
......
...@@ -11,7 +11,7 @@ module NameSet ( ...@@ -11,7 +11,7 @@ module NameSet (
-- ** Manipulating these sets -- ** Manipulating these sets
emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets,
minusNameSet, elemNameSet, nameSetElems, extendNameSet, extendNameSetList, minusNameSet, elemNameSet, nameSetElems, extendNameSet, extendNameSetList,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet, delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet,
intersectsNameSet, intersectNameSet, intersectsNameSet, intersectNameSet,
nameSetAny, nameSetAll, nameSetAny, nameSetAll,
...@@ -59,7 +59,6 @@ nameSetElems :: NameSet -> [Name] ...@@ -59,7 +59,6 @@ nameSetElems :: NameSet -> [Name]
isEmptyNameSet :: NameSet -> Bool isEmptyNameSet :: NameSet -> Bool
delFromNameSet :: NameSet -> Name -> NameSet delFromNameSet :: NameSet -> Name -> NameSet
delListFromNameSet :: NameSet -> [Name] -> NameSet delListFromNameSet :: NameSet -> [Name] -> NameSet
foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b
filterNameSet :: (Name -> Bool) -> NameSet -> NameSet filterNameSet :: (Name -> Bool) -> NameSet -> NameSet
intersectNameSet :: NameSet -> NameSet -> NameSet intersectNameSet :: NameSet -> NameSet -> NameSet
intersectsNameSet :: NameSet -> NameSet -> Bool intersectsNameSet :: NameSet -> NameSet -> Bool
...@@ -78,7 +77,6 @@ minusNameSet = minusUniqSet ...@@ -78,7 +77,6 @@ minusNameSet = minusUniqSet
elemNameSet = elementOfUniqSet elemNameSet = elementOfUniqSet
nameSetElems = uniqSetToList nameSetElems = uniqSetToList
delFromNameSet = delOneFromUniqSet delFromNameSet = delOneFromUniqSet
foldNameSet = foldUniqSet
filterNameSet = filterUniqSet filterNameSet = filterUniqSet
intersectNameSet = intersectUniqSets intersectNameSet = intersectUniqSets
......
...@@ -9,7 +9,7 @@ module VarEnv ( ...@@ -9,7 +9,7 @@ module VarEnv (
-- ** Manipulating these environments -- ** Manipulating these environments
emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly,
elemVarEnv, varEnvElts, varEnvKeys, varEnvToList, elemVarEnv, varEnvElts,
extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly,
extendVarEnvList, extendVarEnvList,
plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv, plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv,
...@@ -18,7 +18,7 @@ module VarEnv ( ...@@ -18,7 +18,7 @@ module VarEnv (
lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
mapVarEnv, zipVarEnv, mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly, modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv, foldVarEnv_Directly, isEmptyVarEnv,
elemVarEnvByKey, lookupVarEnv_Directly, elemVarEnvByKey, lookupVarEnv_Directly,
filterVarEnv, filterVarEnv_Directly, restrictVarEnv, filterVarEnv, filterVarEnv_Directly, restrictVarEnv,
partitionVarEnv, partitionVarEnv,
...@@ -435,8 +435,6 @@ plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a ...@@ -435,8 +435,6 @@ plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
varEnvElts :: VarEnv a -> [a] varEnvElts :: VarEnv a -> [a]
varEnvKeys :: VarEnv a -> [Unique]
varEnvToList :: VarEnv a -> [(Unique, a)]
isEmptyVarEnv :: VarEnv a -> Bool isEmptyVarEnv :: VarEnv a -> Bool
lookupVarEnv :: VarEnv a -> Var -> Maybe a lookupVarEnv :: VarEnv a -> Var -> Maybe a
...@@ -445,8 +443,6 @@ lookupVarEnv_NF :: VarEnv a -> Var -> a ...@@ -445,8 +443,6 @@ lookupVarEnv_NF :: VarEnv a -> Var -> a
lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
elemVarEnv :: Var -> VarEnv a -> Bool elemVarEnv :: Var -> VarEnv a -> Bool
elemVarEnvByKey :: Unique -> 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 elemVarEnv = elemUFM
elemVarEnvByKey = elemUFM_Directly elemVarEnvByKey = elemUFM_Directly
...@@ -471,12 +467,8 @@ mkVarEnv = listToUFM ...@@ -471,12 +467,8 @@ mkVarEnv = listToUFM
mkVarEnv_Directly= listToUFM_Directly mkVarEnv_Directly= listToUFM_Directly
emptyVarEnv = emptyUFM emptyVarEnv = emptyUFM
varEnvElts = eltsUFM varEnvElts = eltsUFM
varEnvKeys = keysUFM
varEnvToList = ufmToList
unitVarEnv = unitUFM unitVarEnv = unitUFM
isEmptyVarEnv = isNullUFM isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
foldVarEnv_Directly = foldUFM_Directly
lookupVarEnv_Directly = lookupUFM_Directly lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly filterVarEnv_Directly = filterUFM_Directly
delVarEnv_Directly = delFromUFM_Directly delVarEnv_Directly = delFromUFM_Directly
......
...@@ -16,7 +16,7 @@ module VarSet ( ...@@ -16,7 +16,7 @@ module VarSet (
unionVarSet, unionVarSets, mapUnionVarSet, unionVarSet, unionVarSets, mapUnionVarSet,
intersectVarSet, intersectsVarSet, disjointVarSet, intersectVarSet, intersectsVarSet, disjointVarSet,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet, minusVarSet, filterVarSet,
varSetAny, varSetAll, varSetAny, varSetAll,
transCloVarSet, fixVarSet, transCloVarSet, fixVarSet,
lookupVarSet, lookupVarSetByName, lookupVarSet, lookupVarSetByName,
...@@ -82,7 +82,6 @@ delVarSetList :: VarSet -> [Var] -> VarSet ...@@ -82,7 +82,6 @@ delVarSetList :: VarSet -> [Var] -> VarSet
minusVarSet :: VarSet -> VarSet -> VarSet minusVarSet :: VarSet -> VarSet -> VarSet
isEmptyVarSet :: VarSet -> Bool isEmptyVarSet :: VarSet -> Bool
mkVarSet :: [Var] -> VarSet mkVarSet :: [Var] -> VarSet
foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a
lookupVarSet :: VarSet -> Var -> Maybe Var lookupVarSet :: VarSet -> Var -> Maybe Var
-- Returns the set element, which may be -- Returns the set element, which may be
-- (==) to the argument, but not the same as -- (==) to the argument, but not the same as
...@@ -116,7 +115,6 @@ delVarSet = delOneFromUniqSet ...@@ -116,7 +115,6 @@ delVarSet = delOneFromUniqSet
delVarSetList = delListFromUniqSet delVarSetList = delListFromUniqSet
isEmptyVarSet = isEmptyUniqSet isEmptyVarSet = isEmptyUniqSet
mkVarSet = mkUniqSet mkVarSet = mkUniqSet
foldVarSet = foldUniqSet
lookupVarSet = lookupUniqSet lookupVarSet = lookupUniqSet
lookupVarSetByName = lookupUniqSet lookupVarSetByName = lookupUniqSet
sizeVarSet = sizeUniqSet sizeVarSet = sizeUniqSet
......
...@@ -44,6 +44,7 @@ import Control.Monad ...@@ -44,6 +44,7 @@ import Control.Monad
import Name import Name
import StgSyn import StgSyn
import Outputable import Outputable
import UniqFM
------------------------------------- -------------------------------------
-- Non-void types -- Non-void types
...@@ -158,7 +159,8 @@ cgLookupPanic id ...@@ -158,7 +159,8 @@ cgLookupPanic id
pprPanic "StgCmmEnv: variable not found" pprPanic "StgCmmEnv: variable not found"
(vcat [ppr id, (vcat [ppr id,
text "local binds for:", 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 ...@@ -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 -- ent_map groups together all the things imported and used
-- from a particular module -- from a particular module
ent_map :: ModuleEnv [OccName] 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 where
add_mv name mv_map add_mv name mv_map
| isWiredInName name = mv_map -- ignore wired-in names | isWiredInName name = mv_map -- ignore wired-in names
......
...@@ -212,7 +212,9 @@ allKnownKeyNames -- where templateHaskellNames are defined ...@@ -212,7 +212,9 @@ allKnownKeyNames -- where templateHaskellNames are defined
namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n) namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
emptyUFM all_names emptyUFM all_names
badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv 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 badNamesStrs = map pairToStr badNamesPairs
badNamesStr = unlines badNamesStrs badNamesStr = unlines badNamesStrs
......
...@@ -1349,7 +1349,9 @@ depAnalTyClDecls rdr_env ds_w_fvs ...@@ -1349,7 +1349,9 @@ depAnalTyClDecls rdr_env ds_w_fvs
toParents :: GlobalRdrEnv -> NameSet -> NameSet toParents :: GlobalRdrEnv -> NameSet -> NameSet
toParents rdr_env ns 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 where
add n s = extendNameSet s (getParent rdr_env n) add n s = extendNameSet s (getParent rdr_env n)
......
...@@ -1129,7 +1129,8 @@ occAnalNonRecRhs env bndr rhs ...@@ -1129,7 +1129,8 @@ occAnalNonRecRhs env bndr rhs
not_stable = not (isStableUnfolding (idUnfolding bndr)) not_stable = not (isStableUnfolding (idUnfolding bndr))
addIdOccs :: UsageDetails -> VarSet -> UsageDetails 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 :: Id -> UsageDetails -> UsageDetails
addIdOcc v u | isId v = addOneOcc u v NoOccInfo addIdOcc v u | isId v = addOneOcc u v NoOccInfo
...@@ -1594,7 +1595,9 @@ transClosureFV env ...@@ -1594,7 +1595,9 @@ transClosureFV env
| no_change = env | no_change = env
| otherwise = transClosureFV (listToUFM new_fv_list) | otherwise = transClosureFV (listToUFM new_fv_list)
where 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) bump no_change (b,fvs)
| no_change_here = (no_change, (b,fvs)) | no_change_here = (no_change, (b,fvs))
| otherwise = (False, (b,new_fvs)) | otherwise = (False, (b,new_fvs))
...@@ -1615,7 +1618,8 @@ extendFvs env s ...@@ -1615,7 +1618,8 @@ extendFvs env s
= (s `unionVarSet` extras, extras `subVarSet` s) = (s `unionVarSet` extras, extras `subVarSet` s)
where where
extras :: VarSet -- env(s) 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 intersectUFM_C (\x _ -> x) env s
{- {-
......
...@@ -84,7 +84,7 @@ import UniqSupply ...@@ -84,7 +84,7 @@ import UniqSupply
import Util import Util
import Outputable import Outputable
import FastString import FastString
import UniqDFM (udfmToUfm) import UniqDFM
import FV import FV
{- {-
...@@ -911,7 +911,8 @@ isFunction (_, AnnLam b e) | isId b = True ...@@ -911,7 +911,8 @@ isFunction (_, AnnLam b e) | isId b = True
isFunction _ = False isFunction _ = False
countFreeIds :: DVarSet -> Int 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 where
add :: Var -> Int -> Int add :: Var -> Int -> Int
add v n | isId v = n+1 add v n | isId v = n+1
......
...@@ -568,7 +568,9 @@ matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es ...@@ -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)) kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst))
(tyVarKind tmpl_var) (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 to_co uniq expr env
| Just co <- exprToCoercion_maybe expr | Just co <- exprToCoercion_maybe expr
= extendVarEnv_Directly env uniq co = extendVarEnv_Directly env uniq co
......
...@@ -42,6 +42,7 @@ import Unify ( tcMatchTy ) ...@@ -42,6 +42,7 @@ import Unify ( tcMatchTy )
import Util import Util
import Var import Var
import VarSet import VarSet
import UniqFM
import BasicTypes ( IntWithInf, intGtLimit ) import BasicTypes ( IntWithInf, intGtLimit )
import ErrUtils ( emptyMessages ) import ErrUtils ( emptyMessages )
import qualified GHC.LanguageExtensions as LangExt import qualified GHC.LanguageExtensions as LangExt
...@@ -1367,7 +1368,9 @@ neededEvVars ev_binds initial_seeds ...@@ -1367,7 +1368,9 @@ neededEvVars ev_binds initial_seeds
also_needs :: VarSet -> VarSet also_needs :: VarSet -> VarSet
also_needs needs 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 where
add v needs add v needs
| Just ev_bind <- lookupEvBind ev_binds v | Just ev_bind <- lookupEvBind ev_binds v
......
...@@ -122,6 +122,7 @@ import PrelNames ...@@ -122,6 +122,7 @@ import PrelNames
import TysPrim ( eqPhantPrimTyCon ) import TysPrim ( eqPhantPrimTyCon )
import ListSetOps import ListSetOps
import Maybes import Maybes
import UniqFM
import Control.Monad (foldM) import Control.Monad (foldM)
import Control.Arrow ( first ) import Control.Arrow ( first )
...@@ -1614,7 +1615,10 @@ liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst ...@@ -1614,7 +1615,10 @@ liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst
liftEnvSubst selector subst lc_env liftEnvSubst selector subst lc_env
= composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst
where 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 (tpairs, cpairs) = partitionWith ty_or_co pairs
tenv = mkVarEnv_Directly tpairs tenv = mkVarEnv_Directly tpairs
cenv = mkVarEnv_Directly cpairs cenv = mkVarEnv_Directly cpairs
......
...@@ -2107,7 +2107,9 @@ checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a ...@@ -2107,7 +2107,9 @@ checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
text "needInScope" <+> ppr needInScope ) text "needInScope" <+> ppr needInScope )
a a
where 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) needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos)
`delListFromUFM_Directly` substDomain `delListFromUFM_Directly` substDomain
tysCosFVsInScope = needInScope `varSetInScope` in_scope tysCosFVsInScope = needInScope `varSetInScope` in_scope
......
...@@ -36,6 +36,7 @@ import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv ) ...@@ -36,6 +36,7 @@ import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv )
import Util import Util
import Pair import Pair
import Outputable import Outputable
import UniqFM
import Control.Monad import Control.Monad
#if __GLASGOW_HASKELL__ > 710 #if __GLASGOW_HASKELL__ > 710
...@@ -457,7 +458,9 @@ niFixTCvSubst tenv = f tenv ...@@ -457,7 +458,9 @@ niFixTCvSubst tenv = f tenv
not_fixpoint = varSetAny in_domain range_tvs not_fixpoint = varSetAny in_domain range_tvs
in_domain tv = tv `elemVarEnv` tenv 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 subst = mkTvSubst (mkInScopeSet range_tvs) tenv
-- env' extends env by replacing any free type with -- env' extends env by replacing any free type with
...@@ -467,7 +470,10 @@ niFixTCvSubst tenv = f tenv ...@@ -467,7 +470,10 @@ niFixTCvSubst tenv = f tenv
setTyVarKind rtv $ setTyVarKind rtv $
substTy subst $ substTy subst $
tyVarKind rtv) 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) ] , not (in_domain rtv) ]
subst' = mkTvSubst (mkInScopeSet range_tvs) tenv' subst' = mkTvSubst (mkInScopeSet range_tvs) tenv'
...@@ -476,7 +482,9 @@ niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet ...@@ -476,7 +482,9 @@ niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet
-- remembering that the substitution isn't necessarily idempotent -- remembering that the substitution isn't necessarily idempotent
-- This is used in the occurs check, before extending the substitution -- This is used in the occurs check, before extending the substitution
niSubstTvSet tsubst tvs 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 where
get tv get tv
| Just ty <- lookupVarEnv tsubst tv | Just ty <- lookupVarEnv tsubst tv
......
...@@ -12,7 +12,7 @@ module FastStringEnv ( ...@@ -12,7 +12,7 @@ module FastStringEnv (
-- ** Manipulating these environments -- ** Manipulating these environments
mkFsEnv,