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