{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections, RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module GHC.Linker.Deps
( LinkDepsOpts (..)
, LinkDeps (..)
, getLinkDeps
)
where
import GHC.Prelude
import GHC.Platform.Ways
import GHC.Runtime.Interpreter
import GHC.Linker.Types
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Error
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.WholeCoreBindings
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
import GHC.Iface.Errors.Types
import GHC.Iface.Errors.Ppr
import GHC.Utils.Misc
import GHC.Unit.Home
import GHC.Data.Maybe
import Control.Monad
import Control.Applicative
import qualified Data.Set as Set
import qualified Data.Map as M
import Data.List (isSuffixOf)
import Data.Either
import System.FilePath
import System.Directory
data LinkDepsOpts = LinkDepsOpts
{ LinkDepsOpts -> FilePath
ldObjSuffix :: !String
, LinkDepsOpts -> Bool
ldOneShotMode :: !Bool
, LinkDepsOpts -> ModuleGraph
ldModuleGraph :: !ModuleGraph
, LinkDepsOpts -> UnitEnv
ldUnitEnv :: !UnitEnv
, LinkDepsOpts -> SDocContext
ldPprOpts :: !SDocContext
, LinkDepsOpts -> FinderCache
ldFinderCache :: !FinderCache
, LinkDepsOpts -> FinderOpts
ldFinderOpts :: !FinderOpts
, LinkDepsOpts -> Bool
ldUseByteCode :: !Bool
, LinkDepsOpts -> DiagnosticOpts IfaceMessage
ldMsgOpts :: !(DiagnosticOpts IfaceMessage)
, LinkDepsOpts -> Ways
ldWays :: !Ways
, LinkDepsOpts
-> SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
ldLoadIface :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
}
data LinkDeps = LinkDeps
{ LinkDeps -> [Linkable]
ldNeededLinkables :: [Linkable]
, LinkDeps -> [Linkable]
ldAllLinkables :: [Linkable]
, LinkDeps -> [UnitId]
ldUnits :: [UnitId]
, LinkDeps -> UniqDSet UnitId
ldNeededUnits :: UniqDSet UnitId
}
getLinkDeps
:: LinkDepsOpts
-> Interp
-> LoaderState
-> SrcSpan
-> [Module]
-> IO LinkDeps
getLinkDeps :: LinkDepsOpts
-> Interp -> LoaderState -> SrcSpan -> [Module] -> IO LinkDeps
getLinkDeps LinkDepsOpts
opts Interp
interp LoaderState
pls SrcSpan
span [Module]
mods = do
Maybe FilePath
maybe_normal_osuf <- LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay LinkDepsOpts
opts Interp
interp SrcSpan
span
LinkDepsOpts
-> LoaderState
-> Maybe FilePath
-> SrcSpan
-> [Module]
-> IO LinkDeps
get_link_deps LinkDepsOpts
opts LoaderState
pls Maybe FilePath
maybe_normal_osuf SrcSpan
span [Module]
mods
get_link_deps
:: LinkDepsOpts
-> LoaderState
-> Maybe FilePath
-> SrcSpan
-> [Module]
-> IO LinkDeps
get_link_deps :: LinkDepsOpts
-> LoaderState
-> Maybe FilePath
-> SrcSpan
-> [Module]
-> IO LinkDeps
get_link_deps LinkDepsOpts
opts LoaderState
pls Maybe FilePath
maybe_normal_osuf SrcSpan
span [Module]
mods = do
([Module]
mods_s, UniqDSet UnitId
pkgs_s) <-
if LinkDepsOpts -> Bool
ldOneShotMode LinkDepsOpts
opts
then [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps ((Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Module -> Bool
isInteractiveModule [Module]
mods)
UniqDSet Module
forall a. UniqDSet a
emptyUniqDSet UniqDSet UnitId
forall a. UniqDSet a
emptyUniqDSet;
else do
([UniqDSet UnitId]
pkgs, [Maybe Module]
mmods) <- [(UniqDSet UnitId, Maybe Module)]
-> ([UniqDSet UnitId], [Maybe Module])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(UniqDSet UnitId, Maybe Module)]
-> ([UniqDSet UnitId], [Maybe Module]))
-> IO [(UniqDSet UnitId, Maybe Module)]
-> IO ([UniqDSet UnitId], [Maybe Module])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModNodeKeyWithUid -> IO (UniqDSet UnitId, Maybe Module))
-> [ModNodeKeyWithUid] -> IO [(UniqDSet UnitId, Maybe Module)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ModNodeKeyWithUid -> IO (UniqDSet UnitId, Maybe Module)
get_mod_info [ModNodeKeyWithUid]
all_home_mods
([Module], UniqDSet UnitId) -> IO ([Module], UniqDSet UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe Module] -> [Module]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Module]
mmods, [UniqDSet UnitId] -> UniqDSet UnitId
forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets (UniqDSet UnitId
init_pkg_set UniqDSet UnitId -> [UniqDSet UnitId] -> [UniqDSet UnitId]
forall a. a -> [a] -> [a]
: [UniqDSet UnitId]
pkgs))
let
([Module]
mods_needed, [Linkable]
links_got) = [Either Module Linkable] -> ([Module], [Linkable])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((Module -> Either Module Linkable)
-> [Module] -> [Either Module Linkable]
forall a b. (a -> b) -> [a] -> [b]
map Module -> Either Module Linkable
split_mods [Module]
mods_s)
pkgs_needed :: [UnitId]
pkgs_needed = UniqDFM UnitId UnitId -> [UnitId]
forall key elt. UniqDFM key elt -> [elt]
eltsUDFM (UniqDFM UnitId UnitId -> [UnitId])
-> UniqDFM UnitId UnitId -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UniqDSet UnitId -> UniqDFM UnitId UnitId
forall a. UniqDSet a -> UniqDFM a a
getUniqDSet UniqDSet UnitId
pkgs_s UniqDFM UnitId UnitId
-> UniqDFM UnitId LoadedPkgInfo -> UniqDFM UnitId UnitId
forall key elt1 elt2.
UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1
`minusUDFM` LoaderState -> UniqDFM UnitId LoadedPkgInfo
pkgs_loaded LoaderState
pls
split_mods :: Module -> Either Module Linkable
split_mods Module
mod =
let is_linked :: Maybe Linkable
is_linked = ModuleEnv Linkable -> Module -> Maybe Linkable
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv (LoaderState -> ModuleEnv Linkable
objs_loaded LoaderState
pls) Module
mod
Maybe Linkable -> Maybe Linkable -> Maybe Linkable
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ModuleEnv Linkable -> Module -> Maybe Linkable
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv (LoaderState -> ModuleEnv Linkable
bcos_loaded LoaderState
pls) Module
mod
in case Maybe Linkable
is_linked of
Just Linkable
linkable -> Linkable -> Either Module Linkable
forall a b. b -> Either a b
Right Linkable
linkable
Maybe Linkable
Nothing -> Module -> Either Module Linkable
forall a b. a -> Either a b
Left Module
mod
[Linkable]
lnks_needed <- (Module -> IO Linkable) -> [Module] -> IO [Linkable]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> Module -> IO Linkable
get_linkable (LinkDepsOpts -> FilePath
ldObjSuffix LinkDepsOpts
opts)) [Module]
mods_needed
LinkDeps -> IO LinkDeps
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LinkDeps -> IO LinkDeps) -> LinkDeps -> IO LinkDeps
forall a b. (a -> b) -> a -> b
$ LinkDeps
{ ldNeededLinkables :: [Linkable]
ldNeededLinkables = [Linkable]
lnks_needed
, ldAllLinkables :: [Linkable]
ldAllLinkables = [Linkable]
links_got [Linkable] -> [Linkable] -> [Linkable]
forall a. [a] -> [a] -> [a]
++ [Linkable]
lnks_needed
, ldUnits :: [UnitId]
ldUnits = [UnitId]
pkgs_needed
, ldNeededUnits :: UniqDSet UnitId
ldNeededUnits = UniqDSet UnitId
pkgs_s
}
where
mod_graph :: ModuleGraph
mod_graph = LinkDepsOpts -> ModuleGraph
ldModuleGraph LinkDepsOpts
opts
unit_env :: UnitEnv
unit_env = LinkDepsOpts -> UnitEnv
ldUnitEnv LinkDepsOpts
opts
make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)
make_deps_loop :: (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId, Set NodeKey)
found [] = (UniqDSet UnitId, Set NodeKey)
found
make_deps_loop found :: (UniqDSet UnitId, Set NodeKey)
found@(UniqDSet UnitId
found_units, Set NodeKey
found_mods) (ModNodeKeyWithUid
nk:[ModNodeKeyWithUid]
nexts)
| ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
nk NodeKey -> Set NodeKey -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NodeKey
found_mods = (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId, Set NodeKey)
found [ModNodeKeyWithUid]
nexts
| Bool
otherwise =
case NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
nk) (ModuleGraph -> Map NodeKey (Set NodeKey)
mgTransDeps ModuleGraph
mod_graph) of
Just Set NodeKey
trans_deps ->
let deps :: Set NodeKey
deps = NodeKey -> Set NodeKey -> Set NodeKey
forall a. Ord a => a -> Set a -> Set a
Set.insert (ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
nk) Set NodeKey
trans_deps
todo_boot_mods :: [ModNodeKeyWithUid]
todo_boot_mods = [ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
NotBoot) UnitId
uid | NodeKey_Module (ModNodeKeyWithUid (GWIB ModuleName
mn IsBootInterface
IsBoot) UnitId
uid) <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
trans_deps]
in (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId
found_units, Set NodeKey
deps Set NodeKey -> Set NodeKey -> Set NodeKey
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set NodeKey
found_mods) ([ModNodeKeyWithUid]
todo_boot_mods [ModNodeKeyWithUid] -> [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
forall a. [a] -> [a] -> [a]
++ [ModNodeKeyWithUid]
nexts)
Maybe (Set NodeKey)
Nothing ->
let (ModNodeKeyWithUid ModuleNameWithIsBoot
_ UnitId
uid) = ModNodeKeyWithUid
nk
in (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId -> UnitId -> UniqDSet UnitId
forall a. Uniquable a => UniqDSet a -> a -> UniqDSet a
addOneToUniqDSet UniqDSet UnitId
found_units UnitId
uid, Set NodeKey
found_mods) [ModNodeKeyWithUid]
nexts
mkNk :: Module -> ModNodeKeyWithUid
mkNk Module
m = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m) IsBootInterface
NotBoot) (Module -> UnitId
moduleUnitId Module
m)
(UniqDSet UnitId
init_pkg_set, Set NodeKey
all_deps) = (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId
forall a. UniqDSet a
emptyUniqDSet, Set NodeKey
forall a. Set a
Set.empty) ([ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey))
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
forall a b. (a -> b) -> a -> b
$ (Module -> ModNodeKeyWithUid) -> [Module] -> [ModNodeKeyWithUid]
forall a b. (a -> b) -> [a] -> [b]
map Module -> ModNodeKeyWithUid
mkNk ((Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Module -> Bool
isInteractiveModule [Module]
mods)
all_home_mods :: [ModNodeKeyWithUid]
all_home_mods = [ModNodeKeyWithUid
with_uid | NodeKey_Module ModNodeKeyWithUid
with_uid <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
all_deps]
get_mod_info :: ModNodeKeyWithUid -> IO (UniqDSet UnitId, Maybe Module)
get_mod_info (ModNodeKeyWithUid ModuleNameWithIsBoot
gwib UnitId
uid) =
case HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo
lookupHug (UnitEnv -> HomeUnitGraph
ue_home_unit_graph UnitEnv
unit_env) UnitId
uid (ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
gwib) of
Just HomeModInfo
hmi ->
let iface :: ModIface
iface = (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
mmod :: IO (Maybe Module)
mmod = case ModIface -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src ModIface
iface of
HscSource
HsBootFile -> Module -> IO (Maybe Module)
forall a. Module -> IO a
link_boot_mod_error (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface)
HscSource
_ -> Maybe Module -> IO (Maybe Module)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Module -> IO (Maybe Module))
-> Maybe Module -> IO (Maybe Module)
forall a b. (a -> b) -> a -> b
$ Module -> Maybe Module
forall a. a -> Maybe a
Just (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface)
in ([UnitId] -> UniqDSet UnitId
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet ([UnitId] -> UniqDSet UnitId) -> [UnitId] -> UniqDSet UnitId
forall a b. (a -> b) -> a -> b
$ Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList (Set UnitId -> [UnitId]) -> Set UnitId -> [UnitId]
forall a b. (a -> b) -> a -> b
$ Dependencies -> Set UnitId
dep_direct_pkgs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface),) (Maybe Module -> (UniqDSet UnitId, Maybe Module))
-> IO (Maybe Module) -> IO (UniqDSet UnitId, Maybe Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Module)
mmod
Maybe HomeModInfo
Nothing -> LinkDepsOpts -> SDoc -> IO (UniqDSet UnitId, Maybe Module)
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (SDoc -> IO (UniqDSet UnitId, Maybe Module))
-> SDoc -> IO (UniqDSet UnitId, Maybe Module)
forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"getLinkDeps: Home module not loaded" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
gwib) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid
follow_deps :: [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps :: [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps [] UniqDSet Module
acc_mods UniqDSet UnitId
acc_pkgs
= ([Module], UniqDSet UnitId) -> IO ([Module], UniqDSet UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqDSet Module -> [Module]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet Module
acc_mods, UniqDSet UnitId
acc_pkgs)
follow_deps (Module
mod:[Module]
mods) UniqDSet Module
acc_mods UniqDSet UnitId
acc_pkgs
= do
MaybeErr MissingInterfaceError ModIface
mb_iface <- LinkDepsOpts
-> SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
ldLoadIface LinkDepsOpts
opts SDoc
msg Module
mod
ModIface
iface <- case MaybeErr MissingInterfaceError ModIface
mb_iface of
Failed MissingInterfaceError
err -> LinkDepsOpts -> SDoc -> IO ModIface
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (SDoc -> IO ModIface) -> SDoc -> IO ModIface
forall a b. (a -> b) -> a -> b
$
IfaceMessageOpts -> MissingInterfaceError -> SDoc
missingInterfaceErrorDiagnostic (LinkDepsOpts -> DiagnosticOpts IfaceMessage
ldMsgOpts LinkDepsOpts
opts) MissingInterfaceError
err
Succeeded ModIface
iface -> ModIface -> IO ModIface
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModIface -> IsBootInterface
mi_boot ModIface
iface IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Module -> IO ()
forall a. Module -> IO a
link_boot_mod_error Module
mod
let
pkg :: Unit
pkg = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
deps :: Dependencies
deps = ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface
pkg_deps :: Set UnitId
pkg_deps = Dependencies -> Set UnitId
dep_direct_pkgs Dependencies
deps
([ModuleName]
boot_deps, [ModuleName]
mod_deps) = (((UnitId, ModuleNameWithIsBoot) -> Either ModuleName ModuleName)
-> [(UnitId, ModuleNameWithIsBoot)]
-> ([ModuleName], [ModuleName]))
-> [(UnitId, ModuleNameWithIsBoot)]
-> ((UnitId, ModuleNameWithIsBoot) -> Either ModuleName ModuleName)
-> ([ModuleName], [ModuleName])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((UnitId, ModuleNameWithIsBoot) -> Either ModuleName ModuleName)
-> [(UnitId, ModuleNameWithIsBoot)] -> ([ModuleName], [ModuleName])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a. Set a -> [a]
Set.toList (Dependencies -> Set (UnitId, ModuleNameWithIsBoot)
dep_direct_mods Dependencies
deps)) (((UnitId, ModuleNameWithIsBoot) -> Either ModuleName ModuleName)
-> ([ModuleName], [ModuleName]))
-> ((UnitId, ModuleNameWithIsBoot) -> Either ModuleName ModuleName)
-> ([ModuleName], [ModuleName])
forall a b. (a -> b) -> a -> b
$
\case
(UnitId
_, GWIB ModuleName
m IsBootInterface
IsBoot) -> ModuleName -> Either ModuleName ModuleName
forall a b. a -> Either a b
Left ModuleName
m
(UnitId
_, GWIB ModuleName
m IsBootInterface
NotBoot) -> ModuleName -> Either ModuleName ModuleName
forall a b. b -> Either a b
Right ModuleName
m
mod_deps' :: [Module]
mod_deps' = case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
Maybe HomeUnit
Nothing -> []
Just HomeUnit
home_unit -> (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Module -> Bool) -> Module -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> UniqDSet Module -> Bool
forall a. Uniquable a => a -> UniqDSet a -> Bool
`elementOfUniqDSet` UniqDSet Module
acc_mods)) ((ModuleName -> Module) -> [ModuleName] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit) ([ModuleName] -> [Module]) -> [ModuleName] -> [Module]
forall a b. (a -> b) -> a -> b
$ ([ModuleName]
boot_deps [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
mod_deps))
acc_mods' :: UniqDSet Module
acc_mods' = case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
Maybe HomeUnit
Nothing -> UniqDSet Module
acc_mods
Just HomeUnit
home_unit -> UniqDSet Module -> [Module] -> UniqDSet Module
forall a. Uniquable a => UniqDSet a -> [a] -> UniqDSet a
addListToUniqDSet UniqDSet Module
acc_mods (Module
mod Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: (ModuleName -> Module) -> [ModuleName] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit) [ModuleName]
mod_deps)
acc_pkgs' :: UniqDSet UnitId
acc_pkgs' = UniqDSet UnitId -> [UnitId] -> UniqDSet UnitId
forall a. Uniquable a => UniqDSet a -> [a] -> UniqDSet a
addListToUniqDSet UniqDSet UnitId
acc_pkgs (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
pkg_deps)
case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
Just HomeUnit
home_unit | HomeUnit -> Unit -> Bool
isHomeUnit HomeUnit
home_unit Unit
pkg -> [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps ([Module]
mod_deps' [Module] -> [Module] -> [Module]
forall a. [a] -> [a] -> [a]
++ [Module]
mods)
UniqDSet Module
acc_mods' UniqDSet UnitId
acc_pkgs'
Maybe HomeUnit
_ -> [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps [Module]
mods UniqDSet Module
acc_mods (UniqDSet UnitId -> UnitId -> UniqDSet UnitId
forall a. Uniquable a => UniqDSet a -> a -> UniqDSet a
addOneToUniqDSet UniqDSet UnitId
acc_pkgs' (Unit -> UnitId
toUnitId Unit
pkg))
where
msg :: SDoc
msg = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"need to link module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"due to use of Template Haskell"
link_boot_mod_error :: Module -> IO a
link_boot_mod_error :: forall a. Module -> IO a
link_boot_mod_error Module
mod = LinkDepsOpts -> SDoc -> IO a
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (SDoc -> IO a) -> SDoc -> IO a
forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"cannot be linked; it is only available as a boot module"
no_obj :: Outputable a => a -> IO b
no_obj :: forall a b. Outputable a => a -> IO b
no_obj a
mod = LinkDepsOpts -> SrcSpan -> SDoc -> IO b
forall a. LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith LinkDepsOpts
opts SrcSpan
span (SDoc -> IO b) -> SDoc -> IO b
forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"cannot find object file for module " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
mod) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc
while_linking_expr
while_linking_expr :: SDoc
while_linking_expr = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"while linking an interpreted expression"
homeModLinkable :: HomeModInfo -> Maybe Linkable
homeModLinkable :: HomeModInfo -> Maybe Linkable
homeModLinkable HomeModInfo
hmi =
if LinkDepsOpts -> Bool
ldUseByteCode LinkDepsOpts
opts
then HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi Maybe Linkable -> Maybe Linkable -> Maybe Linkable
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HomeModInfo -> Maybe Linkable
homeModInfoObject HomeModInfo
hmi
else HomeModInfo -> Maybe Linkable
homeModInfoObject HomeModInfo
hmi Maybe Linkable -> Maybe Linkable -> Maybe Linkable
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi
get_linkable :: FilePath -> Module -> IO Linkable
get_linkable FilePath
osuf Module
mod
| Just HomeModInfo
mod_info <- Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule Module
mod (UnitEnv -> HomeUnitGraph
ue_home_unit_graph UnitEnv
unit_env)
= Linkable -> IO Linkable
adjust_linkable (FilePath -> Maybe Linkable -> Linkable
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"getLinkDeps" (HomeModInfo -> Maybe Linkable
homeModLinkable HomeModInfo
mod_info))
| Bool
otherwise
= do
case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
Maybe HomeUnit
Nothing -> Module -> IO Linkable
forall a b. Outputable a => a -> IO b
no_obj Module
mod
Just HomeUnit
home_unit -> do
let fc :: FinderCache
fc = LinkDepsOpts -> FinderCache
ldFinderCache LinkDepsOpts
opts
let fopts :: FinderOpts
fopts = LinkDepsOpts -> FinderOpts
ldFinderOpts LinkDepsOpts
opts
FindResult
mb_stuff <- FinderCache
-> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult
findHomeModule FinderCache
fc FinderOpts
fopts HomeUnit
home_unit (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
case FindResult
mb_stuff of
Found ModLocation
loc Module
mod -> ModLocation -> Module -> IO Linkable
found ModLocation
loc Module
mod
FindResult
_ -> ModuleName -> IO Linkable
forall a b. Outputable a => a -> IO b
no_obj (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
where
found :: ModLocation -> Module -> IO Linkable
found ModLocation
loc Module
mod = do {
Maybe Linkable
mb_lnk <- Module -> ModLocation -> IO (Maybe Linkable)
findObjectLinkableMaybe Module
mod ModLocation
loc ;
case Maybe Linkable
mb_lnk of {
Maybe Linkable
Nothing -> Module -> IO Linkable
forall a b. Outputable a => a -> IO b
no_obj Module
mod ;
Just Linkable
lnk -> Linkable -> IO Linkable
adjust_linkable Linkable
lnk
}}
adjust_linkable :: Linkable -> IO Linkable
adjust_linkable Linkable
lnk
| Just FilePath
new_osuf <- Maybe FilePath
maybe_normal_osuf = do
[Unlinked]
new_uls <- (Unlinked -> IO Unlinked) -> [Unlinked] -> IO [Unlinked]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> Unlinked -> IO Unlinked
adjust_ul FilePath
new_osuf)
(Linkable -> [Unlinked]
linkableUnlinked Linkable
lnk)
Linkable -> IO Linkable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Linkable
lnk{ linkableUnlinked=new_uls }
| Bool
otherwise =
Linkable -> IO Linkable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Linkable
lnk
adjust_ul :: FilePath -> Unlinked -> IO Unlinked
adjust_ul FilePath
new_osuf (DotO FilePath
file) = do
Bool -> IO ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (FilePath
osuf FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
file)
let file_base :: FilePath
file_base = Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (FilePath -> FilePath -> Maybe FilePath
stripExtension FilePath
osuf FilePath
file)
new_file :: FilePath
new_file = FilePath
file_base FilePath -> FilePath -> FilePath
<.> FilePath
new_osuf
Bool
ok <- FilePath -> IO Bool
doesFileExist FilePath
new_file
if (Bool -> Bool
not Bool
ok)
then LinkDepsOpts -> SrcSpan -> SDoc -> IO Unlinked
forall a. LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith LinkDepsOpts
opts SrcSpan
span (SDoc -> IO Unlinked) -> SDoc -> IO Unlinked
forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"cannot find object file "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
quotes (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
new_file) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
while_linking_expr
else Unlinked -> IO Unlinked
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Unlinked
DotO FilePath
new_file)
adjust_ul FilePath
_ (DotA FilePath
fp) = FilePath -> IO Unlinked
forall a. HasCallStack => FilePath -> a
panic (FilePath
"adjust_ul DotA " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp)
adjust_ul FilePath
_ (DotDLL FilePath
fp) = FilePath -> IO Unlinked
forall a. HasCallStack => FilePath -> a
panic (FilePath
"adjust_ul DotDLL " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp)
adjust_ul FilePath
_ l :: Unlinked
l@(BCOs {}) = Unlinked -> IO Unlinked
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Unlinked
l
adjust_ul FilePath
_ l :: Unlinked
l@LoadedBCOs{} = Unlinked -> IO Unlinked
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Unlinked
l
adjust_ul FilePath
_ (CoreBindings (WholeCoreBindings [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
_ Module
mod ModLocation
_)) = FilePath -> SDoc -> IO Unlinked
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"Unhydrated core bindings" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith :: forall a. LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith LinkDepsOpts
opts SrcSpan
span SDoc
msg = LinkDepsOpts -> SDoc -> IO a
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCFatal SrcSpan
span SDoc
msg)
throwProgramError :: LinkDepsOpts -> SDoc -> IO a
throwProgramError :: forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts SDoc
doc = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (SDocContext -> SDoc -> FilePath
renderWithContext (LinkDepsOpts -> SDocContext
ldPprOpts LinkDepsOpts
opts) SDoc
doc))
checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay LinkDepsOpts
_opts Interp
interp SrcSpan
_srcspan
| ExternalInterp {} <- Interp -> InterpInstance
interpInstance Interp
interp = Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
#if defined(HAVE_INTERNAL_INTERPRETER)
checkNonStdWay opts _interp srcspan
| hostFullWays == targetFullWays = return Nothing
| ldObjSuffix opts == normalObjectSuffix && not (null targetFullWays)
= failNonStd opts srcspan
| otherwise = return (Just (hostWayTag ++ "o"))
where
targetFullWays = fullWays (ldWays opts)
hostWayTag = case waysTag hostFullWays of
"" -> ""
tag -> tag ++ "_"
normalObjectSuffix :: String
normalObjectSuffix = "o"
data Way' = Normal | Prof | Dyn
failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath)
failNonStd opts srcspan = dieWith opts srcspan $
text "Cannot load" <+> pprWay' compWay <+>
text "objects when GHC is built" <+> pprWay' ghciWay $$
text "To fix this, either:" $$
text " (1) Use -fexternal-interpreter, or" $$
buildTwiceMsg
where compWay
| ldWays opts `hasWay` WayDyn = Dyn
| ldWays opts `hasWay` WayProf = Prof
| otherwise = Normal
ghciWay
| hostIsDynamic = Dyn
| hostIsProfiled = Prof
| otherwise = Normal
buildTwiceMsg = case (ghciWay, compWay) of
(Normal, Dyn) -> dynamicTooMsg
(Dyn, Normal) -> dynamicTooMsg
_ ->
text " (2) Build the program twice: once" <+>
pprWay' ghciWay <> text ", and then" $$
text " " <> pprWay' compWay <+>
text "using -osuf to set a different object file suffix."
dynamicTooMsg = text " (2) Use -dynamic-too," <+>
text "and use -osuf and -dynosuf to set object file suffixes as needed."
pprWay' :: Way' -> SDoc
pprWay' way = text $ case way of
Normal -> "the normal way"
Prof -> "with -prof"
Dyn -> "with -dynamic"
#endif