From 4fa44a3ae9c36222ccb460ba3ed24e46bf7c70ae Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Mon, 17 Aug 2009 14:23:52 +0000 Subject: [PATCH] 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. --- compiler/HsVersions.h | 9 ++ compiler/ghci/Linker.lhs | 290 +++++++++++++++++++++++----------------------- compiler/utils/Util.lhs | 11 +- 3 files changed, 165 insertions(+), 145 deletions(-) diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h index 4e68bbe..748b031 100644 --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -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 , diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 9f45579..5c05122 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1,17 +1,13 @@ % % (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 diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 3de52b6..5cf020f 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -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} -- 1.7.10.4