Skip to content

GitLab

GHC
GHC
Commit 4e8a0607 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files
Options

Distinguish between UnitId and InstalledUnitId. 

Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 00b530d5
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 700 additions and 432 deletions
compiler/backpack/DriverBkp.hs
View file @ 4e8a0607
......@@ -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
......
compiler/basicTypes/Module.hs
View file @ 4e8a0607
This diff is collapsed.
compiler/deSugar/Desugar.hs
View file @ 4e8a0607
......@@ -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
......
compiler/ghci/Linker.hs
View file @ 4e8a0607
......@@ -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 ()
......
compiler/iface/LoadIface.hs
View file @ 4e8a0607
......@@ -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)
......
compiler/iface/MkIface.hs
View file @ 4e8a0607
......@@ -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) <>
......
compiler/iface/TcIface.hs
View file @ 4e8a0607
......@@ -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 {
......
compiler/main/CodeOutput.hs
View file @ 4e8a0607
......@@ -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")
......
compiler/main/DriverPipeline.hs
View file @ 4e8a0607
......@@ -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
......
compiler/main/Finder.hs
View file @ 4e8a0607
......@@ -71,25 +71,25 @@ type BaseName = String -- Basename of file
-- assumed to not move around during a session.
flushFinderCaches :: HscEnv -> IO ()
flushFinderCaches hsc_env =
atomicModifyIORef' fc_ref $ \fm -> (filterModuleEnv is_ext fm, ())
atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
where
this_pkg = thisPackage (hsc_dflags hsc_env)
fc_ref = hsc_FC hsc_env
is_ext mod _ | moduleUnitId mod /= this_pkg = True
is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True
| otherwise = False
addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO ()
addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache ref key val =
atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ())
atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
removeFromFinderCache :: IORef FinderCache -> Module -> IO ()
removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()
removeFromFinderCache ref key =
atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ())
atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult)
lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
lookupFinderCache ref key = do
c <- readIORef ref
return $! lookupModuleEnv c key
return $! lookupInstalledModuleEnv c key
-- -----------------------------------------------------------------------------
-- The three external entry points
......@@ -131,11 +131,11 @@ findPluginModule hsc_env mod_name =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
findExactModule :: HscEnv -> VirginModule -> IO FindResult
findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findExactModule hsc_env mod =
let dflags = hsc_dflags hsc_env
in if moduleUnitId mod == thisPackage dflags
then findHomeModule hsc_env (moduleName mod)
in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags
then findInstalledHomeModule hsc_env (installedModuleName mod)
else findPackageModule hsc_env mod
-- -----------------------------------------------------------------------------
......@@ -169,9 +169,9 @@ orIfNotFound this or_this = do
-- been done. Otherwise, do the lookup (with the IO action) and save
-- the result in the finder cache and the module location cache (if it
-- was successful.)
homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult
homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
homeSearchCache hsc_env mod_name do_this = do
let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
modLocationCache hsc_env mod do_this
findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
......@@ -190,8 +190,20 @@ findExposedPluginPackageModule hsc_env mod_name
findLookupResult :: HscEnv -> LookupResult -> IO FindResult
findLookupResult hsc_env r = case r of
LookupFound m pkg_conf ->
findPackageModule_ hsc_env m pkg_conf
LookupFound m pkg_conf -> do
let im = fst (splitModuleInsts m)
r' <- findPackageModule_ hsc_env im pkg_conf
case r' of
-- TODO: ghc -M is unlikely to do the right thing
-- with just the location of the thing that was
-- 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)
, fr_pkgs_hidden = []
, fr_mods_hidden = []
, fr_suggestions = []})
LookupMultiple rs ->
return (FoundMultiple rs)
LookupHidden pkg_hiddens mod_hiddens ->
......@@ -205,7 +217,7 @@ findLookupResult hsc_env r = case r of
, fr_mods_hidden = []
, fr_suggestions = suggest })
modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult
modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
modLocationCache hsc_env mod do_this = do
m <- lookupFinderCache (hsc_FC hsc_env) mod
case m of
......@@ -215,20 +227,43 @@ modLocationCache hsc_env mod do_this = do
addToFinderCache (hsc_FC hsc_env) mod result
return result
mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
mkHomeInstalledModule dflags mod_name =
let iuid = fst (splitUnitIdInsts (thisPackage dflags))
in InstalledModule iuid mod_name
-- This returns a module because it's more convenient for users
addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder hsc_env mod_name loc = do
let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
addToFinderCache (hsc_FC hsc_env) mod (Found loc mod)
return mod
let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)
uncacheModule :: HscEnv -> ModuleName -> IO ()
uncacheModule hsc_env mod = do
let this_pkg = thisPackage (hsc_dflags hsc_env)
removeFromFinderCache (hsc_FC hsc_env) (mkModule this_pkg mod)
uncacheModule hsc_env mod_name = do
let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
removeFromFinderCache (hsc_FC hsc_env) mod
-- -----------------------------------------------------------------------------
-- The internal workers
findHomeModule :: HscEnv -> ModuleName -> IO FindResult
findHomeModule hsc_env mod_name = do
r <- findInstalledHomeModule hsc_env mod_name
return $ case r of
InstalledFound loc _ -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
fr_suggestions = []
}
where
dflags = hsc_dflags hsc_env
uid = thisPackage dflags
-- | Implements the search for a module name in the home package only. Calling
-- this function directly is usually *not* what you want; currently, it's used