diff options
author | doyougnu <jeffrey.young@iohk.io> | 2023-01-10 16:16:31 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-04-01 09:42:31 -0400 |
commit | 3b5be05ac29e2ec033e108e15f052f2a13898f24 (patch) | |
tree | 90e35651a8a977374af3b5c78c7c944ca1bfee0b /compiler | |
parent | 77c33fb924d75f502e275c7afbf157e6d963abf4 (diff) | |
download | haskell-3b5be05ac29e2ec033e108e15f052f2a13898f24.tar.gz |
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
-------------------------
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/CmmToAsm/Wasm/Utils.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Hs/Doc.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Iface/Recomp.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/JS/Ppr.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/JS/Transform.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToJS/Object.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/StgToJS/Printer.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Types/Unique/FM.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Types/Unique/Map.hs | 37 | ||||
-rw-r--r-- | compiler/GHC/Unit/State.hs | 285 |
12 files changed, 199 insertions, 159 deletions
diff --git a/compiler/GHC/CmmToAsm/Wasm/Utils.hs b/compiler/GHC/CmmToAsm/Wasm/Utils.hs index 61dfc9bfb2..851a95b382 100644 --- a/compiler/GHC/CmmToAsm/Wasm/Utils.hs +++ b/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)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 0e3348fd45..0d0df0dd1b 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/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 diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 38271e3681..70d0ee3638 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/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) diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index ec587318f4..2e1150910b 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/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 diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs index bb1acd9f51..9315156eeb 100644 --- a/compiler/GHC/JS/Ppr.hs +++ b/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 diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs index 9051c04fbf..0fe2389aea 100644 --- a/compiler/GHC/JS/Transform.hs +++ b/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' diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs index ec4abcaf50..168784ab81 100644 --- a/compiler/GHC/StgToJS/Object.hs +++ b/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 diff --git a/compiler/GHC/StgToJS/Printer.hs b/compiler/GHC/StgToJS/Printer.hs index f6d5c5cec9..03d224f0f9 100644 --- a/compiler/GHC/StgToJS/Printer.hs +++ b/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 diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 8d5ac3a227..60f87f2bc7 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 2da9aad3cb..f610582a1a 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/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 diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index 6bfe5bb5ff..d285c7ad1a 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/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 #-} diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index a72f53b366..f5aeb65216 100644 --- a/compiler/GHC/Unit/State.hs +++ b/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@. -- -- 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) |