Commit 1937ef1c authored by niteria's avatar niteria
Browse files

Make UnitIdMap a deterministic map

This impacts at least the order in which version macros are
generated. It's pretty hard to track what kind of nondeterminism
is benign and this should have no performance impact as the number
of packages should be relatively small.

Test Plan: ./validate

Reviewers: simonmar, austin, bgamari, ezyang

Reviewed By: ezyang

Subscribers: thomie

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

GHC Trac Issues: #4012
parent 3e7a876a
...@@ -57,6 +57,7 @@ import PackageConfig ...@@ -57,6 +57,7 @@ import PackageConfig
import DynFlags import DynFlags
import Name ( Name, nameModule_maybe ) import Name ( Name, nameModule_maybe )
import UniqFM import UniqFM
import UniqDFM
import Module import Module
import Util import Util
import Panic import Panic
...@@ -230,7 +231,7 @@ originEmpty (ModOrigin Nothing [] [] False) = True ...@@ -230,7 +231,7 @@ originEmpty (ModOrigin Nothing [] [] False) = True
originEmpty _ = False originEmpty _ = False
-- | 'UniqFM' map from 'UnitId' -- | 'UniqFM' map from 'UnitId'
type UnitIdMap = UniqFM type UnitIdMap = UniqDFM
-- | 'UniqFM' map from 'UnitId' to 'PackageConfig' -- | 'UniqFM' map from 'UnitId' to 'PackageConfig'
type PackageConfigMap = UnitIdMap PackageConfig type PackageConfigMap = UnitIdMap PackageConfig
...@@ -276,7 +277,7 @@ data PackageState = PackageState { ...@@ -276,7 +277,7 @@ data PackageState = PackageState {
emptyPackageState :: PackageState emptyPackageState :: PackageState
emptyPackageState = PackageState { emptyPackageState = PackageState {
pkgIdMap = emptyUFM, pkgIdMap = emptyPackageConfigMap,
preloadPackages = [], preloadPackages = [],
explicitPackages = [], explicitPackages = [],
moduleToPkgConfAll = Map.empty, moduleToPkgConfAll = Map.empty,
...@@ -287,14 +288,14 @@ type InstalledPackageIndex = Map UnitId PackageConfig ...@@ -287,14 +288,14 @@ type InstalledPackageIndex = Map UnitId PackageConfig
-- | Empty package configuration map -- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM emptyPackageConfigMap = emptyUDFM
-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any -- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' = lookupUFM lookupPackage' = lookupUDFM
-- | Search for packages with a given package ID (e.g. \"foo-0.1\") -- | Search for packages with a given package ID (e.g. \"foo-0.1\")
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
...@@ -306,7 +307,7 @@ extendPackageConfigMap ...@@ -306,7 +307,7 @@ extendPackageConfigMap
:: PackageConfigMap -> [PackageConfig] -> PackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap pkg_map new_pkgs extendPackageConfigMap pkg_map new_pkgs
= foldl add pkg_map new_pkgs = foldl add pkg_map new_pkgs
where add pkg_map p = addToUFM pkg_map (packageConfigId p) p where add pkg_map p = addToUDFM pkg_map (packageConfigId p) p
-- | Looks up the package with the given id in the package state, panicing if it is -- | Looks up the package with the given id in the package state, panicing if it is
-- not found -- not found
...@@ -319,7 +320,7 @@ getPackageDetails dflags pid = ...@@ -319,7 +320,7 @@ getPackageDetails dflags pid =
-- does not imply that the exposed-modules of the package are available -- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed). -- (they may have been thinned or renamed).
listPackageConfigMap :: DynFlags -> [PackageConfig] listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags)) listPackageConfigMap dflags = eltsUDFM (pkgIdMap (pkgState dflags))
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- Loading the package db files and building up the package state -- Loading the package db files and building up the package state
...@@ -549,7 +550,7 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag = ...@@ -549,7 +550,7 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
Right (p:_,_) -> return vm' Right (p:_,_) -> return vm'
where where
n = fsPackageName p n = fsPackageName p
vm' = addToUFM_C edit vm_cleared (packageConfigId p) (b, rns, n) vm' = addToUDFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
-- In the old days, if you said `ghc -package p-0.1 -package p-0.2` -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
-- (or if p-0.1 was registered in the pkgdb as exposed: True), -- (or if p-0.1 was registered in the pkgdb as exposed: True),
...@@ -572,7 +573,7 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag = ...@@ -572,7 +573,7 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
-- -hide-all-packages/-hide-all-plugin-packages depending on what -- -hide-all-packages/-hide-all-plugin-packages depending on what
-- flag is in question. -- flag is in question.
vm_cleared | no_hide_others = vm vm_cleared | no_hide_others = vm
| otherwise = filterUFM_Directly | otherwise = filterUDFM_Directly
(\k (_,_,n') -> k == getUnique (packageConfigId p) (\k (_,_,n') -> k == getUnique (packageConfigId p)
|| n /= n') vm || n /= n') vm
_ -> panic "applyPackageFlag" _ -> panic "applyPackageFlag"
...@@ -581,7 +582,7 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag = ...@@ -581,7 +582,7 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
case selectPackages (matchingStr str) pkgs unusable of case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps Left ps -> packageFlagErr dflags flag ps
Right (ps,_) -> return vm' Right (ps,_) -> return vm'
where vm' = delListFromUFM vm (map packageConfigId ps) where vm' = delListFromUDFM vm (map packageConfigId ps)
selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
-> UnusablePackages -> UnusablePackages
...@@ -710,7 +711,7 @@ findWiredInPackages dflags pkgs vis_map = do ...@@ -710,7 +711,7 @@ findWiredInPackages dflags pkgs vis_map = do
let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
all_exposed_ps = all_exposed_ps =
[ p | p <- all_ps [ p | p <- all_ps
, elemUFM (packageConfigId p) vis_map ] in , elemUDFM (packageConfigId p) vis_map ] in
case all_exposed_ps of case all_exposed_ps of
[] -> case all_ps of [] -> case all_ps of
[] -> notfound [] -> notfound
...@@ -784,9 +785,9 @@ findWiredInPackages dflags pkgs vis_map = do ...@@ -784,9 +785,9 @@ findWiredInPackages dflags pkgs vis_map = do
updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
where f vm (from, to) = case lookupUFM vis_map from of where f vm (from, to) = case lookupUDFM vis_map from of
Nothing -> vm Nothing -> vm
Just r -> addToUFM vm to r Just r -> addToUDFM vm to r
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
...@@ -1014,16 +1015,16 @@ mkPackageState dflags0 dbs preload0 = do ...@@ -1014,16 +1015,16 @@ mkPackageState dflags0 dbs preload0 = do
case comparing packageVersion pkg pkg' of case comparing packageVersion pkg pkg' of
GT -> pkg GT -> pkg
_ -> pkg' _ -> pkg'
calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg calcInitial m pkg = addToUDFM_C preferLater m (fsPackageName pkg) pkg
initial = if gopt Opt_HideAllPackages dflags initial = if gopt Opt_HideAllPackages dflags
then emptyUFM then emptyUDFM
else foldl' calcInitial emptyUFM pkgs1 else foldl' calcInitial emptyUDFM pkgs1
vis_map1 = foldUFM (\p vm -> vis_map1 = foldUDFM (\p vm ->
if exposed p if exposed p
then addToUFM vm (packageConfigId p) then addToUDFM vm (packageConfigId p)
(True, [], fsPackageName p) (True, [], fsPackageName p)
else vm) else vm)
emptyUFM initial emptyUDFM initial
-- --
-- Compute a visibility map according to the command-line flags (-package, -- Compute a visibility map according to the command-line flags (-package,
...@@ -1049,9 +1050,9 @@ mkPackageState dflags0 dbs preload0 = do ...@@ -1049,9 +1050,9 @@ mkPackageState dflags0 dbs preload0 = do
case pluginPackageFlags dflags of case pluginPackageFlags dflags of
-- common case; try to share the old vis_map -- common case; try to share the old vis_map
[] | not hide_plugin_pkgs -> return vis_map [] | not hide_plugin_pkgs -> return vis_map
| otherwise -> return emptyUFM | otherwise -> return emptyUDFM
_ -> do let plugin_vis_map1 _ -> do let plugin_vis_map1
| hide_plugin_pkgs = emptyUFM | hide_plugin_pkgs = emptyUDFM
-- Use the vis_map PRIOR to wired in, -- Use the vis_map PRIOR to wired in,
-- because otherwise applyPackageFlag -- because otherwise applyPackageFlag
-- won't work. -- won't work.
...@@ -1095,7 +1096,7 @@ mkPackageState dflags0 dbs preload0 = do ...@@ -1095,7 +1096,7 @@ mkPackageState dflags0 dbs preload0 = do
-- add base & rts to the preload packages -- add base & rts to the preload packages
basicLinkedPackages basicLinkedPackages
| gopt Opt_AutoLinkPackages dflags | gopt Opt_AutoLinkPackages dflags
= filter (flip elemUFM pkg_db) = filter (flip elemUDFM pkg_db)
[baseUnitId, rtsUnitId] [baseUnitId, rtsUnitId]
| otherwise = [] | otherwise = []
-- but in any case remove the current package from the set of -- but in any case remove the current package from the set of
...@@ -1111,8 +1112,8 @@ mkPackageState dflags0 dbs preload0 = do ...@@ -1111,8 +1112,8 @@ mkPackageState dflags0 dbs preload0 = do
-- Force pstate to avoid leaking the dflags0 passed to mkPackageState -- Force pstate to avoid leaking the dflags0 passed to mkPackageState
let !pstate = PackageState{ let !pstate = PackageState{
preloadPackages = dep_preload, preloadPackages = dep_preload,
explicitPackages = foldUFM (\pkg xs -> explicitPackages = foldUDFM (\pkg xs ->
if elemUFM (packageConfigId pkg) vis_map if elemUDFM (packageConfigId pkg) vis_map
then packageConfigId pkg : xs then packageConfigId pkg : xs
else xs) [] pkg_db, else xs) [] pkg_db,
pkgIdMap = pkg_db, pkgIdMap = pkg_db,
...@@ -1131,7 +1132,7 @@ mkModuleToPkgConfAll ...@@ -1131,7 +1132,7 @@ mkModuleToPkgConfAll
-> VisibilityMap -> VisibilityMap
-> ModuleToPkgConfAll -> ModuleToPkgConfAll
mkModuleToPkgConfAll dflags pkg_db vis_map = mkModuleToPkgConfAll dflags pkg_db vis_map =
foldl' extend_modmap emptyMap (eltsUFM pkg_db) foldl' extend_modmap emptyMap (eltsUDFM pkg_db)
where where
emptyMap = Map.empty emptyMap = Map.empty
sing pk m _ = Map.singleton (mkModule pk m) sing pk m _ = Map.singleton (mkModule pk m)
...@@ -1141,7 +1142,7 @@ mkModuleToPkgConfAll dflags pkg_db vis_map = ...@@ -1141,7 +1142,7 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
extend_modmap modmap pkg = addListTo modmap theBindings extend_modmap modmap pkg = addListTo modmap theBindings
where where
theBindings :: [(ModuleName, Map Module ModuleOrigin)] theBindings :: [(ModuleName, Map Module ModuleOrigin)]
theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg) theBindings | Just (b,rns,_) <- lookupUDFM vis_map (packageConfigId pkg)
= newBindings b rns = newBindings b rns
| otherwise = newBindings False [] | otherwise = newBindings False []
......
...@@ -40,7 +40,7 @@ module UniqDFM ( ...@@ -40,7 +40,7 @@ module UniqDFM (
elemUDFM, elemUDFM,
foldUDFM, foldUDFM,
eltsUDFM, eltsUDFM,
filterUDFM, filterUDFM, filterUDFM_Directly,
isNullUDFM, isNullUDFM,
sizeUDFM, sizeUDFM,
intersectUDFM, udfmIntersectUFM, intersectUDFM, udfmIntersectUFM,
...@@ -265,6 +265,11 @@ eltsUDFM (UDFM m _i) = ...@@ -265,6 +265,11 @@ eltsUDFM (UDFM m _i) =
filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt
filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt
filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i
where
p' k (TaggedVal v _) = p (getUnique k) v
-- | Converts `UniqDFM` to a list, with elements in deterministic order. -- | Converts `UniqDFM` to a list, with elements in deterministic order.
-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
udfmToList :: UniqDFM elt -> [(Unique, elt)] udfmToList :: UniqDFM elt -> [(Unique, elt)]
......
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