Commit 10d15f1e authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactoring unit management code

Over the years the unit management code has been modified a lot to keep
up with changes in Cabal (e.g. support for several library components in
the same package), to integrate BackPack, etc. I found it very hard to
understand as the terminology wasn't consistent, was referring to past
concepts, etc.

The terminology is now explained as clearly as I could in the Note
"About Units" and the code is refactored to reflect it.

-------------------

Many names were misleading: UnitId is not an Id but could be a virtual
unit (an indefinite one instantiated on the fly), IndefUnitId
constructor may contain a definite instantiated unit, etc.

   * Rename IndefUnitId into InstantiatedUnit
   * Rename IndefModule into InstantiatedModule
   * Rename UnitId type into Unit
   * Rename IndefiniteUnitId constructor into VirtUnit
   * Rename DefiniteUnitId constructor into RealUnit
   * Rename packageConfigId into mkUnit
   * Rename getPackageDetails into unsafeGetUnitInfo
   * Rename InstalledUnitId into UnitId

Remove references to misleading ComponentId: a ComponentId is just an
indefinite unit-id to be instantiated.

   * Rename ComponentId into IndefUnitId
   * Rename ComponentDetails into UnitPprInfo
   * Fix display of UnitPprInfo with empty version: this is now used for
     units dynamically generated by BackPack

Generalize several types (Module, Unit, etc.) so that they can be used
with different unit identifier types: UnitKey, UnitId, Unit, etc.

   * GenModule: Module, InstantiatedModule and InstalledModule are now
     instances of this type
   * Generalize DefUnitId, IndefUnitId, Unit, InstantiatedUnit,
     PackageDatabase

Replace BackPack fake "hole" UnitId by a proper HoleUnit constructor.

Add basic support for UnitKey. They should be used more in the future to
avoid mixing them up with UnitId as we do now.

Add many comments.

