Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
4e8a0607
Commit
4e8a0607
authored
Oct 06, 2016
by
Edward Z. Yang
Browse files
Distinguish between UnitId and InstalledUnitId.
Signed-off-by:
Edward Z. Yang
<
ezyang@cs.stanford.edu
>
parent
00b530d5
Changes
42
Expand all
Hide whitespace changes
Inline
Side-by-side
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
->
new
Hashed
UnitId
cid
(
Just
(
hashUnitId
cid
insts
)),
|
otherwise
->
new
Definite
UnitId
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
Hash
edUnitId
-- Invariant: this NEVER returns
Install
edUnitId
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
Hash
edUnitId
-- Precondition: UnitId is NOT
Install
edUnitId
compileInclude
::
Int
->
(
Int
,
UnitId
)
->
BkpM
()
compileInclude
n
(
i
,
uid
)
=
do
hsc_env
<-
getSession
...
...
compiler/basicTypes/Module.hs
View file @
4e8a0607
This diff is collapsed.
Click to expand it.
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
=
sort
By
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
::
!
[
Linker
UnitId
],
-- 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
::
[
Installed
UnitId
]
->
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
],
[
Installed
UnitId
])
-- ... 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
Installed
UnitId
-- accum. package dependencies
->
IO
([
ModuleName
],
[
Installed
UnitId
])
-- 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
->
[
Linker
UnitId
]
->
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
->
[
Linker
UnitId
]
->
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
::
[
Linker
UnitId
]
->
[
Linker
UnitId
]
->
IO
[
Linker
UnitId
]
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
<-
lookup
Installed
Package
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: "
++
un
itIdString
new_pkg
))
=
throwGhcExceptionIO
(
CmdLineError
(
"unknown package: "
++
un
packFS
(
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
lookup
Installed
ModuleEnv
(
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
=
extend
Installed
ModuleEnv
(
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
->
Virgin
Module
findAndReadIface
::
SDoc
->
Installed
Module
->
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
Installed
Found
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
(
m
oduleName
mod
)
err
))
(
installedM
oduleName
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
::
Virgin
Module
->
FilePath
readIface
::
Installed
Module
->
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
=
empty
Installed
ModuleEnv
,
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
::
Installed
Module
->
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
->
Installed
Module
->
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
::
Installed
Module
->
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
]
->
[
Installed
UnitId
]
->
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
]
->
[
Installed
UnitId
]
->
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
u
nitIdString
packages
let
pkg_names
=
map
installedU
nitIdString
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
]
->
[
Installed
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
...
...
@@ -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
(
lookup
Installed
Package
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
->
[
Installed
UnitId
]
->
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
->
[
Installed
UnitId
]
->
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
->
[
Installed
UnitId
]
->
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
[
Installed
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
->
return
(
map
stringToUnitId
(
words
rest
))
return
(
map
stringTo
Installed
UnitId
(
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
]
->
[
Installed
UnitId
]
->
IO
()
linkBinary
=
linkBinary'
False
linkBinary'
::
Bool
->
DynFlags
->
[
FilePath
]
->
[
UnitId
]
->
IO
()
linkBinary'
::
Bool
->
DynFlags
->
[
FilePath
]
->
[
Installed
UnitId
]
->
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
]
->
[
Installed
UnitId
]
->
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
]
->
[
Installed
UnitId
]
->
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
->
(
filter
Installed
ModuleEnv
is_ext
fm
,
()
)
where
this_pkg
=
thisPackage
(
hsc_dflags
hsc_env
)
fc_ref
=
hsc_FC
hsc_env
is_ext
mod
_
|
m
oduleUnitId
mod
/=
this_pkg
=
True
is_ext
mod
_
|
not
(
installedM
oduleUnitId
mod
`
installedUnitIdEq
`
this_pkg
)
=
True
|
otherwise
=
False
addToFinderCache
::
IORef
FinderCache
->
Module
->
FindResult
->
IO
()
addToFinderCache
::
IORef
FinderCache
->
Installed
Module
->
Installed
FindResult
->
IO
()
addToFinderCache
ref
key
val
=
atomicModifyIORef'
ref
$
\
c
->
(
extendModuleEnv
c
key
val
,
()
)
atomicModifyIORef'
ref
$
\
c
->
(
extend
Installed
ModuleEnv
c
key
val
,
()
)
removeFromFinderCache
::
IORef
FinderCache
->
Module
->
IO
()
removeFromFinderCache
::
IORef
FinderCache
->
Installed
Module
->
IO
()
removeFromFinderCache
ref
key
=
atomicModifyIORef'
ref
$
\
c
->
(
delModuleEnv
c
key
,
()
)
atomicModifyIORef'
ref
$
\
c
->
(
del
Installed
ModuleEnv
c
key
,
()
)
lookupFinderCache
::
IORef
FinderCache
->
Virgin
Module
->
IO
(
Maybe
FindResult
)
lookupFinderCache
::
IORef
FinderCache
->
Installed
Module
->
IO
(
Maybe
Installed
FindResult
)
lookupFinderCache
ref
key
=
do
c
<-
readIORef
ref
return
$!
lookupModuleEnv
c
key
return
$!
lookup
Installed
ModuleEnv
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
->
Virgin
Module
->
IO
FindResult
findExactModule
::
HscEnv
->
Installed
Module
->
IO
Installed
FindResult
findExactModule
hsc_env
mod
=
let
dflags
=
hsc_dflags
hsc_env
in
if
m
oduleUnitId
mod
==
thisPackage
dflags
then
findHomeModule
hsc_env
(
m
oduleName
mod
)
in
if
installedM
oduleUnitId
mod
`
installedUnitIdEq
`
thisPackage
dflags
then
find
Installed
HomeModule
hsc_env
(
installedM
oduleName
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
Installed
FindResult
->
IO
Installed
FindResult
homeSearchCache
hsc_env
mod_name
do_this
=
do
let
mod
=
mk
Module
(
thisPackag
e
(
hsc_dflags
hsc_env
)
)
mod_name
let
mod
=
mk
HomeInstalledModul
e
(
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
->
Virgin
Module
->
IO
FindResult
->
IO
FindResult
modLocationCache
::
HscEnv
->
Installed
Module
->
IO
Installed
FindResult
->
IO
Installed
FindResult
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
=
mk
Module
(
thisPackag
e
(
hsc_dflags
hsc_env
)
)
mod_name
addToFinderCache
(
hsc_FC
hsc_env
)
mod
(
Found
loc
mod
)
return
mod
let
mod
=
mk
HomeInstalledModul
e
(
hsc_dflags
hsc_env
)
mod_name
addToFinderCache
(
hsc_FC
hsc_env
)
mod
(
Installed
Found
loc
mod
)
return
(
mkModule
(
thisPackage
(
hsc_dflags
hsc_env
))
mod_name
)
uncacheModule
::
HscEnv
->
ModuleName
->
IO
()
uncacheModule
hsc_env
mod
=
do
let
this_pkg
=
thisPackag
e
(
hsc_dflags
hsc_env
)
removeFromFinderCache
(
hsc_FC
hsc_env
)
(
mkModule
this_pkg
mod
)
uncacheModule
hsc_env
mod
_name
=
do
let
mod
=
mkHomeInstalledModul
e
(
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