Commit 4e8a0607 authored by Edward Z. Yang's avatar Edward Z. Yang

Distinguish between UnitId and InstalledUnitId.

Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 00b530d5
......@@ -161,7 +161,7 @@ withBkpSession cid insts deps session_type do_this = do
TcSession -> newUnitId cid insts
-- No hash passed if no instances
_ | null insts -> newSimpleUnitId cid
| otherwise -> newHashedUnitId cid (Just (hashUnitId cid insts)),
| otherwise -> newDefiniteUnitId cid (Just (hashUnitId cid insts)),
-- Setup all of the output directories according to our hierarchy
objectDir = Just (outdir objectDir),
hiDir = Just (outdir hiDir),
......@@ -207,7 +207,7 @@ compileUnit cid insts = do
lunit <- getSource cid
buildUnit CompSession cid insts lunit
-- Invariant: this NEVER returns HashedUnitId
-- Invariant: this NEVER returns InstalledUnitId
hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps unit = concatMap get_dep (hsunitBody unit)
where
......@@ -281,7 +281,7 @@ buildUnit session cid insts lunit = do
sourcePackageId = SourcePackageId compat_fs,
packageName = compat_pn,
packageVersion = makeVersion [0],
unitId = thisPackage dflags,
unitId = toInstalledUnitId (thisPackage dflags),
instantiatedWith = insts,
-- Slight inefficiency here haha
exposedModules = map (\(m,n) -> (m,Just n)) mods,
......@@ -293,7 +293,7 @@ buildUnit session cid insts lunit = do
-- really used for anything, so we leave it
-- blank for now.
TcSession -> []
_ -> map (unwireUnitId dflags)
_ -> map (toInstalledUnitId . unwireUnitId dflags)
$ deps ++ [ moduleUnitId mod
| (_, mod) <- insts
, not (isHoleModule mod) ],
......@@ -302,6 +302,9 @@ buildUnit session cid insts lunit = do
_ -> obj_files,
importDirs = [ hi_dir ],
exposed = False,
indefinite = case session of
TcSession -> True
_ -> False,
-- nope
hsLibraries = [],
extraLibraries = [],
......@@ -353,7 +356,7 @@ addPackage pkg = do
-- liftIO $ setUnsafeGlobalDynFlags dflags
return ()
-- Precondition: UnitId is NOT HashedUnitId
-- Precondition: UnitId is NOT InstalledUnitId
compileInclude :: Int -> (Int, UnitId) -> BkpM ()
compileInclude n (i, uid) = do
hsc_env <- getSession
......
This diff is collapsed.
......@@ -92,12 +92,12 @@ mkDependencies
-- on M.hi-boot, and hence that we should do the hi-boot consistency
-- check.)
pkgs | th_used = insertList thUnitId (imp_dep_pkgs imports)
pkgs | th_used = insertList (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
sorted_pkgs = sortBy stableUnitIdCmp pkgs
sorted_pkgs = sort pkgs
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
......
......@@ -116,7 +116,7 @@ data PersistentLinkerState
-- The currently-loaded packages; always object code
-- Held, as usual, in dependency order; though I am not sure if
-- that is really important
pkgs_loaded :: ![UnitId],
pkgs_loaded :: ![LinkerUnitId],
-- we need to remember the name of previous temporary DLL/.so
-- libraries so we can link them (see #10322)
......@@ -137,10 +137,10 @@ emptyPLS _ = PersistentLinkerState {
--
-- The linker's symbol table is populated with RTS symbols using an
-- explicit list. See rts/Linker.c for details.
where init_pkgs = [rtsUnitId]
where init_pkgs = map toInstalledUnitId [rtsUnitId]
extendLoadedPkgs :: [UnitId] -> IO ()
extendLoadedPkgs :: [InstalledUnitId] -> IO ()
extendLoadedPkgs pkgs =
modifyPLS_ $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
......@@ -566,7 +566,7 @@ getLinkDeps :: HscEnv -> HomePackageTable
-> Maybe FilePath -- replace object suffices?
-> SrcSpan -- for error messages
-> [Module] -- If you need these
-> IO ([Linkable], [UnitId]) -- ... then link these first
-> IO ([Linkable], [InstalledUnitId]) -- ... then link these first
-- Fails with an IO exception if it can't find enough files
getLinkDeps hsc_env hpt pls replace_osuf span mods
......@@ -604,8 +604,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
-- tree recursively. See bug #936, testcase ghci/prog007.
follow_deps :: [Module] -- modules to follow
-> UniqDSet ModuleName -- accum. module dependencies
-> UniqDSet UnitId -- accum. package dependencies
-> IO ([ModuleName], [UnitId]) -- result
-> UniqDSet InstalledUnitId -- accum. package dependencies
-> IO ([ModuleName], [InstalledUnitId]) -- result
follow_deps [] acc_mods acc_pkgs
= return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
follow_deps (mod:mods) acc_mods acc_pkgs
......@@ -632,7 +632,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps
--
if pkg /= this_pkg
then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' pkg)
then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))
else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
acc_mods' acc_pkgs'
where
......@@ -1126,12 +1126,15 @@ showLS (DLL nm) = "(dynamic) " ++ nm
showLS (DLLPath nm) = "(dynamic) " ++ nm
showLS (Framework nm) = "(framework) " ++ nm
-- TODO: Make this type more precise
type LinkerUnitId = InstalledUnitId
-- | Link exactly the specified packages, and their dependents (unless of
-- course they are already linked). The dependents are linked
-- automatically, and it doesn't matter what order you specify the input
-- packages.
--
linkPackages :: HscEnv -> [UnitId] -> IO ()
linkPackages :: HscEnv -> [LinkerUnitId] -> IO ()
-- NOTE: in fact, since each module tracks all the packages it depends on,
-- we don't really need to use the package-config dependencies.
--
......@@ -1147,7 +1150,7 @@ linkPackages hsc_env new_pkgs = do
modifyPLS_ $ \pls -> do
linkPackages' hsc_env new_pkgs pls
linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState
linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' hsc_env new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
......@@ -1155,7 +1158,7 @@ linkPackages' hsc_env new_pks pls = do
where
dflags = hsc_dflags hsc_env
link :: [UnitId] -> [UnitId] -> IO [UnitId]
link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
......@@ -1163,7 +1166,7 @@ linkPackages' hsc_env new_pks pls = do
| new_pkg `elem` pkgs -- Already linked
= return pkgs
| Just pkg_cfg <- lookupPackage dflags new_pkg
| Just pkg_cfg <- lookupInstalledPackage dflags new_pkg
= do { -- Link dependents first
pkgs' <- link pkgs (depends pkg_cfg)
-- Now link the package itself
......@@ -1171,7 +1174,7 @@ linkPackages' hsc_env new_pks pls = do
; return (new_pkg : pkgs') }
| otherwise
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unitIdString new_pkg))
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))
linkPackage :: HscEnv -> PackageConfig -> IO ()
......
......@@ -276,7 +276,8 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg
; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
; case res of
Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) }
-- TODO: Make sure this error message is good
err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }
-- | Load interface directly for a fully qualified 'Module'. (This is a fairly
-- rare operation, but in particular it is used to load orphan modules
......@@ -572,7 +573,7 @@ moduleFreeHolesPrecise doc_str mod
tryEpsAndHpt dflags eps hpt =
fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)
tryDepsCache eps imod insts =
case lookupModuleEnv (eps_free_holes eps) imod of
case lookupInstalledModuleEnv (eps_free_holes eps) imod of
Just ifhs -> Just (renameFreeHoles ifhs insts)
_otherwise -> Nothing
readAndCache imod insts = do
......@@ -582,7 +583,7 @@ moduleFreeHolesPrecise doc_str mod
let ifhs = mi_free_holes iface
-- Cache it
updateEps_ (\eps ->
eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs })
eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })
return (Succeeded (renameFreeHoles ifhs insts))
Failed err -> return (Failed err)
......@@ -769,7 +770,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
See Trac #8320.
-}
findAndReadIface :: SDoc -> VirginModule
findAndReadIface :: SDoc -> InstalledModule
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
-> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
......@@ -788,7 +789,8 @@ findAndReadIface doc_str mod hi_boot_file
nest 4 (text "reason:" <+> doc_str)])
-- Check for GHC.Prim, and return its static interface
if mod == gHC_PRIM
-- TODO: make this check a function
if mod `installedModuleEq` gHC_PRIM
then do
iface <- getHooked ghcPrimIfaceHook ghcPrimIface
return (Succeeded (iface,
......@@ -799,13 +801,13 @@ findAndReadIface doc_str mod hi_boot_file
hsc_env <- getTopEnv
mb_found <- liftIO (findExactModule hsc_env mod)
case mb_found of
Found loc mod -> do
InstalledFound loc mod -> do
-- Found file, so read it
let file_path = addBootSuffix_maybe hi_boot_file
(ml_hi_file loc)
-- See Note [Home module load error]
if thisPackage dflags == moduleUnitId mod &&
if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&
not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc))
else do r <- read_file file_path
......@@ -815,14 +817,14 @@ findAndReadIface doc_str mod hi_boot_file
traceIf (text "...not found")
dflags <- getDynFlags
return (Failed (cannotFindInterface dflags
(moduleName mod) err))
(installedModuleName mod) err))
where read_file file_path = do
traceIf (text "readIFace" <+> text file_path)
read_result <- readIface mod file_path
case read_result of
Failed err -> return (Failed (badIfaceFile file_path err))
Succeeded iface
| mi_module iface /= mod ->
| not (mod `installedModuleEq` mi_module iface) ->
return (Failed (wrongIfaceModErr iface mod file_path))
| otherwise ->
return (Succeeded (iface, file_path))
......@@ -852,7 +854,7 @@ findAndReadIface doc_str mod hi_boot_file
-- @readIface@ tries just the one file.
readIface :: VirginModule -> FilePath
readIface :: InstalledModule -> FilePath
-> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
-- Failed err <=> file not found, or unreadable, or illegible
-- Succeeded iface <=> successfully found and parsed
......@@ -862,8 +864,10 @@ readIface wanted_mod file_path
readBinIface CheckHiWay QuietBinIFaceReading file_path
; case res of
Right iface
| wanted_mod == actual_mod -> return (Succeeded iface)
| otherwise -> return (Failed err)
-- Same deal
| wanted_mod `installedModuleEq` actual_mod
-> return (Succeeded iface)
| otherwise -> return (Failed err)
where
actual_mod = mi_module iface
err = hiModuleNameMismatchWarn wanted_mod actual_mod
......@@ -884,7 +888,7 @@ initExternalPackageState
= EPS {
eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_free_holes = emptyModuleEnv,
eps_free_holes = emptyInstalledModuleEnv,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
......@@ -1114,7 +1118,7 @@ badIfaceFile file err
= vcat [text "Bad interface file:" <+> text file,
nest 4 err]
hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
hiModuleNameMismatchWarn :: InstalledModule -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod =
-- ToDo: This will fail to have enough qualification when the package IDs
-- are the same
......@@ -1127,11 +1131,11 @@ hiModuleNameMismatchWarn requested_mod read_mod =
, ppr read_mod
]
wrongIfaceModErr :: ModIface -> Module -> String -> SDoc
wrongIfaceModErr iface mod_name file_path
wrongIfaceModErr :: ModIface -> InstalledModule -> String -> SDoc
wrongIfaceModErr iface mod file_path
= sep [text "Interface file" <+> iface_file,
text "contains module" <+> quotes (ppr (mi_module iface)) <> comma,
text "but we were expecting module" <+> quotes (ppr mod_name),
text "but we were expecting module" <+> quotes (ppr mod),
sep [text "Probable cause: the source code which generated",
nest 2 iface_file,
text "has an incompatible module name"
......@@ -1139,7 +1143,7 @@ wrongIfaceModErr iface mod_name file_path
]
where iface_file = doubleQuotes (text file_path)
homeModError :: Module -> ModLocation -> SDoc
homeModError :: InstalledModule -> ModLocation -> SDoc
-- See Note [Home module load error]
homeModError mod location
= text "attempting to use module " <> quotes (ppr mod)
......
......@@ -651,7 +651,7 @@ getOrphanHashes hsc_env mods = do
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
dep_pkgs = sortBy (stableUnitIdCmp `on` fst) (dep_pkgs d),
dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
......@@ -1009,7 +1009,7 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface
loadIface = do
let iface_path = msHiFilePath mod_summary
read_result <- readIface (ms_mod mod_summary) iface_path
read_result <- readIface (ms_installed_mod mod_summary) iface_path
case read_result of
Failed err -> do
traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
......@@ -1107,7 +1107,7 @@ checkHsig mod_summary iface = do
dflags <- getDynFlags
let outer_mod = ms_mod mod_summary
inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
MASSERT( thisPackage dflags == moduleUnitId outer_mod )
MASSERT( moduleUnitId outer_mod == thisPackage dflags )
case inner_mod == mi_semantic_module iface of
True -> up_to_date (text "implementing module unchanged")
False -> return (RecompBecause "implementing module changed")
......@@ -1158,7 +1158,7 @@ checkDependencies hsc_env summary iface
else
return UpToDate
| otherwise
-> if pkg `notElem` (map fst prev_dep_pkgs)
-> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
......
......@@ -378,7 +378,7 @@ tcHiBootIface hsc_src mod
-- to check consistency against, rather than just when we notice
-- that an hi-boot is necessary due to a circular import.
{ read_result <- findAndReadIface
need mod
need (fst (splitModuleInsts mod))
True -- Hi-boot file
; case read_result of {
......
......@@ -50,7 +50,7 @@ codeOutput :: DynFlags
-> FilePath
-> ModLocation
-> ForeignStubs
-> [UnitId]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup () -- Compiled C--
-> IO (FilePath,
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}))
......@@ -107,7 +107,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
-> [UnitId]
-> [InstalledUnitId]
-> IO ()
outputC dflags filenm cmm_stream packages
......@@ -131,7 +131,7 @@ outputC dflags filenm cmm_stream packages
'<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\""
let pkg_names = map unitIdString packages
let pkg_names = map installedUnitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
......
......@@ -402,7 +402,7 @@ link' dflags batch_attempt_linking hpt
return Succeeded
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> 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
......@@ -424,7 +424,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- next, check libraries. XXX this only checks Haskell libraries,
-- not extra_libraries or -l things from the command line.
let pkg_hslibs = [ (libraryDirs c, lib)
| Just c <- map (lookupPackage dflags) pkg_deps,
| Just c <- map (lookupInstalledPackage dflags) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
......@@ -438,7 +438,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- Returns 'False' if it was, and we can avoid linking, because the
-- previous binary was linked with "the same options".
checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool
checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool
checkLinkInfo dflags pkg_deps exe_file
| not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
-- ToDo: Windows and OS X do not use the ELF binary format, so
......@@ -1652,7 +1652,7 @@ mkExtraObjToLinkIntoBinary dflags = do
-- this was included as inline assembly in the main.c file but this
-- is pretty fragile. gas gets upset trying to calculate relative offsets
-- that span the .note section (notably .text) when debug info is present
mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary dflags dep_packages = do
link_info <- getLinkInfo dflags dep_packages
......@@ -1677,7 +1677,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do
-- | Return the "link info" string
--
-- See Note [LinkInfo section]
getLinkInfo :: DynFlags -> [UnitId] -> IO String
getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String
getLinkInfo dflags dep_packages = do
package_link_opts <- getPackageLinkOpts dflags dep_packages
pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
......@@ -1714,13 +1714,13 @@ not follow the specified record-based format (see #11022).
-----------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
getHCFilePackages :: FilePath -> IO [UnitId]
getHCFilePackages :: FilePath -> IO [InstalledUnitId]
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 ->
return (map stringToUnitId (words rest))
return (map stringToInstalledUnitId (words rest))
_other ->
return []
......@@ -1737,10 +1737,10 @@ getHCFilePackages filename =
-- read any interface files), so the user must explicitly specify all
-- the packages.
linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary = linkBinary' False
linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary' staticLink dflags o_files dep_packages = do
let platform = targetPlatform dflags
mySettings = settings dflags
......@@ -1987,7 +1987,7 @@ maybeCreateManifest dflags exe_filename
| otherwise = return []
linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
......@@ -1997,7 +1997,7 @@ linkDynLibCheck dflags o_files dep_packages
linkDynLib dflags o_files dep_packages
linkStaticLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkStaticLibCheck dflags o_files dep_packages
= do
when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $
......@@ -2229,7 +2229,7 @@ haveRtsOptsFlags dflags =
-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags = do
dirs <- getPackageIncludePath dflags [rtsUnitId]
dirs <- getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]
found <- filterM doesFileExist (map (</> "ghcversion.h") dirs)
case found of
......
This diff is collapsed.
......@@ -576,7 +576,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 [UnitId]
setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags'', preload) <- liftIO $ initPackages dflags'
......@@ -586,7 +586,7 @@ setSessionDynFlags dflags = do
return preload
-- | Sets the program 'DynFlags'.
setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setProgramDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags'', preload) <- liftIO $ initPackages dflags'
......@@ -1435,7 +1435,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, [UnitId])
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [InstalledUnitId])
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
......
......@@ -1916,7 +1916,8 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
required_by_imports <- implicitRequirements hsc_env the_imps
return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src,
return (ModSummary { ms_mod = mod,
ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
ms_hspp_opts = dflags',
......
......@@ -179,7 +179,7 @@ newHscEnv dflags = do
eps_var <- newIORef initExternalPackageState
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us allKnownKeyNames)
fc_var <- newIORef emptyModuleEnv
fc_var <- newIORef emptyInstalledModuleEnv
#ifdef GHCI
iserv_mvar <- newMVar Nothing
#endif
......@@ -444,12 +444,14 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do
let hsc_src = ms_hsc_src mod_summary
dflags = hsc_dflags hsc_env
outer_mod = ms_mod mod_summary
inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
mod_name = moduleName outer_mod
outer_mod' = mkModule (thisPackage dflags) mod_name
inner_mod = canonicalizeHomeModule dflags mod_name
src_filename = ms_hspp_file mod_summary
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
MASSERT( moduleUnitId outer_mod == thisPackage dflags )
if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod real_loc
then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
do hpm <- case mb_rdr_module of
Just hpm -> return hpm
......@@ -1021,7 +1023,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, [UnitId])
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [InstalledUnitId])
hscGetSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
(self, pkgs) <- hscCheckSafe' dflags m l
......@@ -1035,15 +1037,17 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
-- Return (regardless of trusted or not) if the trust type requires the modules
-- 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' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe UnitId, [UnitId])
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, [InstalledUnitId])
hscCheckSafe' dflags m l = do
(tw, pkgs) <- isModSafe m l
case tw of
False -> return (Nothing, pkgs)
True | isHomePkg m -> return (Nothing, pkgs)
| otherwise -> return (Just $ moduleUnitId m, 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)
where
isModSafe :: Module -> SrcSpan -> Hsc (Bool, [UnitId])
isModSafe :: Module -> SrcSpan -> Hsc (Bool, [InstalledUnitId])
isModSafe m l = do
iface <- lookup' m
case iface of
......@@ -1123,7 +1127,7 @@ hscCheckSafe' dflags m l = do
| otherwise = False
-- | Check the list of packages are trusted.
checkPkgTrust :: DynFlags -> [UnitId] -> Hsc ()
checkPkgTrust :: DynFlags -> [InstalledUnitId] -> Hsc ()
checkPkgTrust dflags pkgs =
case errors of
[] -> return ()
......@@ -1131,7 +1135,7 @@ checkPkgTrust dflags pkgs =
where
errors = catMaybes $ map go pkgs
go pkg
| trusted $ getPackageDetails dflags pkg
| trusted $ getInstalledPackageDetails dflags pkg
= Nothing
| otherwise
= Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
......
......@@ -10,7 +10,7 @@
module HscTypes (
-- * compilation state
HscEnv(..), hscEPS,
FinderCache, FindResult(..),
FinderCache, FindResult(..), InstalledFindResult(..),
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
HscStatus(..),
......@@ -26,7 +26,7 @@ module HscTypes (
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods, ImportedModsVal(..),
ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary,
ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
SourceModified(..),
......@@ -771,16 +771,18 @@ prepareAnnotations hsc_env mb_guts = do
-- modules along the search path. On @:load@, we flush the entire
-- contents of this cache.
--
-- Although the @FinderCache@ range is 'FindResult' for convenience,
-- in fact it will only ever contain 'Found' or 'NotFound' entries.
--
type FinderCache = VirginModuleEnv FindResult
type FinderCache = InstalledModuleEnv InstalledFindResult
data InstalledFindResult
= InstalledFound ModLocation InstalledModule
| InstalledNoPackage InstalledUnitId
| InstalledNotFound [FilePath] (Maybe InstalledUnitId)
-- | The result of searching for an imported module.
--
-- NB: FindResult manages both user source-import lookups
-- (which can result in 'Module') as well as direct imports
-- for interfaces (which always result in 'VirginModule').
-- for interfaces (which always result in 'InstalledModule').
data FindResult
= Found ModLocation Module
-- ^ The module was found
......@@ -1272,8 +1274,8 @@ data CgGuts
-- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to
-- generate #includes for C code gen
cg_dep_pkgs :: ![InstalledUnitId], -- ^ 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
}
......@@ -2240,7 +2242,7 @@ data Dependencies
-- I.e. modules that this one imports, or that are in the
-- dep_mods of those directly-imported modules
, dep_pkgs :: [(UnitId, Bool)]
, dep_pkgs :: [(InstalledUnitId, Bool)]
-- ^ All packages transitively below this module
-- I.e. packages to which this module's direct imports belong,
-- or that are in the dep_pkgs of those modules
......@@ -2449,7 +2451,7 @@ data ExternalPackageState
--
-- * Deprecations and warnings
eps_free_holes :: ModuleEnv (UniqDSet ModuleName),
eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName),
-- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on
-- the 'eps_PIT' for this information, EXCEPT that when
-- we do dependency analysis, we need to look at the
......@@ -2602,6 +2604,9 @@ data ModSummary
-- ^ The actual preprocessed source, if we have it
}
ms_installed_mod :: ModSummary -> InstalledModule
ms_installed_mod = fst . splitModuleInsts . ms_mod
ms_mod_name :: ModSummary -> ModuleName
ms_mod_name = moduleName . ms_mod
......
......@@ -12,6 +12,8 @@ module PackageConfig (
-- * UnitId
packageConfigId,
expandedPackageConfigId,
definitePackageConfigId,
installedPackageConfigId,
-- * The PackageConfig type: information about a package
PackageConfig,
......@@ -35,6 +37,7 @@ import FastString
import Outputable
import Module
import Unique
import UniqDSet
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,
......@@ -44,7 +47,7 @@ type PackageConfig = InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
Module.UnitId
Module.InstalledUnitId
Module.UnitId
Module.ModuleName
Module.Module
......@@ -129,11 +132,21 @@ pprPackageConfig InstalledPackageInfo {..} =
-- version is, so these are handled specially; see #wired_in_packages#.
-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig'
installedPackageConfigId :: PackageConfig -> InstalledUnitId
installedPackageConfigId = unitId
packageConfigId :: PackageConfig -> UnitId
packageConfigId = unitId
packageConfigId p =
if indefinite p
then newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
else DefiniteUnitId (DefUnitId (unitId p))
expandedPackageConfigId :: PackageConfig -> UnitId
expandedPackageConfigId p =
case instantiatedWith p of
[] -> packageConfigId p
_ -> newUnitId (unitIdComponentId (packageConfigId p)) (instantiatedWith p)