%
% (c) The University of Glasgow 2005-2012
%
\begin{code}
module Linker ( getHValue, showLinkerState,
linkExpr, linkDecls, unload, withExtendedLinkEnv,
extendLinkEnv, deleteFromLinkEnv,
extendLoadedPkgs,
linkPackages,initDynLinker,linkModule,
PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals
) where
#include "HsVersions.h"
import LoadIface
import ObjLink
import ByteCodeLink
import ByteCodeItbls
import ByteCodeAsm
import TcRnMonad
import Packages
import DriverPhases
import Finder
import HscTypes
import Name
import NameEnv
import NameSet
import UniqFM
import Module
import ListSetOps
import DynFlags
import BasicTypes
import Outputable
import Panic
import Util
import ErrUtils
import SrcLoc
import qualified Maybes
import UniqSet
import FastString
import Config
import Platform
import SysTools
import Control.Monad
import Data.IORef
import Data.List
import qualified Data.Map as Map
import Control.Concurrent.MVar
import System.FilePath
import System.IO
#if __GLASGOW_HASKELL__ > 704
import System.Directory hiding (findFile)
#else
import System.Directory
#endif
import Distribution.Package hiding (depends, PackageId)
import Exception
\end{code}
%************************************************************************
%* *
The Linker's state
%* *
%************************************************************************
The persistent linker state *must* match the actual state of the
C dynamic linker at all times, so we keep it in a private global variable.
The global IORef used for PersistentLinkerState actually contains another MVar.
The reason for this is that we want to allow another loaded copy of the GHC
library to side-effect the PLS and for those changes to be reflected here.
The PersistentLinkerState maps Names to actual closures (for
interpreted code only), for use during linking.
\begin{code}
GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
GLOBAL_VAR(v_InitLinkerDone, False, Bool)
modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f
data PersistentLinkerState
= PersistentLinkerState {
closure_env :: ClosureEnv,
itbl_env :: !ItblEnv,
bcos_loaded :: ![Linkable],
objs_loaded :: ![Linkable],
pkgs_loaded :: ![PackageId]
}
emptyPLS :: DynFlags -> PersistentLinkerState
emptyPLS _ = PersistentLinkerState {
closure_env = emptyNameEnv,
itbl_env = emptyNameEnv,
pkgs_loaded = init_pkgs,
bcos_loaded = [],
objs_loaded = [] }
where init_pkgs = [rtsPackageId]
extendLoadedPkgs :: [PackageId] -> IO ()
extendLoadedPkgs pkgs =
modifyPLS_ $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
extendLinkEnv :: [(Name,HValue)] -> IO ()
extendLinkEnv new_bindings =
modifyPLS_ $ \pls ->
let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
in return pls{ closure_env = new_closure_env }
deleteFromLinkEnv :: [Name] -> IO ()
deleteFromLinkEnv to_remove =
modifyPLS_ $ \pls ->
let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
in return pls{ closure_env = new_closure_env }
getHValue :: HscEnv -> Name -> IO HValue
getHValue hsc_env name = do
initDynLinker (hsc_dflags hsc_env)
pls <- modifyPLS $ \pls -> do
if (isExternalName name) then do
(pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
if (failed ok) then throwGhcExceptionIO (ProgramError "")
else return (pls', pls')
else
return (pls, pls)
lookupName (closure_env pls) name
linkDependencies :: HscEnv -> PersistentLinkerState
-> SrcSpan -> [Module]
-> IO (PersistentLinkerState, SuccessFlag)
linkDependencies hsc_env pls span needed_mods = do
let hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
maybe_normal_osuf <- checkNonStdWay dflags span
(lnks, pkgs) <- getLinkDeps hsc_env hpt pls
maybe_normal_osuf span needed_mods
pls1 <- linkPackages' dflags pkgs pls
linkModules dflags pls1 lnks
withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
[(Name,HValue)] -> m a -> m a
withExtendedLinkEnv new_env action
= gbracket (liftIO $ extendLinkEnv new_env)
(\_ -> reset_old_env)
(\_ -> action)
where
reset_old_env = liftIO $ do
modifyPLS_ $ \pls ->
let cur = closure_env pls
new = delListFromNameEnv cur (map fst new_env)
in return pls{ closure_env = new }
filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
filterNameMap mods env
= filterNameEnv keep_elt env
where
keep_elt (n,_) = isExternalName n
&& (nameModule n `elem` mods)
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
text "BCOs:" <+> ppr (bcos_loaded pls)])
\end{code}
%************************************************************************
%* *
\subsection{Initialisation}
%* *
%************************************************************************
\begin{code}
initDynLinker :: DynFlags -> IO ()
initDynLinker dflags =
modifyPLS_ $ \pls0 -> do
done <- readIORef v_InitLinkerDone
if done then return pls0
else do writeIORef v_InitLinkerDone True
reallyInitDynLinker dflags
reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState
reallyInitDynLinker dflags =
do {
let pls0 = emptyPLS dflags
; initObjLinker
; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
; let cmdline_ld_inputs = ldInputs dflags
; let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
; let lib_paths = libraryPaths dflags
; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
; classified_ld_inputs <- mapM (classifyLdInput dflags)
[ f | FileOption _ f <- cmdline_ld_inputs ]
; let platform = targetPlatform dflags
; let framework_paths = if platformUsesFrameworks platform
then frameworkPaths dflags
else []
; let frameworks = if platformUsesFrameworks platform
then cmdlineFrameworks dflags
else []
; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
++ libspecs
++ map Framework frameworks
; if null cmdline_lib_specs then return pls
else do
{ mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
; maybePutStr dflags "final link ... "
; ok <- resolveObjs
; if succeeded ok then maybePutStrLn dflags "done"
else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
; return pls
}}
classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
classifyLdInput dflags f
| isObjectFilename platform f = return (Just (Object f))
| isDynLibFilename platform f = return (Just (DLLPath f))
| otherwise = do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing
where platform = targetPlatform dflags
preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
preloadLib dflags lib_paths framework_paths lib_spec
= do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
case lib_spec of
Object static_ish
-> do b <- preload_static lib_paths static_ish
maybePutStrLn dflags (if b then "done"
else "not found")
Archive static_ish
-> do b <- preload_static_archive lib_paths static_ish
maybePutStrLn dflags (if b then "done"
else "not found")
DLL dll_unadorned
-> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
DLLPath dll_path
-> do maybe_errstr <- loadDLL dll_path
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
Framework framework ->
if platformUsesFrameworks (targetPlatform dflags)
then do maybe_errstr <- loadFramework framework_paths framework
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm framework_paths lib_spec
else panic "preloadLib Framework"
where
platform = targetPlatform dflags
preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
preloadFailed sys_errmsg paths spec
= do maybePutStr dflags "failed.\n"
throwGhcExceptionIO $
CmdLineError (
"user specified .o/.so/.DLL could not be loaded ("
++ sys_errmsg ++ ")\nWhilst trying to load: "
++ showLS spec ++ "\nAdditional directories searched:"
++ (if null paths then " (none)" else
(concat (intersperse "\n" (map (" "++) paths)))))
preload_static _paths name
= do b <- doesFileExist name
if not b then return False
else do if dynamicGhc
then dynLoadObjs dflags [name]
else loadObj name
return True
preload_static_archive _paths name
= do b <- doesFileExist name
if not b then return False
else do if dynamicGhc
then panic "Loading archives not supported"
else loadArchive name
return True
\end{code}
%************************************************************************
%* *
Link a byte-code expression
%* *
%************************************************************************
\begin{code}
linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
linkExpr hsc_env span root_ul_bco
= do {
let dflags = hsc_dflags hsc_env
; initDynLinker dflags
; modifyPLS $ \pls0 -> do {
; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
; if failed ok then
throwGhcExceptionIO (ProgramError "")
else do {
let ie = itbl_env pls
ce = closure_env pls
; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco]
; return (pls, root_hval)
}}}
where
free_names = nameSetToList (bcoFreeNames root_ul_bco)
needed_mods :: [Module]
needed_mods = [ nameModule n | n <- free_names,
isExternalName n,
not (isWiredInName n)
]
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay dflags srcspan =
if interpWays == haskellWays
then return Nothing
else if objectSuf dflags == normalObjectSuffix && not (null haskellWays)
then failNonStd dflags srcspan
else return $ Just $ if dynamicGhc
then "dyn_o"
else "o"
where haskellWays = filter (not . wayRTSOnly) (ways dflags)
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
failNonStd dflags srcspan = dieWith dflags srcspan $
ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
ptext (sLit "You need to build the program twice: once the") <+> ghciWay <+> ptext (sLit "way, and then") $$
ptext (sLit "in the desired way using -osuf to set the object file suffix.")
where ghciWay = if dynamicGhc
then ptext (sLit "dynamic")
else ptext (sLit "normal")
getLinkDeps :: HscEnv -> HomePackageTable
-> PersistentLinkerState
-> Maybe FilePath
-> SrcSpan
-> [Module]
-> IO ([Linkable], [PackageId])
getLinkDeps hsc_env hpt pls replace_osuf span mods
= do {
; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
emptyUniqSet emptyUniqSet;
; let {
mods_needed = mods_s `minusList` linked_mods ;
pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
linked_mods = map (moduleName.linkableModule)
(objs_loaded pls ++ bcos_loaded pls) }
; let { osuf = objectSuf dflags }
; lnks_needed <- mapM (get_linkable osuf) mods_needed
; return (lnks_needed, pkgs_needed) }
where
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
follow_deps :: [Module]
-> UniqSet ModuleName
-> UniqSet PackageId
-> IO ([ModuleName], [PackageId])
follow_deps [] acc_mods acc_pkgs
= return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
follow_deps (mod:mods) acc_mods acc_pkgs
= do
mb_iface <- initIfaceCheck hsc_env $
loadInterface msg mod (ImportByUser False)
iface <- case mb_iface of
Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
Maybes.Succeeded iface -> return iface
when (mi_boot iface) $ link_boot_mod_error mod
let
pkg = modulePackageId mod
deps = mi_deps iface
pkg_deps = dep_pkgs deps
(boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
where is_boot (m,True) = Left m
is_boot (m,False) = Right m
boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
acc_pkgs' = addListToUniqSet acc_pkgs $ map fst pkg_deps
if pkg /= this_pkg
then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
acc_mods' acc_pkgs'
where
msg = text "need to link module" <+> ppr mod <+>
text "due to use of Template Haskell"
link_boot_mod_error mod =
throwGhcExceptionIO (ProgramError (showSDoc dflags (
text "module" <+> ppr mod <+>
text "cannot be linked; it is only available as a boot module")))
no_obj :: Outputable a => a -> IO b
no_obj mod = dieWith dflags span $
ptext (sLit "cannot find object file for module ") <>
quotes (ppr mod) $$
while_linking_expr
while_linking_expr = ptext (sLit "while linking an interpreted expression")
get_linkable osuf mod_name
| Just mod_info <- lookupUFM hpt mod_name
= adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
| otherwise
= do
mb_stuff <- findHomeModule hsc_env mod_name
case mb_stuff of
Found loc mod -> found loc mod
_ -> no_obj mod_name
where
found loc mod = do {
mb_lnk <- findObjectLinkableMaybe mod loc ;
case mb_lnk of {
Nothing -> no_obj mod ;
Just lnk -> adjust_linkable lnk
}}
adjust_linkable lnk
| Just new_osuf <- replace_osuf = do
new_uls <- mapM (adjust_ul new_osuf)
(linkableUnlinked lnk)
return lnk{ linkableUnlinked=new_uls }
| otherwise =
return lnk
adjust_ul new_osuf (DotO file) = do
MASSERT(osuf `isSuffixOf` file)
let file_base = dropTail (length osuf + 1) file
new_file = file_base <.> new_osuf
ok <- doesFileExist new_file
if (not ok)
then dieWith dflags span $
ptext (sLit "cannot find normal object file ")
<> quotes (text new_file) $$ while_linking_expr
else return (DotO new_file)
adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
adjust_ul _ l@(BCOs {}) = return l
\end{code}
%************************************************************************
%* *
Loading a Decls statement
%* *
%************************************************************************
\begin{code}
linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue]
linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
let dflags = hsc_dflags hsc_env
initDynLinker dflags
modifyPLS $ \pls0 -> do
(pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
if failed ok
then throwGhcExceptionIO (ProgramError "")
else do
let ie = plusNameEnv (itbl_env pls) itblEnv
ce = closure_env pls
(final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs
let pls2 = pls { closure_env = final_gce,
itbl_env = ie }
return (pls2, ()) --hvals)
where
free_names = concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs
needed_mods :: [Module]
needed_mods = [ nameModule n | n <- free_names,
isExternalName n,
not (isWiredInName n)
]
\end{code}
%************************************************************************
%* *
Loading a single module
%* *
%************************************************************************
\begin{code}
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
initDynLinker (hsc_dflags hsc_env)
modifyPLS_ $ \pls -> do
(pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
else return pls'
\end{code}
%************************************************************************
%* *
Link some linkables
The linkables may consist of a mixture of
byte-code modules and object modules
%* *
%************************************************************************
\begin{code}
linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
-> IO (PersistentLinkerState, SuccessFlag)
linkModules dflags pls linkables
= mask_ $ do
let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables)
(pls1, ok_flag) <- dynLinkObjs dflags pls objs
if failed ok_flag then
return (pls1, Failed)
else do
pls2 <- dynLinkBCOs dflags pls1 bcos
return (pls2, Succeeded)
partitionLinkable :: Linkable -> [Linkable]
partitionLinkable li
= let li_uls = linkableUnlinked li
li_uls_obj = filter isObject li_uls
li_uls_bco = filter isInterpretable li_uls
in
case (li_uls_obj, li_uls_bco) of
(_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
li {linkableUnlinked=li_uls_bco}]
_ -> [li]
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
findModuleLinkable_maybe lis mod
= case [LM time nm us | LM time nm us <- lis, nm == mod] of
[] -> Nothing
[li] -> Just li
_ -> pprPanic "findModuleLinkable" (ppr mod)
linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
case findModuleLinkable_maybe objs_loaded (linkableModule l) of
Nothing -> False
Just m -> linkableTime l == linkableTime m
\end{code}
%************************************************************************
%* *
\subsection{The object-code linker}
%* *
%************************************************************************
\begin{code}
dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
-> IO (PersistentLinkerState, SuccessFlag)
dynLinkObjs dflags pls objs = do
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
wanted_objs = map nameOfObject unlinkeds
if dynamicGhc
then do dynLoadObjs dflags wanted_objs
return (pls1, Succeeded)
else do mapM_ loadObj wanted_objs
ok <- resolveObjs
if succeeded ok then do
return (pls1, Succeeded)
else do
pls2 <- unload_wkr dflags [] pls1
return (pls2, Failed)
dynLoadObjs :: DynFlags -> [FilePath] -> IO ()
dynLoadObjs _ [] = return ()
dynLoadObjs dflags objs = do
let platform = targetPlatform dflags
soFile <- newTempName dflags (soExt platform)
let
dflags1 = gopt_unset dflags Opt_Static
dflags2 = dflags1 {
ldInputs = [],
ways = [WayDyn],
buildTag = mkBuildTag [WayDyn],
outputFile = Just soFile
}
linkDynLib dflags2 objs []
consIORef (filesToNotIntermediateClean dflags) soFile
m <- loadDLL soFile
case m of
Nothing -> return ()
Just err -> panic ("Loading temp shared object failed: " ++ err)
rmDupLinkables :: [Linkable]
-> [Linkable]
-> ([Linkable],
[Linkable])
rmDupLinkables already ls
= go already [] ls
where
go already extras [] = (already, extras)
go already extras (l:ls)
| linkableInSet l already = go already extras ls
| otherwise = go (l:already) (l:extras) ls
\end{code}
%************************************************************************
%* *
\subsection{The byte-code linker}
%* *
%************************************************************************
\begin{code}
dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
-> IO PersistentLinkerState
dynLinkBCOs dflags pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
unlinkeds :: [Unlinked]
unlinkeds = concatMap linkableUnlinked new_bcos
cbcs :: [CompiledByteCode]
cbcs = map byteCodeOfObject unlinkeds
ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
ies = [ie | ByteCode _ ie <- cbcs]
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
(final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
let pls2 = pls1 { closure_env = final_gce,
itbl_env = final_ie }
return pls2
linkSomeBCOs :: DynFlags
-> Bool
-> ItblEnv
-> ClosureEnv
-> [UnlinkedBCO]
-> IO (ClosureEnv, [HValue])
linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
= do let nms = map unlinkedBCOName ul_bcos
hvals <- fixIO
( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
in mapM (linkBCO dflags ie ce_out) ul_bcos )
let ce_all_additions = zip nms hvals
ce_top_additions = filter (isExternalName.fst) ce_all_additions
ce_additions = if toplevs_only then ce_top_additions
else ce_all_additions
ce_out =
ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
extendClosureEnv ce_in ce_additions
return (ce_out, hvals)
\end{code}
%************************************************************************
%* *
Unload some object modules
%* *
%************************************************************************
\begin{code}
unload :: DynFlags
-> [Linkable]
-> IO ()
unload dflags linkables
= mask_ $ do
initDynLinker dflags
new_pls
<- modifyPLS $ \pls -> do
pls1 <- unload_wkr dflags linkables pls
return (pls1, pls1)
debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
return ()
unload_wkr :: DynFlags
-> [Linkable]
-> PersistentLinkerState
-> IO PersistentLinkerState
unload_wkr _ linkables pls
= do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
let bcos_retained = map linkableModule bcos_loaded'
itbl_env' = filterNameMap bcos_retained (itbl_env pls)
closure_env' = filterNameMap bcos_retained (closure_env pls)
new_pls = pls { itbl_env = itbl_env',
closure_env = closure_env',
bcos_loaded = bcos_loaded',
objs_loaded = objs_loaded' }
return new_pls
where
maybeUnload :: [Linkable] -> Linkable -> IO Bool
maybeUnload keep_linkables lnk
| linkableInSet lnk keep_linkables = return True
| dynamicGhc = return False
| otherwise
= do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
return False
\end{code}
%************************************************************************
%* *
Loading packages
%* *
%************************************************************************
\begin{code}
data LibrarySpec
= Object FilePath
| Archive FilePath
| DLL String
| DLLPath FilePath
| Framework String
partOfGHCi :: [PackageName]
partOfGHCi
| isWindowsHost || isDarwinHost = []
| otherwise = map PackageName
["base", "template-haskell", "editline"]
showLS :: LibrarySpec -> String
showLS (Object nm) = "(static) " ++ nm
showLS (Archive nm) = "(static archive) " ++ nm
showLS (DLL nm) = "(dynamic) " ++ nm
showLS (DLLPath nm) = "(dynamic) " ++ nm
showLS (Framework nm) = "(framework) " ++ nm
linkPackages :: DynFlags -> [PackageId] -> IO ()
linkPackages dflags new_pkgs = do
initDynLinker dflags
modifyPLS_ $ \pls -> do
linkPackages' dflags new_pkgs pls
linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' dflags new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
pkg_map = pkgIdMap (pkgState dflags)
ipid_map = installedPackageIdMap (pkgState dflags)
link :: [PackageId] -> [PackageId] -> IO [PackageId]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
link_one pkgs new_pkg
| new_pkg `elem` pkgs
= return pkgs
| Just pkg_cfg <- lookupPackage pkg_map new_pkg
= do {
pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
Map.lookup ipid ipid_map
| ipid <- depends pkg_cfg ]
; linkPackage dflags pkg_cfg
; return (new_pkg : pkgs') }
| otherwise
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
linkPackage :: DynFlags -> PackageConfig -> IO ()
linkPackage dflags pkg
= do
let platform = targetPlatform dflags
dirs = Packages.libraryDirs pkg
let hs_libs = Packages.hsLibraries pkg
hs_libs' = filter ("HSffi" /=) hs_libs
extra_libs =
(if null (Packages.extraGHCiLibraries pkg)
then Packages.extraLibraries pkg
else Packages.extraGHCiLibraries pkg)
++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
hs_classifieds <- mapM (locateLib dflags True dirs) hs_libs'
extra_classifieds <- mapM (locateLib dflags False dirs) extra_libs
let classifieds = hs_classifieds ++ extra_classifieds
let known_dlls = [ dll | DLLPath dll <- classifieds ]
dlls = [ dll | DLL dll <- classifieds ]
objs = [ obj | Object obj <- classifieds ]
archs = [ arch | Archive arch <- classifieds ]
maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ")
when (packageName pkg `notElem` partOfGHCi) $ do
loadFrameworks platform pkg
mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls)
mapM_ loadObj objs
mapM_ loadArchive archs
maybePutStr dflags "linking ... "
ok <- resolveObjs
if succeeded ok then maybePutStrLn dflags "done."
else throwGhcExceptionIO (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
load_dyn :: FilePath -> IO ()
load_dyn dll = do r <- loadDLL dll
case r of
Nothing -> return ()
Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")" ))
loadFrameworks :: Platform -> InstalledPackageInfo_ ModuleName -> IO ()
loadFrameworks platform pkg
= if platformUsesFrameworks platform
then mapM_ load frameworks
else return ()
where
fw_dirs = Packages.frameworkDirs pkg
frameworks = Packages.frameworks pkg
load fw = do r <- loadFramework fw_dirs fw
case r of
Nothing -> return ()
Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
locateLib :: DynFlags -> Bool -> [FilePath] -> String -> IO LibrarySpec
locateLib dflags is_hs dirs lib
| not is_hs
= findDll `orElse` findArchive `orElse` tryGcc `orElse` assumeDll
| not dynamicGhc
= findObject `orElse` findArchive `orElse` assumeDll
| otherwise
= findHSDll `orElse` findDynObject `orElse` assumeDll
where
mk_obj_path dir = dir </> (lib <.> "o")
mk_dyn_obj_path dir = dir </> (lib <.> "dyn_o")
mk_arch_path dir = dir </> ("lib" ++ lib <.> "a")
hs_dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
mk_hs_dyn_lib_path dir = dir </> mkHsSOName platform hs_dyn_lib_name
so_name = mkSOName platform lib
mk_dyn_lib_path dir = dir </> so_name
findObject = liftM (fmap Object) $ findFile mk_obj_path dirs
findDynObject = liftM (fmap Object) $ findFile mk_dyn_obj_path dirs
findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs
findHSDll = liftM (fmap DLLPath) $ findFile mk_hs_dyn_lib_path dirs
findDll = liftM (fmap DLLPath) $ findFile mk_dyn_lib_path dirs
tryGcc = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs
assumeDll = return (DLL lib)
infixr `orElse`
f `orElse` g = do m <- f
case m of
Just x -> return x
Nothing -> g
platform = targetPlatform dflags
searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
searchForLibUsingGcc dflags so dirs = do
str <- askCc dflags (map (FileOption "-L") dirs
++ [Option "--print-file-name", Option so])
let file = case lines str of
[] -> ""
l:_ -> l
if (file == so)
then return Nothing
else return (Just file)
loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
loadFramework extraPaths rootname
= do { either_dir <- tryIO getHomeDirectory
; let homeFrameworkPath = case either_dir of
Left _ -> []
Right dir -> [dir ++ "/Library/Frameworks"]
ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
; mb_fwk <- findFile mk_fwk ps
; case mb_fwk of
Just fwk_path -> loadDLL fwk_path
Nothing -> return (Just "not found") }
where
mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
\end{code}
%************************************************************************
%* *
Helper functions
%* *
%************************************************************************
\begin{code}
findFile :: (FilePath -> FilePath)
-> [FilePath]
-> IO (Maybe FilePath)
findFile _ [] = return Nothing
findFile mk_file_path (dir : dirs)
= do let file_path = mk_file_path dir
b <- doesFileExist file_path
if b then return (Just file_path)
else findFile mk_file_path dirs
\end{code}
\begin{code}
maybePutStr :: DynFlags -> String -> IO ()
maybePutStr dflags s
= when (verbosity dflags > 0) $
do let act = log_action dflags
act dflags SevInteractive noSrcSpan defaultUserStyle (text s)
maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
\end{code}
%************************************************************************
%* *
Tunneling global variables into new instance of GHC library
%* *
%************************************************************************
\begin{code}
saveLinkerGlobals :: IO (MVar PersistentLinkerState, Bool)
saveLinkerGlobals = liftM2 (,) (readIORef v_PersistentLinkerState) (readIORef v_InitLinkerDone)
restoreLinkerGlobals :: (MVar PersistentLinkerState, Bool) -> IO ()
restoreLinkerGlobals (pls, ild) = do
writeIORef v_PersistentLinkerState pls
writeIORef v_InitLinkerDone ild
\end{code}