diff options
| -rw-r--r-- | compiler/basicTypes/NameEnv.hs | 10 | ||||
| -rw-r--r-- | compiler/iface/MkIface.hs | 8 | ||||
| -rw-r--r-- | compiler/rename/RnBinds.hs | 5 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 7 | ||||
| -rw-r--r-- | compiler/simplCore/OccurAnal.hs | 11 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.hs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvidence.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.hs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyDecls.hs | 23 | ||||
| -rw-r--r-- | compiler/utils/Digraph.hs | 15 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.hs | 12 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Type/Classify.hs | 6 |
12 files changed, 102 insertions, 15 deletions
diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs index 674323d290..740c40605e 100644 --- a/compiler/basicTypes/NameEnv.hs +++ b/compiler/basicTypes/NameEnv.hs @@ -48,6 +48,16 @@ import Maybes ************************************************************************ -} +{- +Note [depAnal determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +depAnal is deterministic provided it gets the nodes in a deterministic order. +The order of lists that get_defs and get_uses return doesn't matter, as these +are only used to construct the edges, and stronglyConnCompFromEdgedVertices is +deterministic even when the edges are not in deterministic order as explained +in Note [Deterministic SCC] in Digraph. +-} + depAnal :: (node -> [Name]) -- Defs -> (node -> [Name]) -- Uses -> [node] diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 7f8397bf07..64c78319a6 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -106,6 +106,7 @@ import Maybes import Binary import Fingerprint import Exception +import UniqFM import Control.Monad import Data.Function @@ -396,7 +397,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n localOccs = map (getUnique . getParent . getOccName) . filter ((== this_mod) . name_module) - . nameSetElems + . nonDetEltsUFM + -- It's OK to use nonDetEltsUFM as localOccs is only + -- used to construct the edges and + -- stronglyConnCompFromEdgedVertices is deterministic + -- even with non-deterministic order of edges as + -- explained in Note [Deterministic SCC] in Digraph. where getParent occ = lookupOccEnv parent_map occ `orElse` occ -- maps OccNames to their parents in the current module. diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 45ca7050ad..61f4dd8a3e 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -46,6 +46,7 @@ import Bag import Util import Outputable import FastString +import UniqFM import Maybes ( orElse ) import qualified GHC.LanguageExtensions as LangExt @@ -516,7 +517,9 @@ depAnalBinds binds_w_dus = (map get_binds sccs, map get_du sccs) where sccs = depAnal (\(_, defs, _) -> defs) - (\(_, _, uses) -> nameSetElems uses) + (\(_, _, uses) -> nonDetEltsUFM uses) + -- It's OK to use nonDetEltsUFM here as explained in + -- Note [depAnal determinism] in NameEnv. (bagToList binds_w_dus) get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index f92bae9f02..d91ce86cff 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -50,6 +50,7 @@ import Util ( debugIsOn, partitionWith ) import HscTypes ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq, removeDups, equivClasses ) import Digraph ( SCC, flattenSCC, flattenSCCs, stronglyConnCompFromEdgedVertices ) +import UniqFM import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -1339,8 +1340,12 @@ depAnalTyClDecls :: GlobalRdrEnv depAnalTyClDecls rdr_env ds_w_fvs = stronglyConnCompFromEdgedVertices edges where - edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nameSetElems fvs)) + edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUFM fvs)) | (d, fvs) <- ds_w_fvs ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic + -- even if the edges are in nondeterministic order as explained + -- in Note [Deterministic SCC] in Digraph. toParents :: GlobalRdrEnv -> NameSet -> NameSet toParents rdr_env ns diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 41a6f7fa71..b9edba7bd9 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -691,7 +691,10 @@ instance Outputable Details where makeNode :: OccEnv -> ImpRuleEdges -> VarSet -> (Var, CoreExpr) -> Node Details makeNode env imp_rule_edges bndr_set (bndr, rhs) - = (details, varUnique bndr, keysUFM node_fvs) + = (details, varUnique bndr, nonDetKeysUFM node_fvs) + -- It's OK to use nonDetKeysUFM here as stronglyConnCompFromEdgedVerticesR + -- is still deterministic with edges in nondeterministic order as + -- explained in Note [Deterministic SCC] in Digraph. where details = ND { nd_bndr = bndr , nd_rhs = rhs' @@ -800,7 +803,11 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds) -- See Note [Choosing loop breakers] for loop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes mk_node (details@(ND { nd_inl = inl_fvs }), k, _) - = (details, k, keysUFM (extendFvs_ rule_fv_env inl_fvs)) + = (details, k, nonDetKeysUFM (extendFvs_ rule_fv_env inl_fvs)) + -- It's OK to use nonDetKeysUFM here as + -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges + -- in nondeterministic order as explained in + -- Note [Deterministic SCC] in Digraph. ------------------------------------ rule_fv_env :: IdEnv IdSet diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 19b503400b..fc04ec9999 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -58,6 +58,7 @@ import Outputable import Type(mkStrLitTy, tidyOpenType) import PrelNames( mkUnboundName, gHC_PRIM, ipClassName ) import TcValidity (checkValidType) +import UniqFM import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -498,10 +499,13 @@ type BKey = Int -- Just number off the bindings mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)] -- See Note [Polymorphic recursion] in HsBinds. mkEdges sig_fn binds - = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)), + = [ (bind, key, [key | n <- nonDetEltsUFM (bind_fvs (unLoc bind)), Just key <- [lookupNameEnv key_map n], no_sig n ]) | (bind, key) <- keyd_binds ] + -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in Digraph. where no_sig :: Name -> Bool no_sig n = noCompleteSig (sig_fn n) diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index c4d02d8248..b86e3f4678 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -62,6 +62,7 @@ import Outputable import FastString import SrcLoc import Data.IORef( IORef ) +import UniqFM {- Note [TcCoercions] @@ -695,8 +696,11 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges mk_node :: EvBind -> (EvBind, EvVar, [EvVar]) mk_node b@(EvBind { eb_lhs = var, eb_rhs = term }) - = (b, var, varSetElems (evVarsOfTerm term `unionVarSet` - coVarsOfType (varType var))) + = (b, var, nonDetEltsUFM (evVarsOfTerm term `unionVarSet` + coVarsOfType (varType var))) + -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in Digraph. evVarsOfCallStack :: EvCallStack -> VarSet evVarsOfCallStack cs = case cs of diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 10fd0cce5f..606e3c19e8 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -2479,8 +2479,12 @@ checkForCyclicBinds ev_binds is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b) edges :: [(EvBind, EvVar, [EvVar])] - edges = [ (bind, bndr, varSetElems (evVarsOfTerm rhs)) + edges = [ (bind, bndr, nonDetEltsUFM (evVarsOfTerm rhs)) | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic even + -- if the edges are in nondeterministic order as explained in + -- Note [Deterministic SCC] in Digraph. #endif nestImplicTcS :: Maybe EvBindsVar -> TyCoVarSet -- bound in this implication diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 62933b5923..2d6637ea29 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -60,6 +60,7 @@ import Data.List import Bag import FastString import FV +import UniqFM import Control.Monad @@ -130,9 +131,13 @@ synonymTyConsOfType ty -} mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] -mkSynEdges syn_decls = [ (ldecl, name, nameSetElems fvs) +mkSynEdges syn_decls = [ (ldecl, name, nonDetEltsUFM fvs) | ldecl@(L _ (SynDecl { tcdLName = L _ name , tcdFVs = fvs })) <- syn_decls ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic even + -- if the edges are in nondeterministic order as explained in + -- Note [Deterministic SCC] in Digraph. calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges @@ -419,8 +424,10 @@ calcRecFlags boot_details is_boot mrole_env all_tycons nt_edges = [(t, mk_nt_edges t) | t <- new_tycons] mk_nt_edges nt -- Invariant: nt is a newtype - = [ tc | tc <- nameEnvElts (tyConsOfType (new_tc_rhs nt)) + = [ tc | tc <- nonDetEltsUFM (tyConsOfType (new_tc_rhs nt)) -- tyConsOfType looks through synonyms + -- It's OK to use nonDetEltsUFM here, see + -- Note [findLoopBreakers determinism]. , tc `elem` new_tycons ] -- If not (tc `elem` new_tycons) we know that either it's a local *data* type, -- or it's imported. Either way, it can't form part of a newtype cycle @@ -433,7 +440,9 @@ calcRecFlags boot_details is_boot mrole_env all_tycons mk_prod_edges tc -- Invariant: tc is a product tycon = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc))) - mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (nameEnvElts (tyConsOfType ty)) + mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (nonDetEltsUFM (tyConsOfType ty)) + -- It's OK to use nonDetEltsUFM here, see + -- Note [findLoopBreakers determinism]. mk_prod_edges2 ptc tc | tc `elem` prod_tycons = [tc] -- Local product @@ -447,6 +456,14 @@ calcRecFlags boot_details is_boot mrole_env all_tycons new_tc_rhs :: TyCon -> Type new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables +{- +Note [findLoopBreakers determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The order of edges doesn't matter for determinism here as explained in +Note [Deterministic SCC] in Digraph. It's enough for the order of nodes +to be deterministic. +-} + findLoopBreakers :: [(TyCon, [TyCon])] -> [Name] -- Finds a set of tycons that cut all loops findLoopBreakers deps diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs index 2c90c1e41e..1d6ef24e61 100644 --- a/compiler/utils/Digraph.hs +++ b/compiler/utils/Digraph.hs @@ -94,6 +94,7 @@ type Node key payload = (payload, key, [key]) emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) +-- See Note [Deterministic SCC] graphFromEdgedVertices :: Ord key -- We only use Ord for efficiency, -- it doesn't effect the result, so @@ -200,6 +201,18 @@ depend on earlier ones, but not vice versa i.e. later components only have edges going from them to earlier ones. -} +{- +Note [Deterministic SCC] +~~~~~~~~~~~~~~~~~~~~~~~~ +stronglyConnCompFromEdgedVertices and stronglyConnCompFromEdgedVerticesR +provide a following guarantee: +Given a deterministically ordered list of nodes it returns a deterministically +ordered list of strongly connected components, where the list of vertices +in an SCC is also deterministically ordered. +Note that the order of edges doesn't need to be deterministic for this to work. +We use the order of nodes to normalize the order of edges. +-} + stronglyConnCompG :: Graph node -> [SCC node] stronglyConnCompG graph = decodeSccs graph forest where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) @@ -216,6 +229,7 @@ decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest -- The following two versions are provided for backwards compatability: +-- See Note [Deterministic SCC] stronglyConnCompFromEdgedVertices :: Ord key => [Node key payload] @@ -226,6 +240,7 @@ stronglyConnCompFromEdgedVertices -- The "R" interface is used when you expect to apply SCC to -- (some of) the result of SCC, so you dont want to lose the dependency info +-- See Note [Deterministic SCC] stronglyConnCompFromEdgedVerticesR :: Ord key => [Node key payload] diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index 590358ab40..2ff635268d 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -61,7 +61,7 @@ module UniqFM ( isNullUFM, lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - nonDetEltsUFM, eltsUFM, keysUFM, splitUFM, + nonDetEltsUFM, eltsUFM, nonDetKeysUFM, keysUFM, splitUFM, ufmToSet_Directly, ufmToList, ufmToIntMap, joinUFM, pprUniqFM, pprUFM, pluralUFM @@ -303,10 +303,18 @@ anyUFM p (UFM m) = M.fold ((||) . p) False m allUFM :: (elt -> Bool) -> UniqFM elt -> Bool allUFM p (UFM m) = M.fold ((&&) . p) True m --- See Note [Deterministic UniqFM] to learn about nondeterminism +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. nonDetEltsUFM :: UniqFM elt -> [elt] nonDetEltsUFM (UFM m) = M.elems m +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUFM :: UniqFM elt -> [Unique] +nonDetKeysUFM (UFM m) = map getUnique $ M.keys m + ufmToIntMap :: UniqFM elt -> M.IntMap elt ufmToIntMap (UFM m) = m diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 0140989233..75d43d4e36 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -98,8 +98,12 @@ type TyConGroup = ([TyCon], UniqSet TyCon) tyConGroups :: [TyCon] -> [TyConGroup] tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges) where - edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs + edges = [((tc, ds), tc, nonDetEltsUFM ds) | tc <- tcs , let ds = tyConsOfTyCon tc] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic even + -- if the edges are in nondeterministic order as explained in + -- Note [Deterministic SCC] in Digraph. mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds) mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss) |