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.
{-# NOINLINE name #-}; \
name :: IORef (ty); \
name = Util.global (value);
{-# 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);
#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);
%
% (c) The University of Glasgow 2005-2006
%
%
% (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.
-
-
+-- | 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
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
import Data.IORef
import Data.List
import Foreign
import Data.IORef
import Data.List
import Foreign
+import Control.Concurrent.MVar
import System.FilePath
import System.IO
import System.FilePath
import System.IO
interpreted code only), for use during linking.
\begin{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
GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
data PersistentLinkerState
\begin{code}
extendLoadedPkgs :: [PackageId] -> IO ()
\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 :: [(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 :: [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:
--
-- | 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
--
-- We use this string to lookup the interpreter's internal representation of the name
-- using the lookupOrig.
--
-- 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
dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
dataConInfoPtrToName x = do
theString <- liftIO $ do
(top, []) -> (acc, top)
(top, _:bot) -> parseModOcc (top : acc) bot
(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
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
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
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
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.
-- | Temporarily extend the linker state.
withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
[(Name,HValue)] -> m a -> m a
withExtendedLinkEnv new_env action
withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
[(Name,HValue)] -> m a -> m a
withExtendedLinkEnv new_env action
+ = gbracket (liftIO $ extendLinkEnv new_env)
(\_ -> reset_old_env)
(\_ -> action)
(\_ -> 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 ()
-
-- 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
-- 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)
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;
-- filterNameMap removes from the environment all entries except
-- those for a given set of modules;
+-- | Display the persistent linker state.
--- Display the persistent linker state
- = 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),
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
-
+-- | 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 ()
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
-- (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
-- (c) Link libraries from the command-line
; let optl = getOpts dflags opt_l
; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
++ map DLL minus_ls
++ map Framework frameworks
; 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
else do
{ mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
; if succeeded ok then maybePutStrLn dflags "done"
else ghcError (ProgramError "linking extra libraries/objects failed")
; if succeeded ok then maybePutStrLn dflags "done"
else ghcError (ProgramError "linking extra libraries/objects failed")
}}
classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
}}
classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
%************************************************************************
\begin{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.
--
-- 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
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
-- 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
; if failed ok then
ghcError (ProgramError "")
else do {
-- Link the expression itself
- pls <- readIORef v_PersistentLinkerState
- ; let ie = itbl_env pls
ce = closure_env pls
-- Link the necessary packages and linkables
; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
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)
where
free_names = nameSetToList (bcoFreeNames root_ul_bco)
ptext (sLit "in the desired way using -osuf to set the object file suffix.")
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
-> 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
-- Find all the packages and linkables that a set of modules depends on
- = do { pls <- readIORef v_PersistentLinkerState ;
-- 1. Find the dependent home-pkg-modules/packages from each iface
(mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
-- 1. Find the dependent home-pkg-modules/packages from each iface
(mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
%************************************************************************
\begin{code}
%************************************************************************
\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
= 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
- dynLinkBCOs bcos
- return Succeeded
+ pls2 <- dynLinkBCOs pls1 bcos
+ return (pls2, Succeeded)
-- HACK to support f-x-dynamic in the interpreter; no other purpose
-- HACK to support f-x-dynamic in the interpreter; no other purpose
%************************************************************************
\begin{code}
%************************************************************************
\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' }
-- Load the object files and link them
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
-- If resolving failed, unload all our
-- object modules and carry on
if succeeded ok then do
-- 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
else do
pls2 <- unload_wkr dflags [] pls1
- writeIORef v_PersistentLinkerState pls2
- return Failed
rmDupLinkables :: [Linkable] -- Already loaded
rmDupLinkables :: [Linkable] -- Already loaded
%************************************************************************
\begin{code}
%************************************************************************
\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' }
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
let pls2 = pls1 { closure_env = final_gce,
itbl_env = final_ie }
let pls2 = pls1 { closure_env = final_gce,
itbl_env = final_ie }
- writeIORef v_PersistentLinkerState pls2
- return ()
-- Link a bunch of BCOs and return them + updated closure env.
linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
-- Link a bunch of BCOs and return them + updated closure env.
linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
\begin{code}
-- ---------------------------------------------------------------------------
\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
--
-- 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,
--
-- 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
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))
debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
showLS (DLLPath nm) = "(dynamic) " ++ nm
showLS (Framework nm) = "(framework) " ++ 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,
-- 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.
-- 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 :: 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
link_one pkg_map pkgs new_pkg
| new_pkg `elem` pkgs -- Already linked
doesDirNameExist,
modificationTimeIfExists,
doesDirNameExist,
modificationTimeIfExists,
+ global, consIORef, globalMVar, globalEmptyMVar,
-- * Filenames and paths
Suffix,
-- * Filenames and paths
Suffix,
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef ( readIORef, writeIORef )
import Data.List hiding (group)
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 )
#ifdef DEBUG
import qualified Data.List as List ( elem, notElem )
writeIORef var (x:xs)
\end{code}
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}
Module names:
\begin{code}
projects / ghc-hetmet.git / commitdiff