%
% (c) The University of Glasgow 2005-2006
%
-
--- --------------------------------------
--- The dynamic linker for GHCi
--- --------------------------------------
-
-This module deals with the top-level issues of dynamic linking,
-calling the object-code linker and the byte-code linker where
-necessary.
-
-
\begin{code}
-{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
+-- | The dynamic linker for GHCi.
+--
+-- This module deals with the top-level issues of dynamic linking,
+-- calling the object-code linker and the byte-code linker where
+-- necessary.
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
module Linker ( HValue, getHValue, showLinkerState,
linkExpr, unload, withExtendedLinkEnv,
#include "HsVersions.h"
+import LoadIface
import ObjLink
import ByteCodeLink
import ByteCodeItbls
import DynFlags
import BasicTypes
import Outputable
-import PackageConfig
import Panic
import Util
import StaticFlags
import ErrUtils
-import DriverPhases
import SrcLoc
+import qualified Maybes
import UniqSet
import Constants
import FastString
-import Config ( cProjectVersion )
+import Config
-- Standard libraries
import Control.Monad
import Data.Char
import Data.IORef
import Data.List
+import qualified Data.Map as Map
import Foreign
+import Control.Concurrent.MVar
import System.FilePath
import System.IO
import System.Directory
-import Control.Exception
-import Data.Maybe
+import Distribution.Package hiding (depends, PackageId)
+
+import Exception
\end{code}
interpreted code only), for use during linking.
\begin{code}
-GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
+GLOBAL_MVAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
data PersistentLinkerState
-- When a new Unlinked is linked into the running image, or an existing
-- module in the image is replaced, the itbl_env must be updated
-- appropriately.
- itbl_env :: ItblEnv,
+ itbl_env :: !ItblEnv,
-- The currently loaded interpreted modules (home package)
- bcos_loaded :: [Linkable],
+ bcos_loaded :: ![Linkable],
-- And the currently-loaded compiled modules (home package)
- objs_loaded :: [Linkable],
+ objs_loaded :: ![Linkable],
-- 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 :: [PackageId]
+ pkgs_loaded :: ![PackageId]
}
emptyPLS :: DynFlags -> PersistentLinkerState
-emptyPLS dflags = PersistentLinkerState {
+emptyPLS _ = PersistentLinkerState {
closure_env = emptyNameEnv,
itbl_env = emptyNameEnv,
pkgs_loaded = init_pkgs,
\begin{code}
extendLoadedPkgs :: [PackageId] -> IO ()
-extendLoadedPkgs pkgs
- = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
+extendLoadedPkgs pkgs =
+ modifyMVar_ v_PersistentLinkerState $ \s ->
+ return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
extendLinkEnv :: [(Name,HValue)] -> IO ()
-- Automatically discards shadowed bindings
-extendLinkEnv new_bindings
- = do pls <- readIORef v_PersistentLinkerState
- let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
- new_pls = pls { closure_env = new_closure_env }
- writeIORef v_PersistentLinkerState new_pls
+extendLinkEnv new_bindings =
+ modifyMVar_ v_PersistentLinkerState $ \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
- = do pls <- readIORef v_PersistentLinkerState
- let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
- new_pls = pls { closure_env = new_closure_env }
- writeIORef v_PersistentLinkerState new_pls
+deleteFromLinkEnv to_remove =
+ modifyMVar_ v_PersistentLinkerState $ \pls ->
+ let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
+ in return pls{ closure_env = new_closure_env }
-- | Given a data constructor in the heap, find its Name.
-- The info tables for data constructors have a field which records
-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
-- string). The format is:
--
--- Package:Module.Name
+-- > Package:Module.Name
--
-- We use this string to lookup the interpreter's internal representation of the name
-- using the lookupOrig.
-
+--
dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
dataConInfoPtrToName x = do
theString <- liftIO $ do
-}
getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
- getConDescAddress ptr = do
-#ifdef GHCI_TABLES_NEXT_TO_CODE
+ getConDescAddress ptr
+ | ghciTablesNextToCode = do
offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
-#else
+ | otherwise =
peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
-#endif
-- parsing names is a little bit fiddly because we have a string in the form:
-- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
where
(modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
- parseModOcc acc str
+ -- We only look for dots if str could start with a module name,
+ -- i.e. if it starts with an upper case character.
+ -- Otherwise we might think that "X.:->" is the module name in
+ -- "X.:->.+", whereas actually "X" is the module name and
+ -- ":->.+" is a constructor name.
+ parseModOcc acc str@(c : _)
+ | isUpper $ chr $ fromIntegral c
= case break (== dot) str of
(top, []) -> (acc, top)
- (top, _:bot) -> parseModOcc (top : acc) bot
-
+ (top, _ : bot) -> parseModOcc (top : acc) bot
+ parseModOcc acc str = (acc, str)
+-- | Get the 'HValue' associated with the given name.
+--
+-- May cause loading the module that contains the name.
+--
+-- Throws a 'ProgramError' if loading fails or the name cannot be found.
getHValue :: HscEnv -> Name -> IO HValue
getHValue hsc_env name = do
- when (isExternalName name) $ do
- ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
- when (failed ok) $ throwDyn (ProgramError "")
- pls <- readIORef v_PersistentLinkerState
- lookupName (closure_env pls) name
+ pls <- modifyMVar v_PersistentLinkerState $ \pls -> do
+ if (isExternalName name) then do
+ (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
+ if (failed ok) then ghcError (ProgramError "")
+ else return (pls', pls')
+ else
+ return (pls, pls)
+ lookupName (closure_env pls) name
-linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
-linkDependencies hsc_env span needed_mods = do
+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
-- The interpreter and dynamic linker can only handle object code built
maybe_normal_osuf <- checkNonStdWay dflags span
-- Find what packages and linkables are required
- eps <- readIORef (hsc_EPS hsc_env)
- (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
+ (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
maybe_normal_osuf span needed_mods
-- Link the packages and modules required
- linkPackages dflags pkgs
- linkModules dflags lnks
+ pls1 <- linkPackages' dflags pkgs pls
+ linkModules dflags pls1 lnks
-- | Temporarily extend the linker state.
-withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
+withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
+ [(Name,HValue)] -> m a -> m a
withExtendedLinkEnv new_env action
- = bracket set_new_env
- reset_old_env
- (const action)
- where set_new_env = do
- pls <- readIORef v_PersistentLinkerState
- let new_closure_env = extendClosureEnv (closure_env pls) new_env
- new_pls = pls { closure_env = new_closure_env }
- writeIORef v_PersistentLinkerState new_pls
- return (closure_env pls)
-
+ = gbracket (liftIO $ extendLinkEnv new_env)
+ (\_ -> reset_old_env)
+ (\_ -> action)
+ where
-- Remember that the linker state might be side-effected
-- during the execution of the IO action, and we don't want to
-- lose those changes (we might have linked a new module or
-- package), so the reset action only removes the names we
-- added earlier.
- reset_old_env env = do
- modifyIORef v_PersistentLinkerState $ \pls ->
+ reset_old_env = liftIO $ do
+ modifyMVar_ v_PersistentLinkerState $ \pls ->
let cur = closure_env pls
new = delListFromNameEnv cur (map fst new_env)
- in
- pls{ closure_env = new }
+ in return pls{ closure_env = new }
-- filterNameMap removes from the environment all entries except
-- those for a given set of modules;
\begin{code}
+-- | Display the persistent linker state.
showLinkerState :: IO ()
--- Display the persistent linker state
showLinkerState
- = do pls <- readIORef v_PersistentLinkerState
+ = do pls <- readMVar v_PersistentLinkerState
printDump (vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
%* *
%************************************************************************
-We initialise the dynamic linker by
-
-a) calling the C initialisation procedure
-
-b) Loading any packages specified on the command line,
-
-c) Loading any packages specified on the command line,
- now held in the -l options in v_Opt_l
-
-d) Loading any .o/.dll files specified on the command line,
- now held in v_Ld_inputs
-
-e) Loading any MacOS frameworks
-
\begin{code}
+-- | Initialise the dynamic linker. This entails
+--
+-- a) Calling the C initialisation procedure,
+--
+-- b) Loading any packages specified on the command line,
+--
+-- c) Loading any packages specified on the command line, now held in the
+-- @-l@ options in @v_Opt_l@,
+--
+-- d) Loading any @.o\/.dll@ files specified on the command line, now held
+-- in @v_Ld_inputs@,
+--
+-- e) Loading any MacOS frameworks.
+--
+-- NOTE: This function is idempotent; if called more than once, it does
+-- nothing. This is useful in Template Haskell, where we call it before
+-- trying to link.
+--
initDynLinker :: DynFlags -> IO ()
--- This function is idempotent; if called more than once, it does nothing
--- This is useful in Template Haskell, where we call it before trying to link
-initDynLinker dflags
- = do { done <- readIORef v_InitLinkerDone
- ; if done then return ()
- else do { writeIORef v_InitLinkerDone True
- ; reallyInitDynLinker dflags }
- }
-
-reallyInitDynLinker dflags
- = do { -- Initialise the linker state
- ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
+initDynLinker dflags =
+ modifyMVar_ v_PersistentLinkerState $ \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 { -- Initialise the linker state
+ let pls0 = emptyPLS dflags
-- (a) initialise the C dynamic linker
; initObjLinker
-- (b) Load packages from the command-line
- ; linkPackages dflags (preloadPackages (pkgState dflags))
+ ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
-- (c) Link libraries from the command-line
; let optl = getOpts dflags opt_l
; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
-- (e) Link any MacOS frameworks
-#ifdef darwin_TARGET_OS
- ; let framework_paths = frameworkPaths dflags
- ; let frameworks = cmdlineFrameworks dflags
-#else
- ; let frameworks = []
- ; let framework_paths = []
-#endif
+ ; let framework_paths
+ | isDarwinTarget = frameworkPaths dflags
+ | otherwise = []
+ ; let frameworks
+ | isDarwinTarget = cmdlineFrameworks dflags
+ | otherwise = []
-- Finally do (c),(d),(e)
; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
++ map DLL minus_ls
++ map Framework frameworks
- ; if null cmdline_lib_specs then return ()
+ ; if null cmdline_lib_specs then return pls
else do
{ mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
; ok <- resolveObjs
; if succeeded ok then maybePutStrLn dflags "done"
- else throwDyn (InstallationError "linking extra libraries/objects failed")
+ else ghcError (ProgramError "linking extra libraries/objects failed")
+
+ ; return pls
}}
classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
Object static_ish
-> do b <- preload_static lib_paths static_ish
maybePutStrLn dflags (if b then "done"
- else "not found")
-
+ 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 <- loadDynamic lib_paths dll_unadorned
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
-#ifdef darwin_TARGET_OS
Framework framework
+ | isDarwinTarget
-> do maybe_errstr <- loadFramework framework_paths framework
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm framework_paths lib_spec
-#endif
+ | otherwise -> panic "preloadLib Framework"
+
where
preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
preloadFailed sys_errmsg paths spec
- = do maybePutStr dflags
- ("failed.\nDynamic linker error message was:\n "
- ++ sys_errmsg ++ "\nWhilst trying to load: "
- ++ showLS spec ++ "\nDirectories to search are:\n"
- ++ unlines (map (" "++) paths) )
- give_up
+ = do maybePutStr dflags "failed.\n"
+ ghcError $
+ 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)))))
-- Not interested in the paths in the static case.
- preload_static paths name
+ preload_static _paths name
= do b <- doesFileExist name
if not b then return False
else loadObj name >> return True
-
- give_up = throwDyn $
- CmdLineError "user specified .o/.so/.DLL could not be loaded."
+ preload_static_archive _paths name
+ = do b <- doesFileExist name
+ if not b then return False
+ else loadArchive name >> return True
\end{code}
%************************************************************************
\begin{code}
-linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
-
--- Link a single expression, *including* first linking packages and
+-- | Link a single expression, /including/ first linking packages and
-- modules that this expression depends on.
--
--- Raises an IO exception if it can't find a compiled version of the
--- dependents to link.
+-- Raises an IO exception ('ProgramError') if it can't find a compiled
+-- version of the dependents to link.
--
--- Note: This function side-effects the linker state (Pepe)
-
+linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
linkExpr hsc_env span root_ul_bco
= do {
-- Initialise the linker (if it's not been done already)
let dflags = hsc_dflags hsc_env
; initDynLinker dflags
+ -- Take lock for the actual work.
+ ; modifyMVar v_PersistentLinkerState $ \pls0 -> do {
+
-- Link the packages and modules required
- ; ok <- linkDependencies hsc_env span needed_mods
+ ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
; if failed ok then
- throwDyn (ProgramError "")
+ ghcError (ProgramError "")
else do {
-- Link the expression itself
- pls <- readIORef v_PersistentLinkerState
- ; let ie = itbl_env pls
+ let ie = itbl_env pls
ce = closure_env pls
-- Link the necessary packages and linkables
; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
- ; return root_hval
- }}
+ ; return (pls, root_hval)
+ }}}
where
free_names = nameSetToList (bcoFreeNames root_ul_bco)
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
-dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
+dieWith :: SrcSpan -> Message -> IO a
+dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
checkNonStdWay dflags srcspan = do
- tag <- readIORef v_Build_tag
- if null tag then return Nothing else do
+ let tag = buildTag dflags
+ if null tag {- || tag == "dyn" -} then return Nothing else do
+ -- see #3604: object files compiled for way "dyn" need to link to the
+ -- dynamic packages, so we can't load them into a statically-linked GHCi.
+ -- we have to treat "dyn" in the same way as "prof".
+ --
+ -- In the future when GHCi is dynamically linked we should be able to relax
+ -- this, but they we may have to make it possible to load either ordinary
+ -- .o files or -dynamic .o files into GHCi (currently that's not possible
+ -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn
+ -- whereas we have __stginit_base_Prelude_.
let default_osuf = phaseInputExt StopLn
if objectSuf dflags == default_osuf
then failNonStd srcspan
else return (Just default_osuf)
+failNonStd :: SrcSpan -> IO (Maybe String)
failNonStd srcspan = dieWith 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 normal way, and then") $$
- ptext SLIT("in the desired way using -osuf to set the object file suffix.")
+ 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 normal way, and then") $$
+ ptext (sLit "in the desired way using -osuf to set the object file suffix.")
-getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
+getLinkDeps :: HscEnv -> HomePackageTable
+ -> PersistentLinkerState
-> Maybe String -- the "normal" object suffix
-> SrcSpan -- for error messages
-> [Module] -- If you need these
-> IO ([Linkable], [PackageId]) -- ... then link these first
-- Fails with an IO exception if it can't find enough files
-getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
+getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
-- Find all the packages and linkables that a set of modules depends on
- = do { pls <- readIORef v_PersistentLinkerState ;
- let {
+ = do {
-- 1. Find the dependent home-pkg-modules/packages from each iface
- (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
+ (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
+ let {
-- 2. Exclude ones already linked
-- Main reason: avoid findModule calls in get_linkable
mods_needed = mods_s `minusList` linked_mods ;
follow_deps :: [Module] -- modules to follow
-> UniqSet ModuleName -- accum. module dependencies
-> UniqSet PackageId -- accum. package dependencies
- -> ([ModuleName], [PackageId]) -- result
+ -> IO ([ModuleName], [PackageId]) -- result
follow_deps [] acc_mods acc_pkgs
- = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
+ = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
follow_deps (mod:mods) acc_mods acc_pkgs
- | pkg /= this_pkg
- = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
- | mi_boot iface
- = link_boot_mod_error mod
- | otherwise
- = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
- where
- pkg = modulePackageId mod
- iface = get_iface 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 pkg_deps
+ = do
+ mb_iface <- initIfaceCheck hsc_env $
+ loadInterface msg mod (ImportByUser False)
+ iface <- case mb_iface of
+ Maybes.Failed err -> ghcError (ProgramError (showSDoc 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 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 =
- throwDyn (ProgramError (showSDoc (
+ ghcError (ProgramError (showSDoc (
text "module" <+> ppr mod <+>
text "cannot be linked; it is only available as a boot module")))
- get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
- Just iface -> iface
- Nothing -> pprPanic "getLinkDeps" (no_iface mod)
- no_iface mod = ptext SLIT("No iface for") <+> ppr mod
- -- This one is a GHC bug
-
+ no_obj :: Outputable a => a -> IO b
no_obj mod = dieWith span $
- ptext SLIT("cannot find object file for module ") <>
+ ptext (sLit "cannot find object file for module ") <>
quotes (ppr mod) $$
while_linking_expr
- while_linking_expr = ptext SLIT("while linking an interpreted expression")
+ while_linking_expr = ptext (sLit "while linking an interpreted expression")
-- This one is a build-system bug
get_linkable maybe_normal_osuf mod_name -- A home-package module
| Just mod_info <- lookupUFM hpt mod_name
- = ASSERT(isJust (hm_linkable mod_info))
- adjust_linkable (fromJust (hm_linkable mod_info))
+ = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
| otherwise
= do -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
-- ...and then find the linkable for it
mb_lnk <- findObjectLinkableMaybe mod loc ;
case mb_lnk of {
- Nothing -> no_obj mod ;
+ Nothing -> no_obj mod ;
Just lnk -> adjust_linkable lnk
}}
ok <- doesFileExist new_file
if (not ok)
then dieWith span $
- ptext SLIT("cannot find normal object file ")
+ ptext (sLit "cannot find normal object file ")
<> quotes (text new_file) $$ while_linking_expr
else return (DotO new_file)
+ adjust_ul _ _ = panic "adjust_ul"
\end{code}
%************************************************************************
\begin{code}
-linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
-linkModules dflags linkables
- = block $ do -- don't want to be interrupted by ^C in here
+linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
+ -> IO (PersistentLinkerState, SuccessFlag)
+linkModules dflags pls linkables
+ = mask_ $ do -- don't want to be interrupted by ^C in here
let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables)
-- Load objects first; they can't depend on BCOs
- ok_flag <- dynLinkObjs dflags objs
+ (pls1, ok_flag) <- dynLinkObjs dflags pls objs
if failed ok_flag then
- return Failed
+ return (pls1, Failed)
else do
- dynLinkBCOs bcos
- return Succeeded
+ pls2 <- dynLinkBCOs pls1 bcos
+ return (pls2, Succeeded)
-- HACK to support f-x-dynamic in the interpreter; no other purpose
li_uls_bco = filter isInterpretable li_uls
in
case (li_uls_obj, li_uls_bco) of
- (objs@(_:_), bcos@(_:_))
- -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
- other
- -> [li]
+ (_:_, _:_) -> [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
- many -> pprPanic "findModuleLinkable" (ppr mod)
+ _ -> pprPanic "findModuleLinkable" (ppr mod)
linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
%************************************************************************
\begin{code}
-dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
- -- Side-effects the PersistentLinkerState
-
-dynLinkObjs dflags objs
- = do pls <- readIORef v_PersistentLinkerState
-
+dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
+ -> IO (PersistentLinkerState, SuccessFlag)
+dynLinkObjs dflags pls objs = do
-- Load the object files and link them
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
- mapM loadObj (map nameOfObject unlinkeds)
+ mapM_ loadObj (map nameOfObject unlinkeds)
-- Link the all together
ok <- resolveObjs
-- If resolving failed, unload all our
-- object modules and carry on
if succeeded ok then do
- writeIORef v_PersistentLinkerState pls1
- return Succeeded
+ return (pls1, Succeeded)
else do
pls2 <- unload_wkr dflags [] pls1
- writeIORef v_PersistentLinkerState pls2
- return Failed
+ return (pls2, Failed)
rmDupLinkables :: [Linkable] -- Already loaded
%************************************************************************
\begin{code}
-dynLinkBCOs :: [Linkable] -> IO ()
- -- Side-effects the persistent linker state
-dynLinkBCOs bcos
- = do pls <- readIORef v_PersistentLinkerState
+dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState
+dynLinkBCOs pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
- (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
- -- What happens to these linked_bcos?
+ (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
+ -- XXX What happens to these linked_bcos?
let pls2 = pls1 { closure_env = final_gce,
itbl_env = final_ie }
- writeIORef v_PersistentLinkerState pls2
- return ()
+ return pls2
-- Link a bunch of BCOs and return them + updated closure env.
linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
\begin{code}
-- ---------------------------------------------------------------------------
--- Unloading old objects ready for a new compilation sweep.
+-- | Unloading old objects ready for a new compilation sweep.
--
-- The compilation manager provides us with a list of linkables that it
--- considers "stable", i.e. won't be recompiled this time around. For
+-- considers \"stable\", i.e. won't be recompiled this time around. For
-- each of the modules current linked in memory,
--
--- * if the linkable is stable (and it's the same one - the
--- user may have recompiled the module on the side), we keep it,
+-- * if the linkable is stable (and it's the same one -- the user may have
+-- recompiled the module on the side), we keep it,
--
--- * otherwise, we unload it.
+-- * otherwise, we unload it.
--
--- * we also implicitly unload all temporary bindings at this point.
-
-unload :: DynFlags -> [Linkable] -> IO ()
--- The 'linkables' are the ones to *keep*
-
+-- * we also implicitly unload all temporary bindings at this point.
+--
+unload :: DynFlags
+ -> [Linkable] -- ^ The linkables to *keep*.
+ -> IO ()
unload dflags linkables
- = block $ do -- block, so we're safe from Ctrl-C in here
+ = mask_ $ do -- mask, so we're safe from Ctrl-C in here
-- Initialise the linker (if it's not been done already)
initDynLinker dflags
- pls <- readIORef v_PersistentLinkerState
- new_pls <- unload_wkr dflags linkables pls
- writeIORef v_PersistentLinkerState new_pls
+ new_pls
+ <- modifyMVar v_PersistentLinkerState $ \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))
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
-unload_wkr dflags linkables pls
+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)
where
maybeUnload :: [Linkable] -> Linkable -> IO Bool
maybeUnload keep_linkables lnk
- | linkableInSet lnk linkables = return True
+ | linkableInSet lnk keep_linkables = return True
| otherwise
= do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
-- The components of a BCO linkable may contain
-- file in all the directories specified in
-- v_Library_paths before giving up.
+ | Archive FilePath -- Full path name of a .a file, including trailing .a
+
| DLL String -- "Unadorned" name of a .DLL/.so
-- e.g. On unix "qt" denotes "libqt.so"
-- On WinDoze "burble" denotes "burble.DLL"
-- of DLL handles that rts/Linker.c maintains, and that in turn is
-- used by lookupSymbol. So we must call addDLL for each library
-- just to get the DLL handle into the list.
+partOfGHCi :: [PackageName]
partOfGHCi
-# if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
- = [ ]
-# else
- = [ "base", "haskell98", "template-haskell", "readline" ]
-# endif
+ | isWindowsTarget || isDarwinTarget = []
+ | 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 ()
--- 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.
+-- | 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 :: DynFlags -> [PackageId] -> 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.
+-- we don't really need to use the package-config dependencies.
+--
-- However we do need the package-config stuff (to find aux libs etc),
-- and following them lets us load libraries in the right order, which
-- perhaps makes the error message a bit more localised if we get a link
-- failure. So the dependency walking code is still here.
-linkPackages dflags new_pkgs
- = do { pls <- readIORef v_PersistentLinkerState
- ; let pkg_map = pkgIdMap (pkgState dflags)
-
- ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
+linkPackages dflags new_pkgs = do
+ -- It's probably not safe to try to load packages concurrently, so we take
+ -- a lock.
+ modifyMVar_ v_PersistentLinkerState $ \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)
- ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
- }
- where
- link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
- link pkg_map pkgs new_pkgs
- = foldM (link_one pkg_map) pkgs new_pkgs
+ link :: [PackageId] -> [PackageId] -> IO [PackageId]
+ link pkgs new_pkgs =
+ foldM link_one pkgs new_pkgs
- link_one pkg_map pkgs new_pkg
+ link_one pkgs new_pkg
| new_pkg `elem` pkgs -- Already linked
= return pkgs
| Just pkg_cfg <- lookupPackage pkg_map new_pkg
= do { -- Link dependents first
- pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
+ pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
+ Map.lookup ipid ipid_map
+ | ipid <- depends pkg_cfg ]
-- Now link the package itself
; linkPackage dflags pkg_cfg
; return (new_pkg : pkgs') }
| otherwise
- = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
+ = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
linkPackage :: DynFlags -> PackageConfig -> IO ()
let dirs = Packages.libraryDirs pkg
let libs = Packages.hsLibraries pkg
+ -- The FFI GHCi import lib isn't needed as
+ -- compiler/ghci/Linker.lhs + rts/Linker.c link the
+ -- interpreted references to FFI to the compiled FFI.
+ -- We therefore filter it out so that we don't get
+ -- duplicate symbol errors.
+ libs' = filter ("HSffi" /=) libs
-- Because of slight differences between the GHC dynamic linker and
-- the native system linker some packages have to link with a
-- different list of libraries when using GHCi. Examples include: libs
then Packages.extraLibraries pkg
else Packages.extraGHCiLibraries pkg)
++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
- classifieds <- mapM (locateOneObj dirs) libs
+ classifieds <- mapM (locateOneObj dirs) libs'
-- Complication: all the .so's must be loaded before any of the .o's.
let dlls = [ dll | DLL dll <- classifieds ]
objs = [ obj | Object obj <- classifieds ]
+ archs = [ arch | Archive arch <- classifieds ]
- maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
+ maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ")
-- See comments with partOfGHCi
- when (pkgName (package pkg) `notElem` partOfGHCi) $ do
+ when (packageName pkg `notElem` partOfGHCi) $ do
loadFrameworks pkg
-- When a library A needs symbols from a library B, the order in
-- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
-- Ordering isn't important here, because we do one final link
-- step to resolve everything.
mapM_ loadObj objs
+ mapM_ loadArchive archs
maybePutStr dflags "linking ... "
ok <- resolveObjs
if succeeded ok then maybePutStrLn dflags "done."
- else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
+ else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
+load_dyn :: [FilePath] -> FilePath -> IO ()
load_dyn dirs dll = do r <- loadDynamic dirs dll
case r of
Nothing -> return ()
- Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
+ Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")" ))
-#ifndef darwin_TARGET_OS
-loadFrameworks pkg = return ()
-#else
-loadFrameworks pkg = mapM_ load frameworks
+
+loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
+loadFrameworks pkg
+ | isDarwinTarget = mapM_ load frameworks
+ | otherwise = 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 -> throwDyn (CmdLineError ("can't load framework: "
+ Just err -> ghcError (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
-#endif
-- Try to find an object file for a given library in the given paths.
-- If it isn't present, we assume it's a dynamic library.
-#ifndef __PIC__
--- When the GHC package was not compiled as dynamic library (=__PIC__ not set),
--- we search for .o libraries first.
-locateOneObj :: [FilePath] -> String -> IO LibrarySpec
-locateOneObj dirs lib
- = do { mb_obj_path <- findFile mk_obj_path dirs
- ; case mb_obj_path of
- Just obj_path -> return (Object obj_path)
- Nothing ->
- do { mb_lib_path <- findFile mk_dyn_lib_path dirs
- ; case mb_lib_path of
- Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
- Nothing -> return (DLL lib) }} -- We assume
- where
- mk_obj_path dir = dir </> lib <.> "o"
- mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
-#else
--- When the GHC package was compiled as dynamic library (=__PIC__ set),
--- we search for .so libraries first.
locateOneObj :: [FilePath] -> String -> IO LibrarySpec
locateOneObj dirs lib
- = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
- ; case mb_lib_path of
- Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
- Nothing ->
- do { mb_obj_path <- findFile mk_obj_path dirs
- ; case mb_obj_path of
- Just obj_path -> return (Object obj_path)
- Nothing -> return (DLL lib) }} -- We assume
+ | not ("HS" `isPrefixOf` lib)
+ -- For non-Haskell libraries (e.g. gmp, iconv) we assume dynamic library
+ = assumeDll
+ | not isDynamicGhcLib
+ -- When the GHC package was not compiled as dynamic library
+ -- (=DYNAMIC not set), we search for .o libraries or, if they
+ -- don't exist, .a libraries.
+ = findObject `orElse` findArchive `orElse` assumeDll
+ | otherwise
+ -- When the GHC package was compiled as dynamic library (=DYNAMIC set),
+ -- we search for .so libraries first.
+ = findDll `orElse` findObject `orElse` findArchive `orElse` assumeDll
where
mk_obj_path dir = dir </> (lib <.> "o")
- mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
-#endif
+ mk_arch_path dir = dir </> ("lib" ++ lib <.> "a")
+ dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
+ mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name
+ findObject = liftM (fmap Object) $ findFile mk_obj_path dirs
+ findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs
+ findDll = liftM (fmap DLL) $ findFile mk_dyn_lib_path dirs
+ assumeDll = return (DLL lib)
+ infixr `orElse`
+ f `orElse` g = do m <- f
+ case m of
+ Just x -> return x
+ Nothing -> g
-- ----------------------------------------------------------------------------
-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
-- return Nothing == success, else Just error message from dlopen
+loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String)
loadDynamic paths rootname
= do { mb_dll <- findFile mk_dll_path paths
; case mb_dll of
where
mk_dll_path dir = dir </> mkSOName rootname
-#if defined(darwin_TARGET_OS)
-mkSOName root = ("lib" ++ root) <.> "dylib"
-#elif defined(mingw32_TARGET_OS)
--- Win32 DLLs have no .dll extension here, because addDLL tries
--- both foo.dll and foo.drv
-mkSOName root = root
-#else
-mkSOName root = ("lib" ++ root) <.> "so"
-#endif
+mkSOName :: FilePath -> FilePath
+mkSOName root
+ | isDarwinTarget = ("lib" ++ root) <.> "dylib"
+ | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
+ -- addDLL tries both foo.dll and foo.drv
+ root
+ | otherwise = ("lib" ++ root) <.> "so"
-- Darwin / MacOS X only: load a framework
-- a framework is a dynamic library packaged inside a directory of the same
-- name. They are searched for in different paths than normal libraries.
-#ifdef darwin_TARGET_OS
+loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
loadFramework extraPaths rootname
- = do { either_dir <- Control.Exception.try getHomeDirectory
+ = do { either_dir <- tryIO getHomeDirectory
; let homeFrameworkPath = case either_dir of
Left _ -> []
Right dir -> [dir ++ "/Library/Frameworks"]
mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
-- sorry for the hardcoded paths, I hope they won't change anytime soon:
defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
-#endif
\end{code}
%************************************************************************
findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
-> [FilePath] -- Directories to look in
-> IO (Maybe FilePath) -- The first file path to match
-findFile mk_file_path []
+findFile _ []
= return Nothing
findFile mk_file_path (dir:dirs)
= do { let file_path = mk_file_path dir
\end{code}
\begin{code}
+maybePutStr :: DynFlags -> String -> IO ()
maybePutStr dflags s | verbosity dflags > 0 = putStr s
| otherwise = return ()
+maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
| otherwise = return ()
\end{code}
projects / ghc-hetmet.git / blobdiff