diff options
Diffstat (limited to 'compiler/GHC/Unit')
| -rw-r--r-- | compiler/GHC/Unit/Env.hs | 61 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Finder.hs | 253 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Home.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Info.hs | 100 | ||||
| -rw-r--r-- | compiler/GHC/Unit/State.hs | 273 |
5 files changed, 287 insertions, 404 deletions
diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs new file mode 100644 index 0000000000..d7de796434 --- /dev/null +++ b/compiler/GHC/Unit/Env.hs @@ -0,0 +1,61 @@ +module GHC.Unit.Env + ( UnitEnv (..) + , preloadUnitsInfo + , preloadUnitsInfo' + ) +where + +import GHC.Prelude + +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Types + +import GHC.Platform +import GHC.Settings +import GHC.Data.Maybe + +data UnitEnv = UnitEnv + { ue_units :: !UnitState -- ^ Units + , ue_home_unit :: !HomeUnit -- ^ Home unit + , ue_platform :: !Platform -- ^ Platform + , ue_namever :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix) + } + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit +-- used to instantiate the home unit, and for every unit explicitly passed in +-- the given list of UnitId. +preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo] +preloadUnitsInfo' unit_env ids0 = all_infos + where + home_unit = ue_home_unit unit_env + unit_state = ue_units unit_env + ids = ids0 ++ inst_ids + inst_ids + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + | isHomeUnitIndefinite home_unit = [] + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) + pkg_map = unitInfoMap unit_state + preload = preloadUnits unit_state + + all_pkgs = closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing) + all_infos = map (unsafeLookupUnitId unit_state) <$> all_pkgs + + +-- | Lookup 'UnitInfo' for every preload unit from the UnitState and for every +-- unit used to instantiate the home unit. +preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo] +preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env [] diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs index 36193fce94..130994b74b 100644 --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -29,9 +29,6 @@ module GHC.Unit.Finder ( findObjectLinkableMaybe, findObjectLinkable, - cannotFindModule, - cannotFindInterface, - ) where #include "HsVersions.h" @@ -198,14 +195,14 @@ findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString findExposedPackageModule hsc_env mod_name mb_pkg = findLookupResult hsc_env $ lookupModuleWithSuggestions - (unitState (hsc_dflags hsc_env)) mod_name mb_pkg + (hsc_units hsc_env) mod_name mb_pkg findExposedPluginPackageModule :: HscEnv -> ModuleName -> IO FindResult findExposedPluginPackageModule hsc_env mod_name = findLookupResult hsc_env $ lookupPluginModuleWithSuggestions - (unitState (hsc_dflags hsc_env)) mod_name Nothing + (hsc_units hsc_env) mod_name Nothing findLookupResult :: HscEnv -> LookupResult -> IO FindResult findLookupResult hsc_env r = case r of @@ -354,14 +351,10 @@ findInstalledHomeModule hsc_env mod_name = -- | Search for a module in external packages only. findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findPackageModule hsc_env mod = do - let - dflags = hsc_dflags hsc_env - pkg_id = moduleUnit mod - pkgstate = unitState dflags - -- - case lookupUnitId pkgstate pkg_id of + let pkg_id = moduleUnit mod + case lookupUnitId (hsc_units hsc_env) pkg_id of Nothing -> return (InstalledNoPackage pkg_id) - Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf + Just u -> findPackageModule_ hsc_env mod u -- | Look up the interface file associated with module @mod@. This function -- requires a few invariants to be upheld: (1) the 'Module' in question must @@ -617,239 +610,3 @@ findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) -- We used to look for _stub.o files here, but that was a bug (#706) -- Now GHC merges the stub.o into the main .o (#3687) --- ----------------------------------------------------------------------------- --- Error messages - -cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc -cannotFindModule dflags mod res = pprWithUnitState unit_state $ - cantFindErr (sLit cannotFindMsg) - (sLit "Ambiguous module name") - dflags mod res - where - unit_state = unitState dflags - cannotFindMsg = - case res of - NotFound { fr_mods_hidden = hidden_mods - , fr_pkgs_hidden = hidden_pkgs - , fr_unusables = unusables } - | not (null hidden_mods && null hidden_pkgs && null unusables) - -> "Could not load module" - _ -> "Could not find module" - -cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") - (sLit "Ambiguous interface for") - -cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult - -> SDoc -cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) - | Just pkgs <- unambiguousPackages - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [text "it was found in multiple packages:", - hsep (map ppr pkgs) ] - ) - | otherwise - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - vcat (map pprMod mods) - ) - where - unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnit m : xs) - unambiguousPackage _ _ = Nothing - - pprMod (m, o) = text "it is bound as" <+> ppr m <+> - text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( - if e == Just True - then [text "package" <+> ppr (moduleUnit m)] - else [] ++ - map ((text "a reexport in package" <+>) - .ppr.mkUnit) res ++ - if f then [text "a package flag"] else [] - ) - -cantFindErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - pkgs = unitState dflags - home_unit = mkHomeUnitFromFlags dflags - more_info - = case find_result of - NoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" - - NotFound { fr_paths = files, fr_pkg = mb_pkg - , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens - , fr_unusables = unusables, fr_suggestions = suggest } - | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg) - -> not_found_in_package pkg files - - | not (null suggest) - -> pp_suggestions suggest $$ tried_these files dflags - - | null files && null mod_hiddens && - null pkg_hiddens && null unusables - -> text "It is not a module in the current program, or in any known package." - - | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ - vcat (map mod_hidden mod_hiddens) $$ - vcat (map unusable unusables) $$ - tried_these files dflags - - _ -> panic "cantFindErr" - - build_tag = waysBuildTag (ways dflags) - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files dflags - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files dflags - - pkg_hidden :: Unit -> SDoc - pkg_hidden uid = - text "It is a member of the hidden package" - <+> quotes (ppr uid) - --FIXME: we don't really want to show the unit id here we should - -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint uid - pkg_hidden_hint uid - | gopt Opt_BuildingCabalPackage dflags - = let pkg = expectJust "pkg_hidden" (lookupUnit pkgs uid) - in text "Perhaps you need to add" <+> - quotes (ppr (unitPackageName pkg)) <+> - text "to the build-depends in your .cabal file." - | Just pkg <- lookupUnit pkgs uid - = text "You can run" <+> - quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> - text "to expose it." $$ - text "(Note: this unloads all the modules in the current scope.)" - | otherwise = Outputable.empty - - mod_hidden pkg = - text "it is a hidden module in the package" <+> quotes (ppr pkg) - - unusable (pkg, reason) - = text "It is a member of the package" - <+> quotes (ppr pkg) - $$ pprReason (text "which is") reason - - pp_suggestions :: [ModuleSuggestion] -> SDoc - pp_suggestions sugs - | null sugs = Outputable.empty - | otherwise = hang (text "Perhaps you meant") - 2 (vcat (map pp_sugg sugs)) - - -- NB: Prefer the *original* location, and then reexports, and then - -- package flags when making suggestions. ToDo: if the original package - -- also has a reexport, prefer that one - pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromExposedReexport = res, - fromPackageFlag = f }) - | Just True <- e - = parens (text "from" <+> ppr (moduleUnit mod)) - | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnit mod)) - | (pkg:_) <- res - = parens (text "from" <+> ppr (mkUnit pkg) - <> comma <+> text "reexporting" <+> ppr mod) - | f - = parens (text "defined via package flags to be" - <+> ppr mod) - | otherwise = Outputable.empty - pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromHiddenReexport = rhs }) - | Just False <- e - = parens (text "needs flag -package-id" - <+> ppr (moduleUnit mod)) - | (pkg:_) <- rhs - = parens (text "needs flag -package-id" - <+> ppr (mkUnit pkg)) - | otherwise = Outputable.empty - -cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName - -> InstalledFindResult -> SDoc -cantFindInstalledErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - home_unit = mkHomeUnitFromFlags dflags - unit_state = unitState dflags - build_tag = waysBuildTag (ways dflags) - - more_info - = case find_result of - InstalledNoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg - - InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg) - -> not_found_in_package pkg files - - | null files - -> text "It is not a module in the current program, or in any known package." - - | otherwise - -> tried_these files dflags - - _ -> panic "cantFindInstalledErr" - - looks_like_srcpkgid :: UnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id (i.e. an installed package component - -- identifier) into a PackageId and see if it means anything. - | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files dflags - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files dflags - -tried_these :: [FilePath] -> DynFlags -> SDoc -tried_these files dflags - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v (or `:set -v` in ghci) " <> - text "to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs index 6baa8bf5fb..fa8a0b1d6f 100644 --- a/compiler/GHC/Unit/Home.hs +++ b/compiler/GHC/Unit/Home.hs @@ -43,9 +43,7 @@ import Data.Maybe -- unit identifier) with `homeUnitMap`. -- -- TODO: this isn't implemented yet. UnitKeys are still converted too early into --- UnitIds in GHC.Unit.State.readUnitDataBase and wiring of home unit --- instantiations is done inplace in DynFlags by --- GHC.Unit.State.upd_wired_in_home_instantiations. +-- UnitIds in GHC.Unit.State.readUnitDataBase data GenHomeUnit u = DefiniteHomeUnit UnitId (Maybe (u, GenInstantiations u)) -- ^ Definite home unit (i.e. that we can compile). diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index 1f2366f292..d95ea5b442 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -19,23 +19,41 @@ module GHC.Unit.Info , unitPackageNameString , unitPackageIdString , pprUnitInfo + + , collectIncludeDirs + , collectExtraCcOpts + , collectLibraryDirs + , collectFrameworks + , collectFrameworksDirs + , unitHsLibs ) where #include "HsVersions.h" import GHC.Prelude +import GHC.Platform.Ways -import GHC.Unit.Database -import Data.Version -import Data.Bifunctor +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Types.Unique import GHC.Data.FastString import qualified GHC.Data.ShortText as ST -import GHC.Utils.Outputable + import GHC.Unit.Module as Module -import GHC.Types.Unique import GHC.Unit.Ppr +import GHC.Unit.Database + +import GHC.Settings + +import Data.Version +import Data.Bifunctor +import Data.List (isPrefixOf, stripPrefix) +import qualified Data.Set as Set + -- | Information about an installed unit -- @@ -165,3 +183,75 @@ mkUnitPprInfo ufs i = UnitPprInfo (unitPackageNameString i) (unitPackageVersion i) ((unpackFS . unPackageName) <$> unitComponentName i) + +-- | Find all the include directories in the given units +collectIncludeDirs :: [UnitInfo] -> [FilePath] +collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps)) + +-- | Find all the C-compiler options in the given units +collectExtraCcOpts :: [UnitInfo] -> [String] +collectExtraCcOpts ps = map ST.unpack (concatMap unitCcOptions ps) + +-- | Find all the library directories in the given units for the given ways +collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath] +collectLibraryDirs ws = ordNub . filter notNull . concatMap (libraryDirsForWay ws) + +-- | Find all the frameworks in the given units +collectFrameworks :: [UnitInfo] -> [String] +collectFrameworks ps = map ST.unpack (concatMap unitExtDepFrameworks ps) + +-- | Find all the package framework paths in these and the preload packages +collectFrameworksDirs :: [UnitInfo] -> [String] +collectFrameworksDirs ps = map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps))) + +-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. +libraryDirsForWay :: Ways -> UnitInfo -> [String] +libraryDirsForWay ws + | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs + | otherwise = map ST.unpack . unitLibraryDirs + +unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String] +unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p) + where + ways1 = Set.filter (/= WayDyn) ways0 + -- the name of a shared library is libHSfoo-ghc<version>.so + -- we leave out the _dyn, because it is superfluous + + -- debug and profiled RTSs include support for -eventlog + ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1 + = Set.filter (/= WayTracing) ways1 + | otherwise + = ways1 + + tag = waysTag (fullWays ways2) + rts_tag = waysTag ways2 + + mkDynName x + | not (ways0 `hasWay` WayDyn) = x + | "HS" `isPrefixOf` x = x ++ dynLibSuffix namever + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | otherwise + = panic ("Don't understand library name " ++ x) + + -- Add _thr and other rts suffixes to packages named + -- `rts` or `rts-1.0`. Why both? Traditionally the rts + -- package is called `rts` only. However the tooling + -- usually expects a package name to have a version. + -- As such we will gradually move towards the `rts-1.0` + -- package name, at which point the `rts` package name + -- will eventually be unused. + -- + -- This change elevates the need to add custom hooks + -- and handling specifically for the `rts` package for + -- example in ghc-cabal. + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) + + expandTag t | null t = "" + | otherwise = '_':t + diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 74ba55a702..1aabfb10c2 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -1,6 +1,7 @@ -- (c) The University of Glasgow, 2006 {-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} -- | Unit manipulation module GHC.Unit.State ( @@ -9,6 +10,7 @@ module GHC.Unit.State ( -- * Reading the package config, and processing cmdline args UnitState(..), UnitDatabase (..), + UnitErr (..), emptyUnitState, initUnits, readUnitDatabases, @@ -39,12 +41,9 @@ module GHC.Unit.State ( UnusableUnitReason(..), pprReason, - -- * Inspecting the set of packages in scope - getUnitIncludePath, - getUnitExtraCcOpts, - getPreloadUnitsAnd, - - collectIncludeDirs, + closeUnitDeps, + closeUnitDeps', + mayThrowUnitErr, -- * Module hole substitution ShHoleSubst, @@ -73,19 +72,23 @@ where import GHC.Prelude +import GHC.Driver.Session + import GHC.Platform -import GHC.Unit.Home +import GHC.Platform.Ways + import GHC.Unit.Database import GHC.Unit.Info import GHC.Unit.Ppr import GHC.Unit.Types import GHC.Unit.Module -import GHC.Driver.Session -import GHC.Platform.Ways +import GHC.Unit.Home + import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable @@ -94,7 +97,7 @@ import GHC.Data.Maybe import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST -import GHC.Utils.Error ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, +import GHC.Utils.Error ( debugTraceMsg, dumpIfSet_dyn, withTiming, DumpFormat (..) ) import GHC.Utils.Exception @@ -342,8 +345,8 @@ data UnitConfig = UnitConfig , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units } -initUnitConfig :: DynFlags -> UnitConfig -initUnitConfig dflags = +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig +initUnitConfig dflags cached_dbs = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags !hu_instantiations = homeUnitInstantiations_ dflags @@ -376,7 +379,7 @@ initUnitConfig dflags = , unitConfigHideAll = gopt Opt_HideAllPackages dflags , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags - , unitConfigDBCache = unitDatabases dflags + , unitConfigDBCache = cached_dbs , unitConfigFlagsDB = packageDBFlags dflags , unitConfigFlagsExposed = packageFlags dflags , unitConfigFlagsIgnored = ignorePackageFlags dflags @@ -573,27 +576,55 @@ listUnitInfo state = Map.elems (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 :: DynFlags -> IO DynFlags -initUnits dflags = do +initUnits :: DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit) +initUnits dflags cached_dbs = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () let ctx = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages let printer = debugTraceMsg dflags -- printer for trace messages - (state,dbs) <- withTiming dflags (text "initializing unit database") + (unit_state,dbs) <- withTiming dflags (text "initializing unit database") forceUnitInfoMap - (mkUnitState ctx printer (initUnitConfig dflags)) - - dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Module Map" - FormatText (pprModuleMap (moduleNameProvidersMap state)) - - let dflags' = dflags - { unitDatabases = Just dbs -- databases are cached and never read again - , unitState = state - } - dflags'' = upd_wired_in_home_instantiations dflags' - - return dflags'' + $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) + + dumpIfSet_dyn dflags Opt_D_dump_mod_map "Module Map" + FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) + $ pprModuleMap (moduleNameProvidersMap unit_state)) + + let home_unit = mkHomeUnit unit_state + (homeUnitId_ dflags) + (homeUnitInstanceOf_ dflags) + (homeUnitInstantiations_ dflags) + + return (dbs,unit_state,home_unit) + +mkHomeUnit + :: UnitState + -> UnitId -- ^ Home unit id + -> Maybe UnitId -- ^ Home unit instance of + -> [(ModuleName, Module)] -- ^ Home unit instantiations + -> HomeUnit +mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ = + let + -- Some wired units can be used to instantiate the home unit. We need to + -- replace their unit keys with their wired unit ids. + wmap = wireMap unit_state + hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_ + in case (hu_instanceof, hu_instantiations) of + (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing + (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with") + (Just u, is) + -- detect fully indefinite units: all their instantiations are hole + -- modules and the home unit id is the same as the instantiating unit + -- id (see Note [About units] in GHC.Unit) + | all (isHoleModule . snd) is && u == hu_id + -> IndefiniteHomeUnit u is + -- otherwise it must be that we (fully) instantiate an indefinite unit + -- to make it definite. + -- TODO: error when the unit is partially instantiated?? + | otherwise + -> DefiniteHomeUnit hu_id (Just (u, is)) -- ----------------------------------------------------------------------------- -- Reading the unit database(s) @@ -759,30 +790,28 @@ mungeDynLibFields pkg = -- -trust and -distrust. applyTrustFlag - :: SDocContext - -> UnitPrecedenceMap + :: UnitPrecedenceMap -> UnusableUnits -> [UnitInfo] -> TrustFlag - -> IO [UnitInfo] -applyTrustFlag ctx prec_map unusable pkgs flag = + -> MaybeErr UnitErr [UnitInfo] +applyTrustFlag prec_map unusable pkgs flag = case flag of -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr ctx flag ps - Right (ps,qs) -> return (map trust ps ++ qs) + Left ps -> Failed (TrustFlagErr flag ps) + Right (ps,qs) -> Succeeded (map trust ps ++ qs) where trust p = p {unitIsTrusted=True} DistrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr ctx flag ps - Right (ps,qs) -> return (distrustAllUnits ps ++ qs) + Left ps -> Failed (TrustFlagErr flag ps) + Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs) applyPackageFlag - :: SDocContext - -> UnitPrecedenceMap + :: UnitPrecedenceMap -> UnitInfoMap -> PreloadUnitClosure -> UnusableUnits @@ -790,15 +819,15 @@ applyPackageFlag -- any previously exposed packages with the same name -> [UnitInfo] -> VisibilityMap -- Initially exposed - -> PackageFlag -- flag to apply - -> IO VisibilityMap -- Now exposed + -> PackageFlag -- flag to apply + -> MaybeErr UnitErr VisibilityMap -- Now exposed -applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm flag = +applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = case flag of ExposePackage _ arg (ModRenaming b rns) -> case findPackages prec_map pkg_map closure arg pkgs unusable of - Left ps -> packageFlagErr ctx flag ps - Right (p:_) -> return vm' + Left ps -> Failed (PackageFlagErr flag ps) + Right (p:_) -> Succeeded vm' where n = fsPackageName p @@ -861,9 +890,8 @@ applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm fl HidePackage str -> case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of - Left ps -> packageFlagErr ctx flag ps - Right ps -> return vm' - where vm' = foldl' (flip Map.delete) vm (map mkUnit ps) + Left ps -> Failed (PackageFlagErr flag ps) + Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps) -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages. Furthermore, any packages it returns are *renamed* @@ -970,34 +998,6 @@ compareByPreference prec_map pkg pkg' comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -packageFlagErr :: SDocContext - -> PackageFlag - -> [(UnitInfo, UnusableUnitReason)] - -> IO a -packageFlagErr ctx flag reasons - = packageFlagErr' ctx (pprFlag flag) reasons - -trustFlagErr :: SDocContext - -> TrustFlag - -> [(UnitInfo, UnusableUnitReason)] - -> IO a -trustFlagErr ctx flag reasons - = packageFlagErr' ctx (pprTrustFlag flag) reasons - -packageFlagErr' :: SDocContext - -> SDoc - -> [(UnitInfo, UnusableUnitReason)] - -> IO a -packageFlagErr' ctx flag_doc reasons - = throwGhcExceptionIO (CmdLineError (renderWithContext ctx $ err)) - where err = text "cannot satisfy " <> flag_doc <> - (if null reasons then Outputable.empty else text ": ") $$ - nest 4 (ppr_reasons $$ - text "(use -v for more information)") - ppr_reasons = vcat (map ppr_reason reasons) - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason - pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of HidePackage p -> text "-hide-package " <> text p @@ -1117,17 +1117,6 @@ findWiredInUnits printer prec_map pkgs vis_map = do -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in GHC.Builtin.Names. --- | Some wired units can be used to instantiate the home unit. We need to --- replace their unit keys with their wired unit ids. -upd_wired_in_home_instantiations :: DynFlags -> DynFlags -upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations_ = wiredInsts } - where - state = unitState dflags - wiringMap = wireMap state - unwiredInsts = homeUnitInstantiations_ dflags - wiredInsts = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts - - upd_wired_in_mod :: WiringMap -> Module -> Module upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m @@ -1482,7 +1471,8 @@ mkUnitState ctx printer cfg = do -- Apply trust flags (these flags apply regardless of whether -- or not packages are visible or not) - pkgs1 <- foldM (applyTrustFlag ctx prec_map unusable) + pkgs1 <- mayThrowUnitErr + $ foldM (applyTrustFlag prec_map unusable) (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) let prelim_pkg_db = mkUnitInfoMap pkgs1 @@ -1540,7 +1530,8 @@ mkUnitState ctx printer cfg = do -- -hide-package). This needs to know about the unusable packages, since if a -- user tries to enable an unusable package, we should let them know. -- - vis_map2 <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable + vis_map2 <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable (unitConfigHideAll cfg) pkgs1) vis_map1 other_flags @@ -1568,7 +1559,8 @@ mkUnitState ctx printer cfg = do -- won't work. | otherwise = vis_map2 plugin_vis_map2 - <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable + <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable hide_plugin_pkgs pkgs1) plugin_vis_map1 (reverse (unitConfigFlagsPlugins cfg)) @@ -1614,8 +1606,9 @@ mkUnitState ctx printer cfg = do preload3 = ordNub $ (basicLinkedUnits ++ preload1) -- Close the preload packages with their dependencies - let dep_preload_err = closeUnitDeps pkg_db (zip (map toUnitId preload3) (repeat Nothing)) - dep_preload <- throwErr ctx dep_preload_err + dep_preload <- mayThrowUnitErr + $ closeUnitDeps pkg_db + $ zip (map toUnitId preload3) (repeat Nothing) let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable @@ -1635,7 +1628,6 @@ mkUnitState ctx printer cfg = do , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } - return (state, raw_dbs) -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' @@ -1775,30 +1767,6 @@ addListTo = foldl' merge mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin mkModMap pkg mod = Map.singleton (mkModule pkg mod) --- ----------------------------------------------------------------------------- --- Extracting information from the packages in scope - --- Many of these functions take a list of packages: in those cases, --- the list is expected to contain the "dependent packages", --- i.e. those packages that were found to be depended on by the --- current module/program. These can be auto or non-auto packages, it --- doesn't really matter. The list is always combined with the list --- of preload (command-line) packages to determine which packages to --- use. - --- | Find all the include directories in these and the preload packages -getUnitIncludePath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] -getUnitIncludePath ctx unit_state home_unit pkgs = - collectIncludeDirs `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs - -collectIncludeDirs :: [UnitInfo] -> [FilePath] -collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps)) - --- | Find all the C-compiler options in these and the preload packages -getUnitExtraCcOpts :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] -getUnitExtraCcOpts ctx unit_state home_unit pkgs = do - ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs - return $ map ST.unpack (concatMap unitCcOptions ps) -- ----------------------------------------------------------------------------- -- Package Utils @@ -1923,39 +1891,15 @@ listVisibleModuleNames state = map fst (filter visible (Map.toList (moduleNameProvidersMap state))) where visible (_, ms) = any originVisible (Map.elems ms) --- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit --- used to instantiate the home unit, and for every unit explicitly passed in --- the given list of UnitId. -getPreloadUnitsAnd :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo] -getPreloadUnitsAnd ctx unit_state home_unit ids0 = - let - ids = ids0 ++ inst_ids - inst_ids - -- An indefinite package will have insts to HOLE, - -- which is not a real package. Don't look it up. - -- Fixes #14525 - | isHomeUnitIndefinite home_unit = [] - | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) - pkg_map = unitInfoMap unit_state - preload = preloadUnits unit_state - in do - all_pkgs <- throwErr ctx (closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing)) - return (map (unsafeLookupUnitId unit_state) all_pkgs) - -throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a -throwErr ctx m = case m of - Failed e -> throwGhcExceptionIO (CmdLineError (renderWithContext ctx e)) - Succeeded r -> return r - -- | Takes a list of UnitIds (and their "parent" dependency, used for error -- messages), and returns the list with dependencies included, in reverse -- dependency order (a units appears before those it depends on). -closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId] +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] 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 MsgDoc [UnitId] +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps -- | Add a UnitId and those it depends on (recursively) to the given list of @@ -1968,16 +1912,11 @@ closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps add_unit :: UnitInfoMap -> [UnitId] -> (UnitId,Maybe UnitId) - -> MaybeErr MsgDoc [UnitId] + -> MaybeErr UnitErr [UnitId] 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 $ - (ftext (fsLit "unknown package:") <+> ppr p) - <> case mb_parent of - Nothing -> Outputable.empty - Just parent -> space <> parens (text "dependency of" - <+> ftext (unitIdFS parent)) + Nothing -> Failed (CloseUnitErr p mb_parent) Just info -> do -- Add the unit's dependents also ps' <- foldM add_unit_key ps (unitDepends info) @@ -1986,6 +1925,44 @@ add_unit pkg_map ps (p, mb_parent) add_unit_key ps key = add_unit pkg_map ps (key, Just p) +data UnitErr + = CloseUnitErr !UnitId !(Maybe UnitId) + | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] + | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] + +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a +mayThrowUnitErr = \case + Failed e -> throwGhcExceptionIO + $ CmdLineError + $ renderWithContext defaultSDocContext + $ withPprStyle defaultUserStyle + $ ppr e + Succeeded a -> return a + +instance Outputable UnitErr where + ppr = \case + CloseUnitErr p mb_parent + -> (ftext (fsLit "unknown unit:") <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + PackageFlagErr flag reasons + -> flag_err (pprFlag flag) reasons + + TrustFlagErr flag reasons + -> flag_err (pprTrustFlag flag) reasons + where + flag_err flag_doc reasons = + text "cannot satisfy " + <> flag_doc + <> (if null reasons then Outputable.empty else text ": ") + $$ nest 4 (vcat (map ppr_reason reasons) $$ + text "(use -v for more information)") + + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + -- ----------------------------------------------------------------------------- -- | Pretty-print a UnitId for the user. |