Update Haddock submodule
parent ea717aa4
......@@ -159,11 +159,11 @@ module GHC (
-- * Abstract syntax elements
-- ** Packages
UnitId,
-- ** Units
Unit,
-- ** Modules
Module, mkModule, pprModule, moduleName, moduleUnitId,
Module, mkModule, pprModule, moduleName, moduleUnit,
ModuleName, mkModuleName, moduleNameString,
-- ** Names
......@@ -594,7 +594,7 @@ checkBrokenTablesNextToCode' dflags
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
dflags'' <- liftIO $ interpretPackageEnv dflags'
......@@ -643,7 +643,7 @@ setSessionDynFlags dflags = do
-- | Sets the program 'DynFlags'. Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This
......@@ -655,7 +655,7 @@ setLogAction action = do
void $ setProgramDynFlags_ False $
dflags' { log_action = action }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [UnitId]
setProgramDynFlags_ invalidate_needed dflags = do
dflags' <- checkNewDynFlags dflags
dflags_prev <- getProgramDynFlags
......@@ -1357,7 +1357,7 @@ packageDbModules only_exposed = do
[ mkModule pid modname
| p <- pkgs
, not only_exposed || exposed p
, let pid = packageConfigId p
, let pid = mkUnit p
, modname <- exposedModules p
++ map exportName (reexportedModules p) ]
-}
......@@ -1489,7 +1489,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
this_pkg = thisPackage dflags
--
case maybe_pkg of
Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m -> return m
......@@ -1501,7 +1501,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found loc m | moduleUnitId m /= this_pkg -> return m
Found loc m | moduleUnit m /= this_pkg -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
......@@ -1545,7 +1545,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 InstalledUnitId)
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId)
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
......
......@@ -44,7 +44,7 @@ import GHC.Types.Basic ( Arity, Fixity(..), FixityDirection(..), Boxity(..),
import GHC.Types.SrcLoc ( wiredInSrcSpan )
import GHC.Types.ForeignCall ( CLabelString )
import GHC.Types.Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique )
import GHC.Types.Module ( UnitId )
import GHC.Types.Module ( Unit )
import GHC.Utils.Outputable
import GHC.Data.FastString
......@@ -704,7 +704,7 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op)
************************************************************************
-}
data PrimCall = PrimCall CLabelString UnitId
data PrimCall = PrimCall CLabelString Unit
instance Outputable PrimCall where
ppr (PrimCall lbl pkgId)
......
......@@ -164,7 +164,7 @@ nameToCLabel n suffix = mkFastString label
where
encodeZ = zString . zEncodeFS
(Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
packagePart = encodeZ (unitIdFS pkgKey)
packagePart = encodeZ (unitFS pkgKey)
modulePart = encodeZ (moduleNameFS modName)
occPart = encodeZ (occNameFS (nameOccName n))
......
......@@ -187,7 +187,7 @@ data CLabel
-- | A label from a .cmm file that is not associated with a .hs level Id.
| CmmLabel
UnitId -- what package the label belongs to.
Unit -- what package the label belongs to.
FastString -- identifier giving the prefix of the label
CmmLabelInfo -- encodes the suffix of the label
......@@ -354,7 +354,7 @@ instance Ord CLabel where
data ForeignLabelSource
-- | Label is in a named package
= ForeignLabelInPackage UnitId
= ForeignLabelInPackage Unit
-- | Label is in some external, system package that doesn't also
-- contain compiled Haskell code, and is not associated with any .hi files.
......@@ -553,7 +553,7 @@ mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
:: UnitId -> FastString -> CLabel
:: Unit -> FastString -> CLabel
mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
......@@ -1082,7 +1082,7 @@ labelDynamic config this_mod lbl =
externalDynamicRefs = ncgExternalDynamicRefs config
platform = ncgPlatform config
os = platformOS platform
this_pkg = moduleUnitId this_mod
this_pkg = moduleUnit this_mod
-----------------------------------------------------------------------------
......
......@@ -585,7 +585,7 @@ importName
-- A label imported with an explicit packageId.
| STRING NAME
{ ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
{ ($2, mkCmmCodeLabel (fsToUnit (mkFastString $1)) $2) }
names :: { [FastString] }
......@@ -1163,7 +1163,7 @@ profilingInfo dflags desc_str ty_str
then NoProfilingInfo
else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
......
......@@ -9,12 +9,12 @@ where
import GHC.Prelude
import GHC.Platform
import GHC.Cmm.Type (Width(..))
import GHC.Types.Module
import GHC.Unit.Module
-- | Native code generator configuration
data NCGConfig = NCGConfig
{ ncgPlatform :: !Platform -- ^ Target platform
, ncgUnitId :: UnitId -- ^ Target unit ID
, ncgUnitId :: Unit -- ^ Target unit ID
, ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
, ncgDebugLevel :: !Int -- ^ Debug level
, ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
......
......@@ -1391,7 +1391,7 @@ dataConRepArgTys (MkData { dcRep = rep
dataConIdentity :: DataCon -> ByteString
-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.
dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
[ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod))
[ BSB.byteString $ bytesFS (unitFS (moduleUnit mod))
, BSB.int8 $ fromIntegral (ord ':')
, BSB.byteString $ bytesFS (moduleNameFS (moduleName mod))
, BSB.int8 $ fromIntegral (ord '.')
......
This diff is collapsed.
......@@ -35,7 +35,7 @@ import GHC.Unit.Info
data HsComponentId = HsComponentId {
hsPackageName :: PackageName,
hsComponentId :: ComponentId
hsComponentId :: IndefUnitId
}
instance Outputable HsComponentId where
......
......@@ -60,7 +60,7 @@ codeOutput :: DynFlags
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-- ^ additional files to be compiled with with the C compiler
-> [InstalledUnitId]
-> [UnitId]
-> Stream IO RawCmmGroup a -- Compiled C--
-> IO (FilePath,
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
......@@ -120,7 +120,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> [InstalledUnitId]
-> [UnitId]
-> IO a
outputC dflags filenm cmm_stream packages
......@@ -133,7 +133,7 @@ outputC dflags filenm cmm_stream packages
-- * -#include options from the cmdline and OPTIONS pragmas
-- * the _stub.h file, if there is one.
--
let rts = getPackageDetails dflags rtsUnitId
let rts = unsafeGetUnitInfo dflags rtsUnitId
let cc_injects = unlines (map mk_include (unitIncludes rts))
mk_include h_file =
......@@ -142,7 +142,7 @@ outputC dflags filenm cmm_stream packages
'<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\""
let pkg_names = map installedUnitIdString packages
let pkg_names = map unitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
......@@ -225,7 +225,7 @@ outputForeignStubs dflags mod location stubs
-- we need the #includes from the rts package for the stub files
let rts_includes =
let rts_pkg = getPackageDetails dflags rtsUnitId in
let rts_pkg = unsafeGetUnitInfo dflags rtsUnitId in
concatMap mk_include (unitIncludes rts_pkg)
mk_include i = "#include \"" ++ i ++ "\"\n"
......
......@@ -5,6 +5,7 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.Driver.Finder (
flushFinderCaches,
......@@ -76,7 +77,7 @@ flushFinderCaches hsc_env =
where
this_pkg = thisPackage (hsc_dflags hsc_env)
fc_ref = hsc_FC hsc_env
is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True
is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True
| otherwise = False
addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
......@@ -135,8 +136,8 @@ findPluginModule hsc_env mod_name =
findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findExactModule hsc_env mod =
let dflags = hsc_dflags hsc_env
in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags
then findInstalledHomeModule hsc_env (installedModuleName mod)
in if moduleUnit mod `unitIdEq` thisPackage dflags
then findInstalledHomeModule hsc_env (moduleName mod)
else findPackageModule hsc_env mod
-- -----------------------------------------------------------------------------
......@@ -194,7 +195,7 @@ findExposedPluginPackageModule hsc_env mod_name
findLookupResult :: HscEnv -> LookupResult -> IO FindResult
findLookupResult hsc_env r = case r of
LookupFound m pkg_conf -> do
let im = fst (splitModuleInsts m)
let im = fst (getModuleInstantiation m)
r' <- findPackageModule_ hsc_env im pkg_conf
case r' of
-- TODO: ghc -M is unlikely to do the right thing
......@@ -202,8 +203,8 @@ findLookupResult hsc_env r = case r of
-- instantiated; you probably also need all of the
-- implicit locations from the instances
InstalledFound loc _ -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnitId m))
InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
, fr_mods_hidden = []
, fr_unusables = []
......@@ -212,13 +213,13 @@ findLookupResult hsc_env r = case r of
return (FoundMultiple rs)
LookupHidden pkg_hiddens mod_hiddens ->
return (NotFound{ fr_paths = [], fr_pkg = Nothing
, fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens
, fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens
, fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens
, fr_mods_hidden = map (moduleUnit.fst) mod_hiddens
, fr_unusables = []
, fr_suggestions = [] })
LookupUnusable unusable ->
let unusables' = map get_unusable unusable
get_unusable (m, ModUnusable r) = (moduleUnitId m, r)
get_unusable (m, ModUnusable r) = (moduleUnit m, r)
get_unusable (_, r) =
pprPanic "findLookupResult: unexpected origin" (ppr r)
in return (NotFound{ fr_paths = [], fr_pkg = Nothing
......@@ -245,8 +246,8 @@ modLocationCache hsc_env mod do_this = do
mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
mkHomeInstalledModule dflags mod_name =
let iuid = thisInstalledUnitId dflags
in InstalledModule iuid mod_name
let iuid = thisUnitId dflags
in Module iuid mod_name
-- This returns a module because it's more convenient for users
addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
......@@ -339,7 +340,7 @@ findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findPackageModule hsc_env mod = do
let
dflags = hsc_dflags hsc_env
pkg_id = installedModuleUnitId mod
pkg_id = moduleUnit mod
pkgstate = pkgState dflags
--
case lookupInstalledPackage pkgstate pkg_id of
......@@ -355,7 +356,7 @@ findPackageModule hsc_env mod = do
-- for the appropriate config.
findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult
findPackageModule_ hsc_env mod pkg_conf =
ASSERT2( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId pkg_conf) )
ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
......@@ -381,7 +382,7 @@ findPackageModule_ hsc_env mod pkg_conf =
[one] | MkDepend <- ghcMode dflags -> do
-- there's only one place that this .hi file can be, so
-- don't bother looking for it.
let basename = moduleNameSlashes (installedModuleName mod)
let basename = moduleNameSlashes (moduleName mod)
loc <- mk_hi_loc one basename
return (InstalledFound loc mod)
_otherwise ->
......@@ -413,7 +414,7 @@ searchPathExts paths mod exts
return result
where
basename = moduleNameSlashes (installedModuleName mod)
basename = moduleNameSlashes (moduleName mod)
to_search :: [(FilePath, IO ModLocation)]
to_search = [ (file, fn path basename)
......@@ -424,7 +425,7 @@ searchPathExts paths mod exts
file = base <.> ext
]
search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod)))
search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod)))
search ((file, mk_result) : rest) = do
b <- doesFileExist file
......@@ -649,7 +650,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
where
unambiguousPackages = foldl' unambiguousPackage (Just []) mods
unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
= Just (moduleUnitId m : xs)
= Just (moduleUnit m : xs)
unambiguousPackage _ _ = Nothing
pprMod (m, o) = text "it is bound as" <+> ppr m <+>
......@@ -658,10 +659,10 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
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 (moduleUnitId m)]
then [text "package" <+> ppr (moduleUnit m)]
else [] ++
map ((text "a reexport in package" <+>)
.ppr.packageConfigId) res ++
.ppr.mkUnit) res ++
if f then [text "a package flag"] else []
)
......@@ -714,7 +715,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
text "try running 'ghc-pkg check'." $$
tried_these files dflags
pkg_hidden :: UnitId -> SDoc
pkg_hidden :: Unit -> SDoc
pkg_hidden uid =
text "It is a member of the hidden package"
<+> quotes (ppr uid)
......@@ -758,11 +759,11 @@ cantFindErr cannot_find _ dflags mod_name find_result
fromExposedReexport = res,
fromPackageFlag = f })
| Just True <- e
= parens (text "from" <+> ppr (moduleUnitId mod))
= parens (text "from" <+> ppr (moduleUnit mod))
| f && moduleName mod == m
= parens (text "from" <+> ppr (moduleUnitId mod))
= parens (text "from" <+> ppr (moduleUnit mod))
| (pkg:_) <- res
= parens (text "from" <+> ppr (packageConfigId pkg)
= parens (text "from" <+> ppr (mkUnit pkg)
<> comma <+> text "reexporting" <+> ppr mod)
| f
= parens (text "defined via package flags to be"
......@@ -775,10 +776,10 @@ cantFindErr cannot_find _ dflags mod_name find_result
fromHiddenReexport = rhs })
| Just False <- e
= parens (text "needs flag -package-key"
<+> ppr (moduleUnitId mod))
<+> ppr (moduleUnit mod))
| (pkg:_) <- rhs
= parens (text "needs flag -package-id"
<+> ppr (packageConfigId pkg))
<+> ppr (mkUnit pkg))
| otherwise = Outputable.empty
cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName
......@@ -794,7 +795,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
text "was found" $$ looks_like_srcpkgid pkg
InstalledNotFound files mb_pkg
| Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags)
| Just pkg <- mb_pkg, not (pkg `unitIdEq` thisPackage dflags)
-> not_found_in_package pkg files
| null files
......@@ -808,13 +809,13 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
build_tag = buildTag dflags
pkgstate = pkgState dflags
looks_like_srcpkgid :: InstalledUnitId -> SDoc
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 pkgstate (PackageId (installedUnitIdFS pk))
| (pkg:pkgs) <- searchPackageId pkgstate (PackageId (unitIdFS pk))
= parens (text "This unit ID looks like the source package ID;" $$
text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$
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!
......
......@@ -475,7 +475,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
src_filename = ms_hspp_file mod_summary
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
keep_rn' = gopt Opt_WriteHie dflags || keep_rn
MASSERT( moduleUnitId outer_mod == thisPackage dflags )
MASSERT( moduleUnit outer_mod == thisPackage dflags )
tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
......@@ -1049,7 +1049,7 @@ checkSafeImports tcg_env
imports = imp_mods impInfo -- ImportedMods
imports1 = moduleEnvToList imports -- (Module, [ImportedBy])
imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])
pkgReqs = imp_trust_pkgs impInfo -- [UnitId]
pkgReqs = imp_trust_pkgs impInfo -- [Unit]
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!"
......@@ -1069,11 +1069,11 @@ checkSafeImports tcg_env
= return v1
-- easier interface to work with
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
-- what pkg's to add to our trust requirements
pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->
Bool -> ImportAvails
pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
&& not (safeHaskellModeEnabled dflags) && infPassed
......@@ -1097,7 +1097,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
return $ isEmptyBag errs
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe hsc_env m l = runHsc hsc_env $ do
(self, pkgs) <- hscCheckSafe' m l
good <- isEmptyBag `fmap` getWarnings
......@@ -1111,7 +1111,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 InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' m l = do
dflags <- getDynFlags
(tw, pkgs) <- isModSafe m l
......@@ -1120,9 +1120,9 @@ hscCheckSafe' m l = do
True | isHomePkg dflags m -> return (Nothing, pkgs)
-- TODO: do we also have to check the trust of the instantiation?
-- Not necessary if that is reflected in dependencies
| otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
| otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs)
where
isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe m l = do
dflags <- getDynFlags
iface <- lookup' m
......@@ -1170,7 +1170,7 @@ hscCheckSafe' m l = do
pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The package (" <> ppr (moduleUnitId m)
, text "The package (" <> ppr (moduleUnit m)
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
......@@ -1192,7 +1192,7 @@ hscCheckSafe' m l = do
packageTrusted _ Sf_SafeInferred False _ = True
packageTrusted dflags _ _ m
| isHomePkg dflags m = True
| otherwise = unitIsTrusted $ getPackageDetails dflags (moduleUnitId m)
| otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
......@@ -1212,11 +1212,11 @@ hscCheckSafe' m l = do
isHomePkg :: DynFlags -> Module -> Bool
isHomePkg dflags m
| thisPackage dflags == moduleUnitId m = True
| thisPackage dflags == moduleUnit m = True
| otherwise = False
-- | Check the list of packages are trusted.
checkPkgTrust :: Set InstalledUnitId -> Hsc ()
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust pkgs = do
dflags <- getDynFlags
let errors = S.foldr go [] pkgs
......
......@@ -309,9 +309,9 @@ warnUnusedPackages = do
pit = eps_PIT eps
let loadedPackages
= map (getPackageDetails dflags)
= map (unsafeGetUnitInfo dflags)
. nub . sort
. map moduleUnitId
. map moduleUnit
. moduleEnvKeys
$ pit
......@@ -348,16 +348,16 @@ warnUnusedPackages = do
matching :: DynFlags -> PackageArg -> UnitInfo -> Bool
matching _ (PackageArg str) p = matchingStr str p
matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p
matching dflags (UnitIdArg uid) p = uid == realUnit dflags p
-- For wired-in packages, we have to unwire their id,
-- otherwise they won't match package flags
realUnitId :: DynFlags -> UnitInfo -> UnitId
realUnitId dflags
= unwireUnitId dflags
. DefiniteUnitId
. DefUnitId
. installedUnitInfoId
realUnit :: DynFlags -> UnitInfo -> Unit
realUnit dflags
= unwireUnit dflags
. RealUnit
. Definite
. unitId
-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
......@@ -965,7 +965,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
when (not (null (unitIdsToCheck dflags))) $
when (not (null (instantiatedUnitsToCheck dflags))) $
throwGhcException (ProgramError "Backpack typechecking not supported with -j")
-- The bits of shared state we'll be using:
......@@ -1374,7 +1374,7 @@ upsweep
upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
dflags <- getSessionDynFlags
(res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)
(unitIdsToCheck dflags) done_holes
(instantiatedUnitsToCheck dflags) done_holes
return (res, reverse $ mgModSummaries done)
where
done_holes = emptyUniqSet
......@@ -1405,13 +1405,13 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> [Unit]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' _old_hpt done
[] _ _ uids_to_check _
= do hsc_env <- getSession
liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) uids_to_check
return (Succeeded, done)
upsweep' _old_hpt done
......@@ -1436,13 +1436,13 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
-- our imports when you run --make.
let (ready_uids, uids_to_check')
= partition (\uid -> isEmptyUniqDSet
(unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
(unitFreeModuleHoles uid `uniqDSetMinusUniqSet` done_holes))
uids_to_check
done_holes'
| ms_hsc_src mod == HsigFile
= addOneToUniqSet done_holes (ms_mod_name mod)
| otherwise = done_holes
liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids
liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) ready_uids
-- Remove unwanted tmp files between compilations
liftIO (cleanup hsc_env)
......@@ -1517,16 +1517,17 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'
unitIdsToCheck :: DynFlags -> [UnitId]
unitIdsToCheck dflags =
nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))
-- | Return a list of instantiated units to type check from the PackageState.
--
-- Use explicit (instantiated) units as roots and also return their
-- instantiations that are themselves instantiations and so on recursively.
instantiatedUnitsToCheck :: DynFlags -> [Unit]
instantiatedUnitsToCheck dflags =
nubSort $ concatMap goUnit (explicitPackages (pkgState dflags))
where
goUnitId uid =
case splitUnitIdInsts uid of
(_, Just indef) ->
let insts = indefUnitIdInsts indef
in uid : concatMap (goUnitId . moduleUnitId . snd) insts
_ -> []
goUnit HoleUnit = []
goUnit (RealUnit _) = []
goUnit uid@(VirtUnit i) = uid : concatMap (goUnit . moduleUnit . snd) (instUnitInsts i)
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate dflags location
......
This diff is collapsed.
......@@ -2,14 +2,15 @@ module GHC.Driver.Packages where
import GHC.Prelude
import GHC.Data.FastString
import {-# SOURCE #-} GHC.Driver.Session (DynFlags)
import {-# SOURCE #-} GHC.Types.Module(ComponentId, UnitId, InstalledUnitId)
import {-# SOURCE #-} GHC.Types.Module(IndefUnitId, Unit, UnitId)
data PackageState
data UnitInfoMap
data PackageDatabase
data PackageDatabase unit
emptyPackageState :: PackageState
componentIdString :: ComponentId -> String
mkComponentId :: PackageState -> FastString -> ComponentId
displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String
improveUnitId :: UnitInfoMap -> UnitId -> UnitId
mkIndefUnitId :: PackageState -> FastString -> IndefUnitId
displayUnitId :: PackageState -> UnitId -> Maybe String
improveUnit :: UnitInfoMap -> Unit -> Unit
getUnitInfoMap :: DynFlags -> UnitInfoMap
unitInfoMap :: PackageState -> UnitInfoMap
getPackageState :: DynFlags -> PackageState
updateIndefUnitId :: PackageState -> IndefUnitId -> IndefUnitId
......@@ -490,7 +490,7 @@ link' dflags batch_attempt_linking hpt
return Succeeded
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded dflags staticLink linkables pkg_deps = do
-- if the modification time on the executable is later than the
-- modification times on all of the objects and libraries, then omit
......@@ -1611,13 +1611,13 @@ getLocation src_flavour mod_name = do
-----------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
getHCFilePackages :: FilePath -> IO [InstalledUnitId]
getHCFilePackages :: FilePath -> IO [UnitId]
getHCFilePackages filename =
Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
l <- hGetLine h
case l of
'/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest