[Git][ghc/ghc][master] driver: Unit State Data.Map -> GHC.Unique.UniqMap
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Apr 1 13:42:56 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00
driver: Unit State Data.Map -> GHC.Unique.UniqMap
In pursuit of #22426. The driver and unit state are major contributors.
This commit also bumps the haddock submodule to reflect the API changes in
UniqMap.
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModulesRecomp
T10421
T10547
T12150
T12234
T12425
T13035
T16875
T18140
T18304
T18698a
T18698b
T18923
T20049
T5837
T6048
T9198
-------------------------
- - - - -
13 changed files:
- compiler/GHC/CmmToAsm/Wasm/Utils.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/JS/Transform.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Printer.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Map.hs
- compiler/GHC/Unit/State.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/CmmToAsm/Wasm/Utils.hs
=====================================
@@ -23,7 +23,7 @@ detEltsUFM :: Ord k => UniqFM k0 (k, a) -> [(k, a)]
detEltsUFM = sortOn fst . nonDetEltsUFM
detEltsUniqMap :: Ord k => UniqMap k a -> [(k, a)]
-detEltsUniqMap = sortOn fst . nonDetEltsUniqMap
+detEltsUniqMap = sortOn fst . nonDetUniqMapToList
builderCommas :: (a -> Builder) -> [a] -> Builder
builderCommas f xs = mconcat (intersperse ", " (map f xs))
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -105,6 +105,7 @@ import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
+import GHC.Types.Unique.Map
import GHC.Types.PkgQual
import GHC.Unit
@@ -129,6 +130,7 @@ import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.Maybe
import Data.Time
+import Data.List (sortOn)
import Data.Bifunctor (first)
import System.Directory
import System.FilePath
@@ -529,7 +531,7 @@ warnUnusedPackages us dflags mod_graph =
guard (Set.notMember (unitId ui) used_args)
return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)
- unusedArgs = mapMaybe resolve (explicitUnits us)
+ unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us)
warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)
@@ -1733,7 +1735,7 @@ checkHomeUnitsClosed ue home_id_set home_imp_ids
loop (from_uid, uid) =
let us = ue_findHomeUnitEnv from_uid ue in
let um = unitInfoMap (homeUnitEnv_units us) in
- case Map.lookup uid um of
+ case lookupUniqMap um uid of
Nothing -> pprPanic "uid not found" (ppr uid)
Just ui ->
let depends = unitDepends ui
=====================================
compiler/GHC/Hs/Doc.hs
=====================================
@@ -224,8 +224,8 @@ instance NFData Docs where
instance Binary Docs where
put_ bh docs = do
put_ bh (docs_mod_hdr docs)
- put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_decls docs)
- put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_args docs)
+ put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs)
+ put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs)
put_ bh (docs_structure docs)
put_ bh (Map.toList $ docs_named_chunks docs)
put_ bh (docs_haddock_opts docs)
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Unique.Set
import GHC.Types.Fixity.Env
+import GHC.Types.Unique.Map
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.State
@@ -558,8 +559,8 @@ checkMergedSignatures hsc_env mod_summary iface = do
let logger = hsc_logger hsc_env
let unit_state = hsc_units hsc_env
let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
- new_merged = case Map.lookup (ms_mod_name mod_summary)
- (requirementContext unit_state) of
+ new_merged = case lookupUniqMap (requirementContext unit_state)
+ (ms_mod_name mod_summary) of
Nothing -> []
Just r -> sort $ map (instModuleToModule unit_state) r
if old_merged == new_merged
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -196,9 +196,9 @@ defRenderJsV r = \case
| isNullUniqMap m -> text "{}"
| otherwise -> braceNest . hsep . punctuate comma .
map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y)
- -- nonDetEltsUniqMap doesn't introduce non-determinism here
+ -- nonDetKeysUniqMap doesn't introduce non-determinism here
-- because we sort the elements lexically
- $ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m)
+ $ sortOn (LexicalFastString . fst) (nonDetUniqMapToList m)
JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
defRenderJsI :: RenderJs -> Ident -> Doc
=====================================
compiler/GHC/JS/Transform.hs
=====================================
@@ -82,7 +82,7 @@ identsV = \case
JInt{} -> []
JStr{} -> []
JRegEx{} -> []
- JHash m -> concatMap (identsE . snd) (nonDetEltsUniqMap m)
+ JHash m -> concatMap identsE (nonDetEltsUniqMap m)
JFunc args s -> args ++ identsS s
UnsatVal{} -> error "identsV: UnsatVal"
@@ -183,7 +183,7 @@ jmcompos ret app f' v =
JHash m -> ret JHash `app` m'
-- nonDetEltsUniqMap doesn't introduce nondeterminism here because the
-- elements are treated independently before being re-added to a UniqMap
- where (ls, vs) = unzip (nonDetEltsUniqMap m)
+ where (ls, vs) = unzip (nonDetUniqMapToList m)
m' = ret (listToUniqMap . zip ls) `app` mapM' f vs
JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s
UnsatVal _ -> ret v'
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -436,7 +436,6 @@ instance Binary Sat.JStat where
n -> error ("Binary get bh JStat: invalid tag: " ++ show n)
-
instance Binary Sat.JExpr where
put_ bh (Sat.ValExpr v) = putByte bh 1 >> put_ bh v
put_ bh (Sat.SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i
@@ -463,7 +462,7 @@ instance Binary Sat.JVal where
put_ bh (Sat.JInt i) = putByte bh 4 >> put_ bh i
put_ bh (Sat.JStr xs) = putByte bh 5 >> put_ bh xs
put_ bh (Sat.JRegEx xs) = putByte bh 6 >> put_ bh xs
- put_ bh (Sat.JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m)
+ put_ bh (Sat.JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m)
put_ bh (Sat.JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s
get bh = getByte bh >>= \case
1 -> Sat.JVar <$> get bh
=====================================
compiler/GHC/StgToJS/Printer.hs
=====================================
@@ -104,7 +104,7 @@ ghcjsRenderJsV r (JHash m)
map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y)
-- nonDetEltsUniqMap doesn't introduce non-determinism here because
-- we sort the elements lexically
- . sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m
+ . sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m
where
quoteIfRequired :: FastString -> Doc
quoteIfRequired x
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -1366,7 +1366,7 @@ zonkAndGroupSkolTvs hole_ty = do
group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)])
group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]]
- skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems)
+ skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetUniqMapToList group_skolems)
{- Note [Adding deferred bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -57,6 +57,7 @@ module GHC.Types.Unique.FM (
mergeUFM,
plusMaybeUFM_C,
plusUFMList,
+ plusUFMListWith,
sequenceUFMList,
minusUFM,
minusUFM_C,
@@ -331,6 +332,9 @@ plusMaybeUFM_C f (UFM xm) (UFM ym)
plusUFMList :: [UniqFM key elt] -> UniqFM key elt
plusUFMList = foldl' plusUFM emptyUFM
+plusUFMListWith :: (elt -> elt -> elt) -> [UniqFM key elt] -> UniqFM key elt
+plusUFMListWith f xs = unsafeIntMapToUFM $ M.unionsWith f (map ufmToIntMap xs)
+
sequenceUFMList :: forall key elt. [UniqFM key elt] -> UniqFM key [elt]
sequenceUFMList = foldr (plusUFM_CD2 cons) emptyUFM
where
=====================================
compiler/GHC/Types/Unique/Map.hs
=====================================
@@ -30,20 +30,25 @@ module GHC.Types.Unique.Map (
plusUniqMap_C,
plusMaybeUniqMap_C,
plusUniqMapList,
+ plusUniqMapListWith,
minusUniqMap,
intersectUniqMap,
intersectUniqMap_C,
disjointUniqMap,
mapUniqMap,
filterUniqMap,
+ filterWithKeyUniqMap,
partitionUniqMap,
sizeUniqMap,
elemUniqMap,
+ nonDetKeysUniqMap,
+ nonDetEltsUniqMap,
lookupUniqMap,
lookupWithDefaultUniqMap,
anyUniqMap,
allUniqMap,
- nonDetEltsUniqMap,
+ nonDetUniqMapToList,
+ nonDetUniqMapToKeySet,
nonDetFoldUniqMap
-- Non-deterministic functions omitted
) where
@@ -61,6 +66,8 @@ import Data.Maybe
import Data.Data
import Control.DeepSeq
+import Data.Set (Set, fromList)
+
-- | Maps indexed by 'Uniquable' keys
newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) }
deriving (Data, Eq, Functor)
@@ -192,6 +199,13 @@ plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $
plusUniqMapList :: [UniqMap k a] -> UniqMap k a
plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)
+plusUniqMapListWith :: (a -> a -> a) -> [UniqMap k a] -> UniqMap k a
+plusUniqMapListWith f xs = UniqMap $ plusUFMListWith go (coerce xs)
+ where
+ -- l and r keys will be identical so we choose the former
+ go (l_key, l) (_r, r) = (l_key, f l r)
+{-# INLINE plusUniqMapListWith #-}
+
minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a
minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2
@@ -201,6 +215,7 @@ intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2
-- | Intersection with a combining function.
intersectUniqMap_C :: (a -> b -> c) -> UniqMap k a -> UniqMap k b -> UniqMap k c
intersectUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM_C (\(k, a) (_, b) -> (k, f a b)) m1 m2
+{-# INLINE intersectUniqMap #-}
disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool
disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2
@@ -211,6 +226,9 @@ mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance
filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a
filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m
+filterWithKeyUniqMap :: (k -> a -> Bool) -> UniqMap k a -> UniqMap k a
+filterWithKeyUniqMap f (UniqMap m) = UniqMap $ filterUFM (uncurry f) m
+
partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)
partitionUniqMap f (UniqMap m) =
coerce $ partitionUFM (f . snd) m
@@ -233,8 +251,21 @@ anyUniqMap f (UniqMap m) = anyUFM (f . snd) m
allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool
allUniqMap f (UniqMap m) = allUFM (f . snd) m
-nonDetEltsUniqMap :: UniqMap k a -> [(k, a)]
-nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m
+nonDetUniqMapToList :: UniqMap k a -> [(k, a)]
+nonDetUniqMapToList (UniqMap m) = nonDetEltsUFM m
+{-# INLINE nonDetUniqMapToList #-}
+
+nonDetUniqMapToKeySet :: Ord k => UniqMap k a -> Set k
+nonDetUniqMapToKeySet m = fromList (nonDetKeysUniqMap m)
+
+nonDetKeysUniqMap :: UniqMap k a -> [k]
+nonDetKeysUniqMap m = map fst (nonDetUniqMapToList m)
+{-# INLINE nonDetKeysUniqMap #-}
+
+nonDetEltsUniqMap :: UniqMap k a -> [a]
+nonDetEltsUniqMap m = map snd (nonDetUniqMapToList m)
+{-# INLINE nonDetEltsUniqMap #-}
nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b
nonDetFoldUniqMap go z (UniqMap m) = nonDetFoldUFM go z m
+{-# INLINE nonDetFoldUniqMap #-}
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -91,6 +91,8 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSet
+import GHC.Types.Unique.Map
+import GHC.Types.Unique
import GHC.Types.PkgQual
import GHC.Utils.Misc
@@ -110,13 +112,10 @@ import System.FilePath as FilePath
import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
-import Data.List ( intersperse, partition, sortBy, isSuffixOf )
-import Data.Map (Map)
+import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
import Data.Set (Set)
import Data.Monoid (First(..))
import qualified Data.Semigroup as Semigroup
-import qualified Data.Map as Map
-import qualified Data.Map.Strict as MapStrict
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
@@ -260,7 +259,7 @@ originEmpty _ = False
type PreloadUnitClosure = UniqSet UnitId
-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.
-type VisibilityMap = Map Unit UnitVisibility
+type VisibilityMap = UniqMap Unit UnitVisibility
-- | 'UnitVisibility' records the various aspects of visibility of a particular
-- 'Unit'.
@@ -274,7 +273,7 @@ data UnitVisibility = UnitVisibility
-- ^ The package name associated with the 'Unit'. This is used
-- to implement legacy behavior where @-package foo-0.1@ implicitly
-- hides any packages named @foo@
- , uv_requirements :: Map ModuleName (Set InstantiatedModule)
+ , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
-- ^ The signatures which are contributed to the requirements context
-- from this unit ID.
, uv_explicit :: Maybe PackageArg
@@ -298,7 +297,7 @@ instance Semigroup UnitVisibility where
{ uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
, uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
, uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
- , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
+ , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1)
, uv_explicit = uv_explicit uv1 <|> uv_explicit uv2
}
@@ -307,7 +306,7 @@ instance Monoid UnitVisibility where
{ uv_expose_all = False
, uv_renamings = []
, uv_package_name = First Nothing
- , uv_requirements = Map.empty
+ , uv_requirements = emptyUniqMap
, uv_explicit = Nothing
}
mappend = (Semigroup.<>)
@@ -407,7 +406,7 @@ initUnitConfig dflags cached_dbs home_units =
-- origin for a given 'Module'
type ModuleNameProvidersMap =
- Map ModuleName (Map Module ModuleOrigin)
+ UniqMap ModuleName (UniqMap Module ModuleOrigin)
data UnitState = UnitState {
-- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted
@@ -431,10 +430,10 @@ data UnitState = UnitState {
packageNameMap :: UniqFM PackageName UnitId,
-- | A mapping from database unit keys to wired in unit ids.
- wireMap :: Map UnitId UnitId,
+ wireMap :: UniqMap UnitId UnitId,
-- | A mapping from wired in unit ids to unit keys from the database.
- unwireMap :: Map UnitId UnitId,
+ unwireMap :: UniqMap UnitId UnitId,
-- | The units we're going to link in eagerly. This list
-- should be in reverse dependency order; that is, a unit
@@ -464,7 +463,7 @@ data UnitState = UnitState {
-- and @r[C=\<A>]:C at .
--
-- There's an entry in this map for each hole in our home library.
- requirementContext :: Map ModuleName [InstantiatedModule],
+ requirementContext :: UniqMap ModuleName [InstantiatedModule],
-- | Indicate if we can instantiate units on-the-fly.
--
@@ -475,17 +474,17 @@ data UnitState = UnitState {
emptyUnitState :: UnitState
emptyUnitState = UnitState {
- unitInfoMap = Map.empty,
+ unitInfoMap = emptyUniqMap,
preloadClosure = emptyUniqSet,
packageNameMap = emptyUFM,
- wireMap = Map.empty,
- unwireMap = Map.empty,
- preloadUnits = [],
- explicitUnits = [],
+ wireMap = emptyUniqMap,
+ unwireMap = emptyUniqMap,
+ preloadUnits = [],
+ explicitUnits = [],
homeUnitDepends = [],
- moduleNameProvidersMap = Map.empty,
- pluginModuleNameProvidersMap = Map.empty,
- requirementContext = Map.empty,
+ moduleNameProvidersMap = emptyUniqMap,
+ pluginModuleNameProvidersMap = emptyUniqMap,
+ requirementContext = emptyUniqMap,
allowVirtualUnits = False
}
@@ -498,7 +497,7 @@ data UnitDatabase unit = UnitDatabase
instance Outputable u => Outputable (UnitDatabase u) where
ppr (UnitDatabase fp _u) = text "DB:" <+> text fp
-type UnitInfoMap = Map UnitId UnitInfo
+type UnitInfoMap = UniqMap UnitId UnitInfo
-- | Find the unit we know about with the given unit, if any
lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
@@ -514,20 +513,20 @@ lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (prelo
lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of
HoleUnit -> error "Hole unit"
- RealUnit i -> Map.lookup (unDefinite i) pkg_map
+ RealUnit i -> lookupUniqMap pkg_map (unDefinite i)
VirtUnit i
| allowOnTheFlyInst
-> -- lookup UnitInfo of the indefinite unit to be instantiated and
-- instantiate it on-the-fly
fmap (renameUnitInfo pkg_map closure (instUnitInsts i))
- (Map.lookup (instUnitInstanceOf i) pkg_map)
+ (lookupUniqMap pkg_map (instUnitInstanceOf i))
| otherwise
-> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite
-- units. Even if they are real, installed units, they can't use the
-- `RealUnit` constructor (it is reserved for definite units) so we use
-- the `VirtUnit` constructor.
- Map.lookup (virtualUnitId i) pkg_map
+ lookupUniqMap pkg_map (virtualUnitId i)
-- | Find the unit we know about with the given unit id, if any
lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
@@ -535,7 +534,7 @@ lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid
-- | Find the unit we know about with the given unit id, if any
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
-lookupUnitId' db uid = Map.lookup uid db
+lookupUnitId' db uid = lookupUniqMap db uid
-- | Looks up the given unit in the unit state, panicking if it is not found
@@ -569,12 +568,12 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
resolvePackageImport unit_st mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- Map.filter originVisible <$> Map.lookup mn (moduleNameProvidersMap unit_st)
+ providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
-- 2. Get the UnitIds of the candidates
- let candidates_uid = concatMap to_uid $ Map.assocs providers
+ let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
let candidates_units = map (\ui -> ((unitPackageName ui), unitId ui))
- $ mapMaybe (\uid -> Map.lookup uid (unitInfoMap unit_st)) candidates_uid
+ $ mapMaybe (\uid -> lookupUniqMap (unitInfoMap unit_st) uid) candidates_uid
-- 4. Check to see if the PackageName helps us disambiguate any candidates.
lookup pn candidates_units
@@ -600,23 +599,22 @@ resolvePackageImport unit_st mn pn = do
-- with module holes).
--
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
-mkUnitInfoMap infos = foldl' add Map.empty infos
+mkUnitInfoMap infos = foldl' add emptyUniqMap infos
where
mkVirt p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p))
add pkg_map p
| not (null (unitInstantiations p))
- = Map.insert (mkVirt p) p
- $ Map.insert (unitId p) p
- $ pkg_map
+ = addToUniqMap (addToUniqMap pkg_map (mkVirt p) p)
+ (unitId p) p
| otherwise
- = Map.insert (unitId p) p pkg_map
+ = addToUniqMap pkg_map (unitId p) p
-- | Get a list of entries from the unit database. NB: be careful with
-- this function, although all units in this map are "visible", this
-- does not imply that the exposed-modules of the unit are available
-- (they may have been thinned or renamed).
listUnitInfo :: UnitState -> [UnitInfo]
-listUnitInfo state = Map.elems (unitInfoMap state)
+listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- ----------------------------------------------------------------------------
-- Loading the unit db files and building up the unit state
@@ -904,20 +902,20 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
-- This method is responsible for computing what our
-- inherited requirements are.
reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
- | otherwise = Map.empty
+ | otherwise = emptyUniqMap
collectHoles uid = case uid of
- HoleUnit -> Map.empty
- RealUnit {} -> Map.empty -- definite units don't have holes
+ HoleUnit -> emptyUniqMap
+ RealUnit {} -> emptyUniqMap -- definite units don't have holes
VirtUnit indef ->
- let local = [ Map.singleton
+ let local = [ unitUniqMap
(moduleName mod)
(Set.singleton $ Module indef mod_name)
| (mod_name, mod) <- instUnitInsts indef
, isHoleModule mod ]
recurse = [ collectHoles (moduleUnit mod)
| (_, mod) <- instUnitInsts indef ]
- in Map.unionsWith Set.union $ local ++ recurse
+ in plusUniqMapListWith Set.union $ local ++ recurse
uv = UnitVisibility
{ uv_expose_all = b
@@ -926,7 +924,7 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
, uv_requirements = reqs
, uv_explicit = Just arg
}
- vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared
+ vm' = addToUniqMap_C mappend vm_cleared (mkUnit p) uv
-- 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),
-- the second package flag would override the first one and you
@@ -950,7 +948,7 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
vm_cleared | no_hide_others = vm
-- NB: renamings never clear
| (_:_) <- rns = vm
- | otherwise = Map.filterWithKey
+ | otherwise = filterWithKeyUniqMap
(\k uv -> k == mkUnit p
|| First (Just n) /= uv_package_name uv) vm
_ -> panic "applyPackageFlag"
@@ -958,7 +956,7 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
HidePackage str ->
case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of
Left ps -> Failed (PackageFlagErr flag ps)
- Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps)
+ Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps)
-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages. Furthermore, any packages it returns are *renamed*
@@ -974,7 +972,7 @@ findPackages prec_map pkg_map closure arg pkgs unusable
= let ps = mapMaybe (finder arg) pkgs
in if null ps
then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
- (Map.elems unusable))
+ (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps)
where
finder (PackageArg str) p
@@ -999,7 +997,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (Map.elems unusable))
+ then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1053,8 +1051,8 @@ compareByPreference
compareByPreference prec_map pkg pkg'
= case comparing unitPackageVersion pkg pkg' of
GT -> GT
- EQ | Just prec <- Map.lookup (unitId pkg) prec_map
- , Just prec' <- Map.lookup (unitId pkg') prec_map
+ EQ | Just prec <- lookupUniqMap prec_map (unitId pkg)
+ , Just prec' <- lookupUniqMap prec_map (unitId pkg')
-- Prefer the unit from the later DB flag (i.e., higher
-- precedence)
-> compare prec prec'
@@ -1080,7 +1078,7 @@ pprTrustFlag flag = case flag of
--
-- See Note [Wired-in units] in GHC.Unit.Types
-type WiringMap = Map UnitId UnitId
+type WiringMap = UniqMap UnitId UnitId
findWiredInUnits
:: Logger
@@ -1120,7 +1118,7 @@ findWiredInUnits logger prec_map pkgs vis_map = do
findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound]
where
all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
- all_exposed_ps = [ p | p <- all_ps, Map.member (mkUnit p) vis_map ]
+ all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ]
try ps = case sortByPreference prec_map ps of
p:_ -> Just <$> pick p
@@ -1146,8 +1144,8 @@ findWiredInUnits logger prec_map pkgs vis_map = do
let
wired_in_pkgs = catMaybes mb_wired_in_pkgs
- wiredInMap :: Map UnitId UnitId
- wiredInMap = Map.fromList
+ wiredInMap :: UniqMap UnitId UnitId
+ wiredInMap = listToUniqMap
[ (unitId realUnitInfo, wiredInUnitId)
| (wiredInUnitId, realUnitInfo) <- wired_in_pkgs
, not (unitIsIndefinite realUnitInfo)
@@ -1155,7 +1153,7 @@ findWiredInUnits logger prec_map pkgs vis_map = do
updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
where upd_pkg pkg
- | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap
+ | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg)
= pkg { unitId = wiredInUnitId
, unitInstanceOf = wiredInUnitId
-- every non instantiated unit is an instance of
@@ -1196,18 +1194,17 @@ upd_wired_in_uid wiredInMap u = case u of
upd_wired_in :: WiringMap -> UnitId -> UnitId
upd_wired_in wiredInMap key
- | Just key' <- Map.lookup key wiredInMap = key'
+ | Just key' <- lookupUniqMap wiredInMap key = key'
| otherwise = key
updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
-updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
- where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of
+updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap)
+ where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of
Nothing -> vm
- Just r -> Map.insert (RealUnit (Definite to)) r
- (Map.delete (RealUnit (Definite from)) vm)
+ Just r -> addToUniqMap (delFromUniqMap vm (RealUnit (Definite from)))
+ (RealUnit (Definite to)) r
-
--- ----------------------------------------------------------------------------
+ -- ----------------------------------------------------------------------------
-- | The reason why a unit is unusable.
data UnusableUnitReason
@@ -1234,7 +1231,7 @@ instance Outputable UnusableUnitReason where
ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids)
ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
-type UnusableUnits = Map UnitId (UnitInfo, UnusableUnitReason)
+type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason)
pprReason :: SDoc -> UnusableUnitReason -> SDoc
pprReason pref reason = case reason of
@@ -1264,7 +1261,7 @@ reportCycles logger sccs = mapM_ report sccs
nest 2 (hsep (map (ppr . unitId) vs))
reportUnusable :: Logger -> UnusableUnits -> IO ()
-reportUnusable logger pkgs = mapM_ report (Map.toList pkgs)
+reportUnusable logger pkgs = mapM_ report (nonDetUniqMapToList pkgs)
where
report (ipid, (_, reason)) =
debugTraceMsg logger 2 $
@@ -1278,14 +1275,15 @@ reportUnusable logger pkgs = mapM_ report (Map.toList pkgs)
-- | A reverse dependency index, mapping an 'UnitId' to
-- the 'UnitId's which have a dependency on it.
-type RevIndex = Map UnitId [UnitId]
+type RevIndex = UniqMap UnitId [UnitId]
-- | Compute the reverse dependency index of a unit database.
reverseDeps :: UnitInfoMap -> RevIndex
-reverseDeps db = Map.foldl' go Map.empty db
+reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db
where
- go r pkg = foldl' (go' (unitId pkg)) r (unitDepends pkg)
- go' from r to = Map.insertWith (++) to [from] r
+ go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex
+ go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg)
+ go' from r to = addToUniqMap_C (++) r to [from]
-- | Given a list of 'UnitId's to remove, a database,
-- and a reverse dependency index (as computed by 'reverseDeps'),
@@ -1299,10 +1297,10 @@ removeUnits uids index m = go uids (m,[])
where
go [] (m,pkgs) = (m,pkgs)
go (uid:uids) (m,pkgs)
- | Just pkg <- Map.lookup uid m
- = case Map.lookup uid index of
- Nothing -> go uids (Map.delete uid m, pkg:pkgs)
- Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs)
+ | Just pkg <- lookupUniqMap m uid
+ = case lookupUniqMap index uid of
+ Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs)
+ Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs)
| otherwise
= go uids (m,pkgs)
@@ -1311,7 +1309,7 @@ removeUnits uids index m = go uids (m,[])
depsNotAvailable :: UnitInfoMap
-> UnitInfo
-> [UnitId]
-depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepends pkg)
+depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg)
-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in
-- 'unitAbiDepends' which correspond to units that do not exist, OR have
@@ -1322,7 +1320,7 @@ depsAbiMismatch :: UnitInfoMap
depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg
where
abiMatch (dep_uid, abi)
- | Just dep_pkg <- Map.lookup dep_uid pkg_map
+ | Just dep_pkg <- lookupUniqMap pkg_map dep_uid
= unitAbiHash dep_pkg == abi
| otherwise
= False
@@ -1331,7 +1329,7 @@ depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends
-- Ignore units
ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
-ignoreUnits flags pkgs = Map.fromList (concatMap doit flags)
+ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags)
where
doit (IgnorePackage str) =
case partition (matchingStr str) pkgs of
@@ -1351,7 +1349,7 @@ ignoreUnits flags pkgs = Map.fromList (concatMap doit flags)
-- the command line. We use this mapping to make sure we prefer
-- units that were defined later on the command line, if there
-- is an ambiguity.
-type UnitPrecedenceMap = Map UnitId Int
+type UnitPrecedenceMap = UniqMap UnitId Int
-- | Given a list of databases, merge them together, where
-- units with the same unit id in later databases override
@@ -1359,7 +1357,7 @@ type UnitPrecedenceMap = Map UnitId Int
-- makes sense (that's done by 'validateDatabase').
mergeDatabases :: Logger -> [UnitDatabase UnitId]
-> IO (UnitInfoMap, UnitPrecedenceMap)
-mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..]
+mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]
where
merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
debugTraceMsg logger 2 $
@@ -1371,22 +1369,22 @@ mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..]
return (pkg_map', prec_map')
where
db_map = mk_pkg_map db
- mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))
+ mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p))
-- The set of UnitIds which appear in both db and pkgs. These are the
-- ones that get overridden. Compute this just to give some
-- helpful debug messages at -v2
override_set :: Set UnitId
- override_set = Set.intersection (Map.keysSet db_map)
- (Map.keysSet pkg_map)
+ override_set = Set.intersection (nonDetUniqMapToKeySet db_map)
+ (nonDetUniqMapToKeySet pkg_map)
-- Now merge the sets together (NB: in case of duplicate,
-- first argument preferred)
pkg_map' :: UnitInfoMap
- pkg_map' = Map.union db_map pkg_map
+ pkg_map' = pkg_map `plusUniqMap` db_map
prec_map' :: UnitPrecedenceMap
- prec_map' = Map.union (Map.map (const i) db_map) prec_map
+ prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map)
-- | Validates a database, removing unusable units from it
-- (this includes removing units that the user has explicitly
@@ -1409,39 +1407,45 @@ validateDatabase cfg pkg_map1 =
-- Helper function
mk_unusable mk_err dep_matcher m uids =
- Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
- | pkg <- uids ]
+ listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
+ | pkg <- uids
+ ]
-- Find broken units
directly_broken = filter (not . null . depsNotAvailable pkg_map1)
- (Map.elems pkg_map1)
+ (nonDetEltsUniqMap pkg_map1)
(pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1
unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken
-- Find recursive units
sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)
- | pkg <- Map.elems pkg_map2 ]
+ | pkg <- nonDetEltsUniqMap pkg_map2 ]
getCyclicSCC (CyclicSCC vs) = map unitId vs
getCyclicSCC (AcyclicSCC _) = []
(pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2
unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
-- Apply ignore flags
- directly_ignored = ignoreUnits ignore_flags (Map.elems pkg_map3)
- (pkg_map4, ignored) = removeUnits (Map.keys directly_ignored) index pkg_map3
+ directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3)
+ (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3
unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored
-- Knock out units whose dependencies don't agree with ABI
-- (i.e., got invalidated due to shadowing)
directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)
- (Map.elems pkg_map4)
+ (nonDetEltsUniqMap pkg_map4)
(pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4
unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed
- unusable = directly_ignored `Map.union` unusable_ignored
- `Map.union` unusable_broken
- `Map.union` unusable_cyclic
- `Map.union` unusable_shadowed
+ -- combine all unusables. The order is important for shadowing.
+ -- plusUniqMapList folds using plusUFM which is right biased (opposite of
+ -- Data.Map.union) so the head of the list should be the least preferred
+ unusable = plusUniqMapList [ unusable_shadowed
+ , unusable_cyclic
+ , unusable_broken
+ , unusable_ignored
+ , directly_ignored
+ ]
-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our unit
@@ -1540,7 +1544,7 @@ mkUnitState logger cfg = do
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
$ foldM (applyTrustFlag prec_map unusable)
- (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
let prelim_pkg_db = mkUnitInfoMap pkgs1
--
@@ -1580,17 +1584,16 @@ mkUnitState logger cfg = do
-- default, because it's almost assuredly not
-- what you want (no mix-in linking has occurred).
if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then Map.insert (mkUnit p)
+ then addToUniqMap vm (mkUnit p)
UnitVisibility {
uv_expose_all = True,
uv_renamings = [],
uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = Map.empty,
+ uv_requirements = emptyUniqMap,
uv_explicit = Nothing
}
- vm
else vm)
- Map.empty pkgs1
+ emptyUniqMap pkgs1
--
-- Compute a visibility map according to the command-line flags (-package,
@@ -1618,9 +1621,9 @@ mkUnitState logger cfg = do
case unitConfigFlagsPlugins cfg of
-- common case; try to share the old vis_map
[] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return Map.empty
+ | otherwise -> return emptyUniqMap
_ -> do let plugin_vis_map1
- | hide_plugin_pkgs = Map.empty
+ | hide_plugin_pkgs = emptyUniqMap
-- Use the vis_map PRIOR to wired in,
-- because otherwise applyPackageFlag
-- won't work.
@@ -1649,9 +1652,9 @@ mkUnitState logger cfg = do
-- The requirement context is directly based off of this: we simply
-- look for nested unit IDs that are directly fed holes: the requirements
-- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- Map.toList vis_map]
- req_ctx = Map.map (Set.toList)
- $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
--
@@ -1664,11 +1667,11 @@ mkUnitState logger cfg = do
-- NB: preload IS important even for type-checking, because we
-- need the correct include path to be set.
--
- let preload1 = Map.keys (Map.filter (isJust . uv_explicit) vis_map)
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-- add default preload units if they can be found in the db
basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip Map.member pkg_db)
+ $ filter (flip elemUniqMap pkg_db)
$ unitConfigAutoLink cfg
preload3 = ordNub $ (basicLinkedUnits ++ preload1)
@@ -1679,7 +1682,7 @@ mkUnitState logger cfg = do
let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = Map.union mod_map1 mod_map2
+ mod_map = mod_map2 `plusUniqMap` mod_map1
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1692,7 +1695,7 @@ mkUnitState logger cfg = do
, pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
, packageNameMap = pkgname_map
, wireMap = wired_map
- , unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]
+ , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
, requirementContext = req_ctx
, allowVirtualUnits = unitConfigAllowVirtual cfg
}
@@ -1715,7 +1718,7 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags
-- that it was recorded as in the package database.
unwireUnit :: UnitState -> Unit -> Unit
unwireUnit state uid@(RealUnit (Definite def_uid)) =
- maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state))
+ maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid)
unwireUnit _ uid = uid
-- -----------------------------------------------------------------------------
@@ -1750,36 +1753,35 @@ mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =
-- entries for every definite (for non-Backpack) and
-- indefinite (for Backpack) package, so that we get the
-- hidden entries we need.
- Map.foldlWithKey extend_modmap emptyMap vis_map_extended
+ nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended
where
- vis_map_extended = Map.union vis_map {- preferred -} default_vis
+ vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map
- default_vis = Map.fromList
+ default_vis = listToUniqMap
[ (mkUnit pkg, mempty)
- | pkg <- Map.elems pkg_map
+ | (_, pkg) <- nonDetUniqMapToList pkg_map
-- Exclude specific instantiations of an indefinite
-- package
, unitIsIndefinite pkg || null (unitInstantiations pkg)
]
- emptyMap = Map.empty
+ emptyMap = emptyUniqMap
setOrigins m os = fmap (const os) m
- extend_modmap modmap uid
- UnitVisibility { uv_expose_all = b, uv_renamings = rns }
+ extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap
= addListTo modmap theBindings
where
pkg = unit_lookup uid
- theBindings :: [(ModuleName, Map Module ModuleOrigin)]
+ theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
theBindings = newBindings b rns
newBindings :: Bool
-> [(ModuleName, ModuleName)]
- -> [(ModuleName, Map Module ModuleOrigin)]
+ -> [(ModuleName, UniqMap Module ModuleOrigin)]
newBindings e rns = es e ++ hiddens ++ map rnBinding rns
rnBinding :: (ModuleName, ModuleName)
- -> (ModuleName, Map Module ModuleOrigin)
+ -> (ModuleName, UniqMap Module ModuleOrigin)
rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
where origEntry = case lookupUFM esmap orig of
Just r -> r
@@ -1788,7 +1790,7 @@ mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =
(text "package flag: could not find module name" <+>
ppr orig <+> text "in package" <+> ppr pk)))
- es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
+ es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]
es e = do
(m, exposedReexport) <- exposed_mods
let (pk', m', origin') =
@@ -1798,7 +1800,7 @@ mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =
(pk', m', fromReexportedModules e pkg)
return (m, mkModMap pk' m' origin')
- esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
+ esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin)
esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
-- be overwritten
@@ -1814,10 +1816,10 @@ mkModuleNameProvidersMap logger cfg pkg_map closure vis_map =
-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages.
mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap unusables =
- Map.foldl' extend_modmap Map.empty unusables
+ nonDetFoldUniqMap extend_modmap emptyUniqMap unusables
where
- extend_modmap modmap (pkg, reason) = addListTo modmap bindings
- where bindings :: [(ModuleName, Map Module ModuleOrigin)]
+ extend_modmap (_uid, (pkg, reason)) modmap = addListTo modmap bindings
+ where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
bindings = exposed ++ hidden
origin = ModUnusable reason
@@ -1826,7 +1828,7 @@ mkUnusableModuleNameProvidersMap unusables =
exposed = map get_exposed exposed_mods
hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods]
- get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin)
+ get_exposed (mod, Just mod') = (mod, unitUniqMap mod' origin)
get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin)
exposed_mods = unitExposedModules pkg
@@ -1837,16 +1839,16 @@ mkUnusableModuleNameProvidersMap unusables =
-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
-- when reloading modules in GHCi (see #4029). This ensures that each
-- value is forced before installing into the map.
-addListTo :: (Monoid a, Ord k1, Ord k2)
- => Map k1 (Map k2 a)
- -> [(k1, Map k2 a)]
- -> Map k1 (Map k2 a)
+addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2)
+ => UniqMap k1 (UniqMap k2 a)
+ -> [(k1, UniqMap k2 a)]
+ -> UniqMap k1 (UniqMap k2 a)
addListTo = foldl' merge
- where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
+ where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v
-- | Create a singleton module mapping
-mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
-mkModMap pkg mod = Map.singleton (mkModule pkg mod)
+mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
+mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- -----------------------------------------------------------------------------
@@ -1924,10 +1926,10 @@ lookupModuleWithSuggestions' :: UnitState
-> PkgQual
-> LookupResult
lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case Map.lookup m mod_map of
+ = case lookupUniqMap mod_map m of
Nothing -> LookupNotFound suggestions
Just xs ->
- case foldl' classify ([],[],[], []) (Map.toList xs) of
+ case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
([], [], [], []) -> LookupNotFound suggestions
(_, _, _, [(m, o)]) -> LookupFound m (mod_unit m, o)
(_, _, _, exposed@(_:_)) -> LookupMultiple exposed
@@ -1985,8 +1987,8 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- Map.toList (moduleNameProvidersMap pkgs)
- , suggestion <- map (getSuggestion m) (Map.toList e)
+ | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
@@ -1994,8 +1996,8 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
listVisibleModuleNames :: UnitState -> [ModuleName]
listVisibleModuleNames state =
- map fst (filter visible (Map.toList (moduleNameProvidersMap state)))
- where visible (_, ms) = any originVisible (Map.elems ms)
+ map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+ where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
-- messages), and returns the list with dependencies included, in reverse
@@ -2006,7 +2008,7 @@ closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps
-- | Similar to closeUnitDeps but takes a list of already loaded units as an
-- additional argument.
closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
-closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps
+closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps
-- | Add a UnitId and those it depends on (recursively) to the given list of
-- UnitIds if they are not already in it. Return a list in reverse dependency
@@ -2017,9 +2019,10 @@ closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps
-- error message ("dependency of <PARENT>").
add_unit :: UnitInfoMap
-> [UnitId]
- -> (UnitId,Maybe UnitId)
+ -> UnitId
+ -> Maybe UnitId
-> MaybeErr UnitErr [UnitId]
-add_unit pkg_map ps (p, mb_parent)
+add_unit pkg_map ps p mb_parent
| p `elem` ps = return ps -- Check if we've already added this unit
| otherwise = case lookupUnitId' pkg_map p of
Nothing -> Failed (CloseUnitErr p mb_parent)
@@ -2028,8 +2031,8 @@ add_unit pkg_map ps (p, mb_parent)
ps' <- foldM add_unit_key ps (unitDepends info)
return (p : ps')
where
- add_unit_key ps key
- = add_unit pkg_map ps (key, Just p)
+ add_unit_key xs key
+ = add_unit pkg_map xs key (Just p)
data UnitErr
= CloseUnitErr !UnitId !(Maybe UnitId)
@@ -2073,7 +2076,7 @@ instance Outputable UnitErr where
-- to form @mod_name@, or @[]@ if this is not a requirement.
requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges pkgstate mod_name =
- fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))
+ fromMaybe [] (lookupUniqMap (requirementContext pkgstate) mod_name)
-- -----------------------------------------------------------------------------
@@ -2128,9 +2131,9 @@ pprUnitsSimple = pprUnitsWith pprIPI
-- | Show the mapping of modules to where they come from.
pprModuleMap :: ModuleNameProvidersMap -> SDoc
pprModuleMap mod_map =
- vcat (map pprLine (Map.toList mod_map))
+ vcat (map pprLine (nonDetUniqMapToList mod_map))
where
- pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
+ pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e)))
pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
pprEntry m (m',o)
| m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o)
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit d19850b8046876e92dfef045d8a5558b951f1650
+Subproject commit 03ba53ca764f56a13d12607c110f923f129e809a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b5be05ac29e2ec033e108e15f052f2a13898f24
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b5be05ac29e2ec033e108e15f052f2a13898f24
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230401/4b94b378/attachment-0001.html>
More information about the ghc-commits
mailing list