From ddbb211eb3625cfbc8fe5a7f55fef1ee2cea34d8 Mon Sep 17 00:00:00 2001 From: Josh Meredith Date: Mon, 24 Apr 2023 18:00:18 +0000 Subject: Refactor `Set UnitId` to `UniqDSet UnitId` (#23335) --- compiler/GHC.hs | 9 ++++----- compiler/GHC/Driver/CodeOutput.hs | 9 ++++----- compiler/GHC/Driver/Env.hs | 2 +- compiler/GHC/Driver/Main.hs | 28 ++++++++++++++-------------- compiler/GHC/Driver/Make.hs | 34 ++++++++++++++++++---------------- compiler/GHC/Driver/Pipeline.hs | 9 +++++---- compiler/GHC/HsToCore/Usage.hs | 6 +++--- compiler/GHC/Iface/Load.hs | 2 +- compiler/GHC/Iface/Recomp.hs | 7 ++++--- compiler/GHC/Linker/Loader.hs | 28 ++++++++++++++-------------- compiler/GHC/Linker/Types.hs | 5 ++--- compiler/GHC/Rename/Names.hs | 17 +++++++++-------- compiler/GHC/Tc/Module.hs | 4 ++-- compiler/GHC/Tc/Types.hs | 9 +++++---- compiler/GHC/Types/Unique/DSet.hs | 11 +++++++++++ compiler/GHC/Unit/Env.hs | 7 ++++--- compiler/GHC/Unit/Module/Deps.hs | 34 +++++++++++++++++++--------------- compiler/GHC/Unit/Module/ModGuts.hs | 4 +--- compiler/GHC/Unit/State.hs | 28 ++++++++++++++-------------- compiler/GHC/Unit/Types.hs | 3 +++ ghc/GHCi/UI.hs | 18 +++++++++--------- 21 files changed, 147 insertions(+), 127 deletions(-) diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 0182b5a2a1..ac9b42202e 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -395,6 +395,7 @@ import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -418,8 +419,6 @@ import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.Sequence as Seq import System.Directory @@ -604,7 +603,7 @@ setSessionDynFlags dflags0 = do logger <- getLogger dflags <- checkNewDynFlags logger dflags0 let all_uids = hsc_all_home_unit_ids hsc_env - case S.toList all_uids of + case uniqDSetToList all_uids of [uid] -> do setUnitDynFlagsNoCheck uid dflags modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) @@ -1379,7 +1378,7 @@ data ModuleInfo = ModuleInfo { -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env + if moduleUnitId mdl `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env then liftIO $ getHomeModuleInfo hsc_env mdl else liftIO $ getPackageModuleInfo hsc_env mdl @@ -1756,7 +1755,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, UnitIdSet) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index c5c0534d20..2b4d569710 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -56,12 +56,11 @@ import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) +import GHC.Types.Unique.DSet import System.Directory import System.FilePath import System.IO -import Data.Set (Set) -import qualified Data.Set as Set {- ************************************************************************ @@ -84,7 +83,7 @@ codeOutput -> (a -> ForeignStubs) -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with the C compiler - -> Set UnitId -- ^ Dependencies + -> UnitIdSet -- ^ Dependencies -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), @@ -161,11 +160,11 @@ outputC :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a - -> Set UnitId + -> UnitIdSet -> IO a outputC logger dflags filenm cmm_stream unit_deps = withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - let pkg_names = map unitIdString (Set.toAscList unit_deps) + let pkg_names = map unitIdString (uniqDSetToAscList unit_deps) doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h "#include \"Stg.h\"\n" diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index c9967c7120..5008194b72 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -127,7 +127,7 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env -hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids :: HscEnv -> UnitIdSet hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 3321d1203f..3450ca0f0c 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -245,6 +245,7 @@ import GHC.Types.Name.Ppr import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic @@ -274,7 +275,6 @@ import Data.IORef import System.FilePath as FilePath import System.Directory import qualified Data.Set as S -import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) @@ -1457,15 +1457,15 @@ checkSafeImports tcg_env clearDiagnostics -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safePkgs <- mkUniqDSet <$> mapMaybeM checkSafe safeImps safeErrs <- getDiagnostics clearDiagnostics -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyMessages, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + False -> return (emptyMessages, emptyUniqDSet) + True -> do infPkgs <- mkUniqDSet <$> mapMaybeM checkSafe regImps infErrs <- getDiagnostics clearDiagnostics return (infErrs, infPkgs) @@ -1516,12 +1516,12 @@ checkSafeImports tcg_env checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + pkgTrustReqs :: DynFlags -> UnitIdSet -> UnitIdSet -> Bool -> ImportAvails pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && not (safeHaskellModeEnabled dflags) && infPassed = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf + imp_trust_pkgs = req `unionUniqDSets` inf } pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe = emptyImportAvails @@ -1540,12 +1540,12 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyMessages errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, UnitIdSet) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l good <- isEmptyMessages `fmap` getDiagnostics clearDiagnostics -- don't want them printed... - let pkgs' | Just p <- self = S.insert p pkgs + let pkgs' | Just p <- self = addOneToUniqDSet pkgs p | otherwise = pkgs return (good, pkgs') @@ -1554,7 +1554,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe UnitId, Set UnitId) + -> Hsc (Maybe UnitId, UnitIdSet) hscCheckSafe' m l = do hsc_env <- getHscEnv let home_unit = hsc_home_unit hsc_env @@ -1566,7 +1566,7 @@ hscCheckSafe' m l = do -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where - isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, UnitIdSet) isModSafe home_unit m l = do hsc_env <- getHscEnv dflags <- getDynFlags @@ -1648,10 +1648,10 @@ hscCheckSafe' m l = do -- | Check the list of packages are trusted. -checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust :: UnitIdSet -> Hsc () checkPkgTrust pkgs = do hsc_env <- getHscEnv - let errors = S.foldr go emptyBag pkgs + let errors = foldr go emptyBag $ uniqDSetToList pkgs state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg @@ -1699,7 +1699,7 @@ markUnsafeInfer tcg_env whyUnsafe = do False -> return tcg_env where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = emptyUniqDSet } pprMod = ppr $ moduleName $ tcg_mod tcg_env whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" @@ -2060,7 +2060,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs in NoStubs `appendStubC` ip_init | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] emptyUniqDSet rawCmms return stub_c_exists where diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index c047056ea6..a6dbad4f30 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -107,6 +107,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Types.PkgQual import GHC.Unit @@ -490,7 +491,7 @@ load how_much = loadWithCache noIfaceCache how_much mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env = - if length (hsc_all_home_unit_ids hsc_env) > 1 + if sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 -- This also displays what unit each module is from. then batchMultiMsg else batchMsg @@ -1735,25 +1736,25 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] +checkHomeUnitsClosed :: UnitEnv -> UnitIdSet -> [(UnitId, UnitId)] -> [DriverMessages] -- Fast path, trivially closed. checkHomeUnitsClosed ue home_id_set home_imp_ids - | Set.size home_id_set == 1 = [] + | sizeUniqDSet home_id_set == 1 = [] | otherwise = - let res = foldMap loop home_imp_ids + let res = foldr (\ids acc -> unionUniqDSets acc $ loop ids) emptyUniqDSet home_imp_ids -- Now check whether everything which transitively depends on a home_unit is actually a home_unit -- These units are the ones which we need to load as home packages but failed to do for some reason, -- it's a bug in the tool invoking GHC. - bad_unit_ids = Set.difference res home_id_set - in if Set.null bad_unit_ids + bad_unit_ids = res `minusUniqDSet` home_id_set + in if isEmptyUniqDSet bad_unit_ids then [] - else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (uniqDSetToAscList bad_unit_ids)] where rootLoc = mkGeneralSrcSpan (fsLit "") -- TODO: This could repeat quite a bit of work but I struggled to write this function. -- Which units transitively depend on a home unit - loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit + loop :: (UnitId, UnitId) -> UnitIdSet -- The units which transitively depend on a home unit loop (from_uid, uid) = let us = ue_findHomeUnitEnv from_uid ue in let um = unitInfoMap (homeUnitEnv_units us) in @@ -1761,20 +1762,21 @@ checkHomeUnitsClosed ue home_id_set home_imp_ids Nothing -> pprPanic "uid not found" (ppr uid) Just ui -> let depends = unitDepends ui - home_depends = Set.fromList depends `Set.intersection` home_id_set - other_depends = Set.fromList depends `Set.difference` home_id_set + home_depends = mkUniqDSet depends `intersectUniqDSets` home_id_set + other_depends = mkUniqDSet depends `minusUniqDSet` home_id_set in -- Case 1: The unit directly depends on a home_id - if not (null home_depends) + if not (isEmptyUniqDSet home_depends) then - let res = foldMap (loop . (from_uid,)) other_depends - in Set.insert uid res + let res :: UnitIdSet + res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends + in addOneToUniqDSet res uid -- Case 2: Check the rest of the dependencies, and then see if any of them depended on else - let res = foldMap (loop . (from_uid,)) other_depends + let res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends in - if not (Set.null res) - then Set.insert uid res + if not (isEmptyUniqDSet res) + then addOneToUniqDSet res uid else res -- | Update the every ModSummary that is depended on diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 0737a2f8c1..c392515aa3 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -108,6 +108,7 @@ import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceError +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -125,7 +126,7 @@ import Control.Monad import qualified Control.Monad.Catch as MC (handle) import Data.Maybe import Data.Either ( partitionEithers ) -import qualified Data.Set as Set +import Data.List ( sort ) import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp @@ -408,8 +409,8 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt home_mod_infos = eltsHpt hpt -- the packages we depend on - pkg_deps = Set.toList - $ Set.unions + pkg_deps = uniqDSetToList + $ unionManyUniqDSets $ fmap (dep_direct_pkgs . mi_deps . hm_iface) $ home_mod_infos @@ -418,7 +419,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos)) debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) - debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) + debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr $ sort pkg_deps)) -- check for the -no-link flag if isNoLink (ghcLink dflags) diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index e2ac533ba8..0172cd3fc5 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -26,6 +26,7 @@ import GHC.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -40,7 +41,6 @@ import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Set as Set import GHC.Linker.Types import GHC.Unit.Finder @@ -196,7 +196,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do mk_mod_usage_info :: UsageConfig -> HomeUnit - -> Set.Set UnitId + -> UnitIdSet -> Module -> ImportedMods -> NameSet @@ -255,7 +255,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names -- (need to recompile if its export list changes: export_fprint) mkUsage :: Module -> ModIface -> Maybe Usage mkUsage mod iface - | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids + | not $ toUnitId (moduleUnit mod) `elementOfUniqDSet` home_unit_ids = Just $ UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 5305a97623..87d9ba59f1 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -504,7 +504,7 @@ loadInterface doc_str mod from -- overlapping instances. ; massertPpr ((isOneShot (ghcMode (hsc_dflags hsc_env))) - || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env + || not (moduleUnitId mod `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env) || mod == gHC_PRIM) (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index b0e668f0e6..a898dbd27c 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -59,6 +59,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique.Set import GHC.Types.Fixity.Env import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -617,8 +618,8 @@ checkDependencies hsc_env summary iface all_home_units = hsc_all_home_unit_ids hsc_env units = hsc_units hsc_env prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) - prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) - (dep_plugin_pkgs (mi_deps iface))) + prev_dep_pkgs = uniqDSetToAscList (unionUniqDSets (dep_direct_pkgs (mi_deps iface)) + (dep_plugin_pkgs (mi_deps iface))) implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags) @@ -633,7 +634,7 @@ checkDependencies hsc_env summary iface classify _ (Found _ mod) - | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) + | (toUnitId $ moduleUnit mod) `elementOfUniqDSet` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index f6caa18a9d..709430db0f 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -324,20 +324,20 @@ loadCmdLineLibs interp hsc_env = do loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState loadCmdLineLibs' interp hsc_env pls = snd <$> foldM - (\(done', pls') cur_uid -> load done' cur_uid pls') - (Set.empty, pls) - (hsc_all_home_unit_ids hsc_env) + (\(done', pls') cur_uid -> load done' cur_uid pls') + (emptyUniqDSet, pls) + (uniqDSetToList $ hsc_all_home_unit_ids hsc_env) where - load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState) - load done uid pls | uid `Set.member` done = return (done, pls) + load :: UnitIdSet -> UnitId -> LoaderState -> IO (UnitIdSet, LoaderState) + load done uid pls | uid `elementOfUniqDSet` done = return (done, pls) load done uid pls = do let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (homeUnitDepends (hsc_units hsc')) pls'' <- loadCmdLineLibs'' interp hsc' pls' - return $ (Set.insert uid done', pls'') + return $ (addOneToUniqDSet done' uid, pls'') loadCmdLineLibs'' :: Interp @@ -685,7 +685,7 @@ getLinkDeps :: HscEnv -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first + -> IO ([Linkable], [Linkable], [UnitId], UnitIdSet) -- ... then link these first -- The module and package dependencies for the needed modules are returned. -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files @@ -737,7 +737,7 @@ getLinkDeps hsc_env pls replace_osuf span mods -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UnitIdSet, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UnitIdSet, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts @@ -766,7 +766,7 @@ getLinkDeps hsc_env pls replace_osuf span mods HsBootFile -> link_boot_mod_error (mi_module iface) _ -> return $ Just (mi_module iface) - in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod + in (dep_direct_pkgs (mi_deps iface),) <$> mmod Nothing -> let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) @@ -780,9 +780,9 @@ getLinkDeps hsc_env pls replace_osuf span mods -- dependencies of that. Hence we need to traverse the dependency -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow - -> UniqDSet Module -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([Module], UniqDSet UnitId) -- result + -> UniqDSet Module -- accum. module dependencies + -> UnitIdSet -- accum. package dependencies + -> IO ([Module], UnitIdSet) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -814,7 +814,7 @@ getLinkDeps hsc_env pls replace_osuf span mods acc_mods' = case hsc_home_unit_maybe hsc_env of Nothing -> acc_mods Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs (uniqDSetToList pkg_deps) case hsc_home_unit_maybe hsc_env of Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs index c343537b08..7ef1451e3c 100644 --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -37,7 +37,7 @@ module GHC.Linker.Types where import GHC.Prelude -import GHC.Unit ( UnitId, Module ) +import GHC.Unit ( UnitId, Module, UnitIdSet ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) import GHCi.RemoteTypes ( ForeignHValue ) @@ -53,7 +53,6 @@ import Control.Concurrent.MVar import Data.Time ( UTCTime ) import Data.Maybe import GHC.Unit.Module.Env -import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Unit.Module.WholeCoreBindings @@ -146,7 +145,7 @@ data LoadedPkgInfo { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] - , loaded_pkg_trans_deps :: UniqDSet UnitId + , loaded_pkg_trans_deps :: UnitIdSet } instance Outputable LoadedPkgInfo where diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index ba45769034..168bbc636b 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -74,6 +74,7 @@ import GHC.Types.Id import GHC.Types.HpcInfo import GHC.Types.PkgQual import GHC.Types.GREInfo (ConInfo(..)) +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Module.Warnings @@ -212,8 +213,8 @@ rnImports imports = do let merged_import_avail = clobberSourceImports imp_avails dflags <- getDynFlags let final_import_avail = - merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) - `S.union` imp_dep_direct_pkgs merged_import_avail} + merged_import_avail { imp_dep_direct_pkgs = mkUniqDSet (implicitPackageDeps dflags) + `unionUniqDSets` imp_dep_direct_pkgs merged_import_avail} return (decls, rdr_env, final_import_avail, hpc_usage) where @@ -480,7 +481,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit - -> S.Set UnitId + -> UnitIdSet -> ModIface -> IsSafeImport -> IsBootInterface @@ -535,7 +536,7 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by -- Trusted packages are a lot like orphans. trusted_pkgs | mod_safe' = dep_trusted_pkgs deps - | otherwise = S.empty + | otherwise = emptyUniqDSet pkg = moduleUnit (mi_module iface) @@ -548,11 +549,11 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by | isHomeUnit home_unit pkg = ptrust | otherwise = False - dependent_pkgs = if toUnitId pkg `S.member` other_home_units - then S.empty - else S.singleton ipkg + dependent_pkgs = if toUnitId pkg `elementOfUniqDSet` other_home_units + then emptyUniqDSet + else unitUniqDSet ipkg - direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units + direct_mods = mkModDeps $ if toUnitId pkg `elementOfUniqDSet` other_home_units then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) else S.empty diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 1b02340061..1b98191a36 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -148,6 +148,7 @@ import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -185,7 +186,6 @@ import Data.List ( sortBy, sort ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord -import qualified Data.Set as S import Data.Traversable ( for ) @@ -3134,7 +3134,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , text "Dependent modules:" <+> (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_direct_pkgs imports)] + ppr (uniqDSetToAscList $ imp_dep_direct_pkgs imports)] -- The use of sort is just to reduce unnecessary -- wobbling in testsuite output diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index a6bab74fc0..4a28270cb1 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -142,6 +142,7 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo @@ -1367,9 +1368,9 @@ plusModDeps = plusInstalledModuleEnv plus_mod_dep emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, imp_direct_dep_mods = emptyInstalledModuleEnv, - imp_dep_direct_pkgs = S.empty, + imp_dep_direct_pkgs = emptyUniqDSet, imp_sig_mods = [], - imp_trust_pkgs = S.empty, + imp_trust_pkgs = emptyUniqDSet, imp_trust_own_pkg = False, imp_boot_mods = emptyInstalledModuleEnv, imp_orphs = [], @@ -1398,8 +1399,8 @@ plusImportAvails imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2, - imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_dep_direct_pkgs = ddpkgs1 `unionUniqDSets` ddpkgs2, + imp_trust_pkgs = tpkgs1 `unionUniqDSets` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_boot_mods = srs1 `plusModDeps` srcs2, imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, diff --git a/compiler/GHC/Types/Unique/DSet.hs b/compiler/GHC/Types/Unique/DSet.hs index d4d555f83b..1d5f23495b 100644 --- a/compiler/GHC/Types/Unique/DSet.hs +++ b/compiler/GHC/Types/Unique/DSet.hs @@ -32,6 +32,7 @@ module GHC.Types.Unique.DSet ( isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, + uniqDSetToAscList, partitionUniqDSet, mapUniqDSet ) where @@ -43,8 +44,11 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique +import GHC.Utils.Binary + import Data.Coerce import Data.Data +import Data.List (sort) -- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass @@ -120,6 +124,9 @@ lookupUniqDSet = lookupUDFM . getUniqDSet uniqDSetToList :: UniqDSet a -> [a] uniqDSetToList = eltsUDFM . getUniqDSet +uniqDSetToAscList :: Ord a => UniqDSet a -> [a] +uniqDSetToAscList = sort . uniqDSetToList + partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet @@ -140,3 +147,7 @@ instance Outputable a => Outputable (UniqDSet a) where pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList + +instance (Uniquable a, Binary a, Ord a) => Binary (UniqDSet a) where + put_ bh = put_ bh . uniqDSetToAscList + get bh = mkUniqDSet <$> get bh diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs index a34ae550e0..e473c45669 100644 --- a/compiler/GHC/Unit/Env.hs +++ b/compiler/GHC/Unit/Env.hs @@ -81,6 +81,7 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic (pprPanic) +import GHC.Types.Unique.DSet import GHC.Unit.Module.ModIface import GHC.Unit.Module import qualified Data.Set as Set @@ -339,8 +340,8 @@ unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env -unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey -unitEnv_keys env = Map.keysSet (unitEnv_graph env) +unitEnv_keys :: UnitEnvGraph v -> UnitIdSet +unitEnv_keys env = mkUniqDSet $ Map.keys (unitEnv_graph env) unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)] unitEnv_elts env = Map.toList (unitEnv_graph env) @@ -443,7 +444,7 @@ ue_unitHomeUnit_maybe uid ue_env = ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env -ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids :: UnitEnv -> UnitIdSet ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs index 583b7fdaaa..07f6bc33b7 100644 --- a/compiler/GHC/Unit/Module/Deps.hs +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -28,6 +28,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint import GHC.Utils.Binary @@ -53,13 +54,13 @@ data Dependencies = Deps -- ^ All home-package modules which are directly imported by this one. -- This may include modules from other units when using multiple home units - , dep_direct_pkgs :: Set UnitId + , dep_direct_pkgs :: UnitIdSet -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. -- Does not include other home units when using multiple home units. -- Modules from these units will go in `dep_direct_mods` - , dep_plugin_pkgs :: Set UnitId + , dep_plugin_pkgs :: UnitIdSet -- ^ All units needed for plugins ------------------------------------ @@ -69,7 +70,7 @@ data Dependencies = Deps -- ^ Transitive closure of hsig files in the home package - , dep_trusted_pkgs :: Set UnitId + , dep_trusted_pkgs :: UnitIdSet -- Packages which we are required to trust -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -110,7 +111,7 @@ data Dependencies = Deps mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods - plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) + plugin_units = mkUniqDSet (map (toUnitId . moduleUnit) external_plugins) all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot)) (imp_direct_dep_mods imports) (map (fmap toUnitId) home_plugins) @@ -197,12 +198,12 @@ instance Binary Dependencies where noDependencies :: Dependencies noDependencies = Deps - { dep_direct_mods = Set.empty - , dep_direct_pkgs = Set.empty - , dep_plugin_pkgs = Set.empty + { dep_direct_mods = mempty + , dep_direct_pkgs = emptyUniqDSet + , dep_plugin_pkgs = emptyUniqDSet , dep_sig_mods = [] - , dep_boot_mods = Set.empty - , dep_trusted_pkgs = Set.empty + , dep_boot_mods = mempty + , dep_trusted_pkgs = emptyUniqDSet , dep_orphs = [] , dep_finsts = [] } @@ -220,11 +221,11 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, text "boot module dependencies:" <+> ppr_set ppr bmods, - text "direct package dependencies:" <+> ppr_set ppr pkgs, - text "plugin package dependencies:" <+> ppr_set ppr plgns, - if null tps + text "direct package dependencies:" <+> ppr_unitIdSet ppr pkgs, + text "plugin package dependencies:" <+> ppr_unitIdSet ppr plgns, + if isEmptyUniqDSet tps then empty - else text "trusted package dependencies:" <+> ppr_set ppr tps, + else text "trusted package dependencies:" <+> ppr_unitIdSet ppr tps, text "orphans:" <+> fsep (map ppr orphs), text "family instance modules:" <+> fsep (map ppr finsts) ] @@ -235,6 +236,9 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc ppr_set w = fsep . fmap w . Set.toAscList + ppr_unitIdSet :: (UnitId -> SDoc) -> UnitIdSet -> SDoc + ppr_unitIdSet w = fsep . fmap w . sort . uniqDSetToList + -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- @@ -491,7 +495,7 @@ data ImportAvails imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot, -- ^ Home-package modules directly imported by the module being compiled. - imp_dep_direct_pkgs :: Set UnitId, + imp_dep_direct_pkgs :: UnitIdSet, -- ^ Packages directly needed by the module being compiled imp_trust_own_pkg :: Bool, @@ -502,7 +506,7 @@ data ImportAvails -- Transitive information below here - imp_trust_pkgs :: Set UnitId, + imp_trust_pkgs :: UnitIdSet, -- ^ This records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs index d54e836d71..00bbfca1b4 100644 --- a/compiler/GHC/Unit/Module/ModGuts.hs +++ b/compiler/GHC/Unit/Module/ModGuts.hs @@ -37,8 +37,6 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) import GHC.Types.SrcLoc import GHC.Types.CostCentre -import Data.Set (Set) - -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module @@ -137,7 +135,7 @@ data CgGuts cg_ccs :: [CostCentre], -- List of cost centres used in bindings and rules cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to + cg_dep_pkgs :: !UnitIdSet, -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index f5aeb65216..39a350cffe 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -346,10 +346,10 @@ data UnitConfig = UnitConfig , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units - , unitConfigHomeUnits :: Set.Set UnitId + , unitConfigHomeUnits :: UnitIdSet } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> UnitConfig initUnitConfig dflags cached_dbs home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags @@ -626,7 +626,7 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) initUnits logger dflags cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () @@ -1362,7 +1362,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> text db_path - forM_ (Set.toList override_set) $ \pkg -> + forM_ (uniqDSetToList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> text "overrides a previously defined package" @@ -1374,9 +1374,9 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] -- 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 (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) + override_set :: UnitIdSet + override_set = intersectUniqDSets (mkUniqDSet $ nonDetKeysUniqMap db_map) + (mkUniqDSet $ nonDetKeysUniqMap pkg_map) -- Now merge the sets together (NB: in case of duplicate, -- first argument preferred) @@ -1688,7 +1688,7 @@ mkUnitState logger cfg = do let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = uniqDSetToList home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map @@ -1701,15 +1701,15 @@ mkUnitState logger cfg = do } return (state, raw_dbs) -selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool -selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True +selectHptFlag :: UnitIdSet -> PackageFlag -> Bool +selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = True selectHptFlag _ _ = False -selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId -selectHomeUnits home_units flags = foldl' go Set.empty flags +selectHomeUnits :: UnitIdSet -> [PackageFlag] -> UnitIdSet +selectHomeUnits home_units flags = foldl' go emptyUniqDSet flags where - go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId - go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur + go :: UnitIdSet -> PackageFlag -> UnitIdSet + go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = addOneToUniqDSet cur (toUnitId uid) -- MP: This does not yet support thinning/renaming go cur _ = cur diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index 7439ab7dde..a92383b0ec 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -33,6 +33,7 @@ module GHC.Unit.Types , GenInstantiatedUnit (..) , InstantiatedUnit , DefUnitId + , UnitIdSet , Instantiations , GenInstantiations , mkInstantiatedUnit @@ -538,6 +539,8 @@ pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- code for. type DefUnitId = Definite UnitId +type UnitIdSet = UniqDSet UnitId + unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 287b3d8788..11b5586039 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -105,6 +105,7 @@ import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Bag (unitBag) import qualified GHC.Data.Strict as Strict +import GHC.Types.Unique.DSet -- Haskell Libraries import System.Console.Haskeline as Haskeline @@ -125,7 +126,6 @@ import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S import Data.Maybe import qualified Data.Map as M import Data.IntMap.Strict (IntMap) @@ -561,7 +561,7 @@ interactiveUI config srcs maybe_exprs = do -- Set to True because Prelude is implicitly imported. impDecl@ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}} hsc_env <- GHC.getSession - let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1 + let in_multi = sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 empty_cache <- liftIO newIfaceCache startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, @@ -2568,15 +2568,15 @@ isSafeModule m = do -- print info to user... liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") - when (not $ S.null good) + when (not $ isEmptyUniqDSet good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ - (intercalate ", " $ map (showPpr dflags) (S.toList good))) - case msafe && S.null bad of + (intercalate ", " $ map (showPpr dflags) (uniqDSetToList good))) + case msafe && isEmptyUniqDSet bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do - when (not $ null bad) + when (not $ isEmptyUniqDSet bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " - ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad))) + ++ (intercalate ", " $ map (showPpr dflags) (uniqDSetToList bad))) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where @@ -2586,8 +2586,8 @@ isSafeModule m = do | isHomeModule (hsc_home_unit hsc_env) md = True | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md) - tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty) - | otherwise = S.partition part deps + tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (emptyUniqDSet, emptyUniqDSet) + | otherwise = partitionUniqDSet part deps where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg unit_state = hsc_units hsc_env dflags = hsc_dflags hsc_env -- cgit v1.2.1