Commit 4fa44a3a authored by Thomas Schilling's avatar Thomas Schilling

Make the dynamic linker thread-safe.

  
The current implementation is rather pessimistic.  The persistent
linker state is now an MVar and all exported Linker functions are
wrapped in modifyMVar calls.  This is serves as a big lock around all
linker functions.

There might be a chance for more concurrency in a few places. E.g.,
extending the closure environment and loading packages might be
independent in some cases.  But for now it's better to be on the safe
side.
parent 9f68c348
......@@ -30,11 +30,20 @@ you will screw up the layout where they are used in case expressions!
{-# NOINLINE name #-}; \
name :: IORef (ty); \
name = Util.global (value);
#define GLOBAL_MVAR(name,value,ty) \
{-# NOINLINE name #-}; \
name :: MVar (ty); \
name = Util.globalMVar (value);
#endif
#else /* __HADDOCK__ */
#define GLOBAL_VAR(name,value,ty) \
name :: IORef (ty); \
name = Util.global (value);
#define GLOBAL_MVAR(name,value,ty) \
name :: MVar (ty); \
name = Util.globalMVar (value);
#endif
#define COMMA ,
......
%
% (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}
-- | 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 -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
......@@ -66,6 +62,7 @@ import Data.Char
import Data.IORef
import Data.List
import Foreign
import Control.Concurrent.MVar
import System.FilePath
import System.IO
......@@ -91,7 +88,7 @@ The PersistentLinkerState maps Names to actual closures (for
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
......@@ -137,34 +134,33 @@ emptyPLS _ = PersistentLinkerState {
\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
......@@ -253,17 +249,26 @@ dataConInfoPtrToName x = do
(top, []) -> (acc, top)
(top, _:bot) -> parseModOcc (top : acc) bot
-- | 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) $ ghcError (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
......@@ -273,13 +278,12 @@ linkDependencies hsc_env span needed_mods = do
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.
......@@ -287,27 +291,20 @@ linkDependencies hsc_env span needed_mods = do
withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
[(Name,HValue)] -> m a -> m a
withExtendedLinkEnv new_env action
= gbracket set_new_env
= gbracket (liftIO $ extendLinkEnv new_env)
(\_ -> reset_old_env)
(\_ -> action)
where set_new_env = do
pls <- liftIO $ readIORef v_PersistentLinkerState
let new_closure_env = extendClosureEnv (closure_env pls) new_env
new_pls = pls { closure_env = new_closure_env }
liftIO $ writeIORef v_PersistentLinkerState new_pls
return ()
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 = liftIO $ do
modifyIORef v_PersistentLinkerState $ \pls ->
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;
......@@ -325,10 +322,10 @@ filterNameMap mods env
\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),
......@@ -344,41 +341,43 @@ showLinkerState
%* *
%************************************************************************
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 :: DynFlags -> IO ()
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
......@@ -401,7 +400,7 @@ reallyInitDynLinker dflags
; 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
......@@ -410,6 +409,8 @@ reallyInitDynLinker dflags
; if succeeded ok then maybePutStrLn dflags "done"
else ghcError (ProgramError "linking extra libraries/objects failed")
; return pls
}}
classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
......@@ -476,37 +477,36 @@ preloadLib dflags lib_paths framework_paths lib_spec
%************************************************************************
\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
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)
......@@ -540,16 +540,17 @@ failNonStd srcspan = dieWith srcspan $
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 _ 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 ;
= do {
-- 1. Find the dependent home-pkg-modules/packages from each iface
(mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
......@@ -678,21 +679,22 @@ getLinkDeps hsc_env hpt _ maybe_normal_osuf span mods
%************************************************************************
\begin{code}
linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
linkModules dflags linkables
linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
-> IO (PersistentLinkerState, SuccessFlag)
linkModules dflags pls linkables
= block $ 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
......@@ -729,12 +731,9 @@ 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' }
......@@ -748,12 +747,10 @@ dynLinkObjs dflags objs
-- 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
......@@ -776,10 +773,8 @@ rmDupLinkables already ls
%************************************************************************
\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' }
......@@ -801,8 +796,7 @@ dynLinkBCOs 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
......@@ -841,31 +835,32 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos
\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
-- 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))
......@@ -955,31 +950,38 @@ 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)
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
; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' dflags new_pks pls = do
let pkg_map = pkgIdMap (pkgState dflags)
; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
}
where
pkgs' <- link pkg_map (pkgs_loaded pls) new_pks
return $! 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 pkg_map pkgs new_pkgs =
foldM (link_one pkg_map) pkgs new_pkgs
link_one pkg_map pkgs new_pkg
| new_pkg `elem` pkgs -- Already linked
......
......@@ -65,7 +65,7 @@ module Util (
doesDirNameExist,
modificationTimeIfExists,
global, consIORef,
global, consIORef, globalMVar, globalEmptyMVar,
-- * Filenames and paths
Suffix,
......@@ -83,6 +83,7 @@ import Data.IORef ( IORef, newIORef )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef ( readIORef, writeIORef )
import Data.List hiding (group)
import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar )
#ifdef DEBUG
import qualified Data.List as List ( elem, notElem )
......@@ -699,6 +700,14 @@ consIORef var x = do
writeIORef var (x:xs)
\end{code}
\begin{code}
globalMVar :: a -> MVar a
globalMVar a = unsafePerformIO (newMVar a)
globalEmptyMVar :: MVar a
globalEmptyMVar = unsafePerformIO newEmptyMVar
\end{code}
Module names:
\begin{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment