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.

1 files changed, 146 insertions, 144 deletions

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 9f45579a52..5c05122ed4 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