Allow for multiple linker instances. Fixes Haskell portion of #3372.

12 files changed, 284 insertions, 151 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index fe43fa9b46..e3e3df0b3f 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -651,6 +651,7 @@ Library
             ByteCodeItbls
             ByteCodeLink
             Debugger
+            LinkerTypes
             Linker
             RtClosureInspect
             GHCi
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 888d00ed06..d803c0b729 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -123,7 +123,8 @@ bindSuspensions t = do
       let ids = [ mkVanillaGlobal name ty
                 | (name,ty) <- zip names tys]
           new_ic = extendInteractiveContextWithIds ictxt ids
-      liftIO $ extendLinkEnv (zip names fhvs)
+          dl = hsc_dynLinker hsc_env
+      liftIO $ extendLinkEnv dl (zip names fhvs)
       setSession hsc_env {hsc_IC = new_ic }
       return t'
      where
@@ -177,8 +178,10 @@ showTerm term = do
                expr = "Prelude.return (Prelude.show " ++
                          showPpr dflags bname ++
                       ") :: Prelude.IO Prelude.String"
+               dl   = hsc_dynLinker hsc_env
            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
-           txt_ <- withExtendedLinkEnv [(bname, fhv)]
+           txt_ <- withExtendedLinkEnv dl
+                                       [(bname, fhv)]
                                        (GHC.compileExprRemote expr)
            let myprec = 10 -- application precedence. TODO Infix constructors
            txt <- liftIO $ evalString hsc_env txt_
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index ef00a85e72..636e7c35de 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -15,8 +15,9 @@ module Linker ( getHValue, showLinkerState,
                 linkExpr, linkDecls, unload, withExtendedLinkEnv,
                 extendLinkEnv, deleteFromLinkEnv,
                 extendLoadedPkgs,
-                linkPackages,initDynLinker,linkModule,
-                linkCmdLineLibs
+                linkPackages, initDynLinker, linkModule,
+                linkCmdLineLibs,
+                uninitializedLinker
         ) where
 
 #include "HsVersions.h"
@@ -38,6 +39,7 @@ import Name
 import NameEnv
 import Module
 import ListSetOps
+import LinkerTypes (DynLinker(..), LinkerUnitId, PersistentLinkerState(..))
 import DynFlags
 import BasicTypes
 import Outputable
@@ -72,11 +74,6 @@ import System.Win32.Info (getSystemDirectory)
 
 import Exception
 
--- needed for 2nd stage
-#if STAGE >= 2
-import Foreign (Ptr)
-#endif
-
 {- **********************************************************************
 
                         The Linker's state
@@ -85,76 +82,40 @@ import Foreign (Ptr)
 
 {-
 The persistent linker state *must* match the actual state of the
-C dynamic linker at all times, so we keep it in a private global variable.
+C dynamic linker at all times.
 
-The global IORef used for PersistentLinkerState actually contains another MVar,
-which in turn contains a Maybe PersistentLinkerState. The MVar serves to ensure
-mutual exclusion between multiple loaded copies of the GHC library. The Maybe
-may be Nothing to indicate that the linker has not yet been initialised.
+The MVar used to hold the PersistentLinkerState contains a Maybe
+PersistentLinkerState. The MVar serves to ensure mutual exclusion between
+multiple loaded copies of the GHC library. The Maybe may be Nothing to
+indicate that the linker has not yet been initialised.
 
 The PersistentLinkerState maps Names to actual closures (for
 interpreted code only), for use during linking.
 -}
-#if STAGE < 2
-GLOBAL_VAR_M( v_PersistentLinkerState
-            , newMVar Nothing
-            , MVar (Maybe PersistentLinkerState))
-#else
-SHARED_GLOBAL_VAR_M( v_PersistentLinkerState
-                   , getOrSetLibHSghcPersistentLinkerState
-                   , "getOrSetLibHSghcPersistentLinkerState"
-                   , newMVar Nothing
-                   , MVar (Maybe PersistentLinkerState))
-#endif
+
+uninitializedLinker :: IO DynLinker
+uninitializedLinker =
+  newMVar Nothing >>= (pure . DynLinker)
 
 uninitialised :: a
 uninitialised = panic "Dynamic linker not initialised"
 
-modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
-modifyPLS_ f = readIORef v_PersistentLinkerState
-  >>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised)
+modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
+modifyPLS_ dl f =
+  modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised)
 
-modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
-modifyPLS f = readIORef v_PersistentLinkerState
-  >>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised)
+modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
+modifyPLS dl f =
+  modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised)
   where fmapFst f = fmap (\(x, y) -> (f x, y))
 
-readPLS :: IO PersistentLinkerState
-readPLS = readIORef v_PersistentLinkerState
-  >>= fmap (fromMaybe uninitialised) . readMVar
+readPLS :: DynLinker -> IO PersistentLinkerState
+readPLS dl =
+  (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl)
 
 modifyMbPLS_
-  :: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
-modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
-
-data PersistentLinkerState
-   = PersistentLinkerState {
-
-        -- Current global mapping from Names to their true values
-        closure_env :: ClosureEnv,
-
-        -- The current global mapping from RdrNames of DataCons to
-        -- info table addresses.
-        -- 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,
-
-        -- The currently loaded interpreted modules (home package)
-        bcos_loaded :: ![Linkable],
-
-        -- And the currently-loaded compiled modules (home package)
-        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 :: ![LinkerUnitId],
-
-        -- we need to remember the name of previous temporary DLL/.so
-        -- libraries so we can link them (see #10322)
-        temp_sos :: ![(FilePath, String)] }
-
+  :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
+modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f 
 
 emptyPLS :: DynFlags -> PersistentLinkerState
 emptyPLS _ = PersistentLinkerState {
@@ -172,22 +133,21 @@ emptyPLS _ = PersistentLinkerState {
   -- explicit list.  See rts/Linker.c for details.
   where init_pkgs = map toInstalledUnitId [rtsUnitId]
 
-
-extendLoadedPkgs :: [InstalledUnitId] -> IO ()
-extendLoadedPkgs pkgs =
-  modifyPLS_ $ \s ->
+extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO ()
+extendLoadedPkgs dl pkgs =
+  modifyPLS_ dl $ \s ->
       return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
 
-extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
-extendLinkEnv new_bindings =
-  modifyPLS_ $ \pls@PersistentLinkerState{..} -> do
+extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO ()
+extendLinkEnv dl new_bindings =
+  modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do
     let new_ce = extendClosureEnv closure_env new_bindings
     return $! pls{ closure_env = new_ce }
     -- strictness is important for not retaining old copies of the pls
 
-deleteFromLinkEnv :: [Name] -> IO ()
-deleteFromLinkEnv to_remove =
-  modifyPLS_ $ \pls -> do
+deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()
+deleteFromLinkEnv dl to_remove =
+  modifyPLS_ dl $ \pls -> do
     let ce = closure_env pls
     let new_ce = delListFromNameEnv ce to_remove
     return pls{ closure_env = new_ce }
@@ -199,8 +159,9 @@ deleteFromLinkEnv to_remove =
 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
 getHValue :: HscEnv -> Name -> IO ForeignHValue
 getHValue hsc_env name = do
+  let dl = hsc_dynLinker hsc_env
   initDynLinker hsc_env
-  pls <- modifyPLS $ \pls -> do
+  pls <- modifyPLS dl $ \pls -> do
            if (isExternalName name) then do
              (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
                               [nameModule name]
@@ -223,7 +184,7 @@ linkDependencies :: HscEnv -> PersistentLinkerState
                  -> SrcSpan -> [Module]
                  -> IO (PersistentLinkerState, SuccessFlag)
 linkDependencies hsc_env pls span needed_mods = do
---   initDynLinker (hsc_dflags hsc_env)
+--   initDynLinker (hsc_dflags hsc_env) dl
    let hpt = hsc_HPT hsc_env
        dflags = hsc_dflags hsc_env
    -- The interpreter and dynamic linker can only handle object code built
@@ -244,9 +205,9 @@ linkDependencies hsc_env pls span needed_mods = do
 -- | Temporarily extend the linker state.
 
 withExtendedLinkEnv :: (ExceptionMonad m) =>
-                       [(Name,ForeignHValue)] -> m a -> m a
-withExtendedLinkEnv new_env action
-    = gbracket (liftIO $ extendLinkEnv new_env)
+                       DynLinker -> [(Name,ForeignHValue)] -> m a -> m a
+withExtendedLinkEnv dl new_env action
+    = gbracket (liftIO $ extendLinkEnv dl new_env)
                (\_ -> reset_old_env)
                (\_ -> action)
     where
@@ -256,16 +217,16 @@ withExtendedLinkEnv new_env action
         -- package), so the reset action only removes the names we
         -- added earlier.
           reset_old_env = liftIO $ do
-            modifyPLS_ $ \pls ->
+            modifyPLS_ dl $ \pls ->
                 let cur = closure_env pls
                     new = delListFromNameEnv cur (map fst new_env)
                 in return pls{ closure_env = new }
 
 
 -- | Display the persistent linker state.
-showLinkerState :: DynFlags -> IO ()
-showLinkerState dflags
-  = do pls <- readPLS
+showLinkerState :: DynLinker -> DynFlags -> IO ()
+showLinkerState dl dflags
+  = do pls <- readPLS dl
        putLogMsg dflags NoReason SevDump noSrcSpan
           (defaultDumpStyle dflags)
                  (vcat [text "----- Linker state -----",
@@ -299,8 +260,9 @@ showLinkerState dflags
 -- trying to link.
 --
 initDynLinker :: HscEnv -> IO ()
-initDynLinker hsc_env =
-  modifyMbPLS_ $ \pls -> do
+initDynLinker hsc_env = do
+  let dl = hsc_dynLinker hsc_env
+  modifyMbPLS_ dl $ \pls -> do
     case pls of
       Just  _ -> return pls
       Nothing -> Just <$> reallyInitDynLinker hsc_env
@@ -323,8 +285,9 @@ reallyInitDynLinker hsc_env = do
 
 linkCmdLineLibs :: HscEnv -> IO ()
 linkCmdLineLibs hsc_env = do
+  let dl = hsc_dynLinker hsc_env
   initDynLinker hsc_env
-  modifyPLS_ $ \pls -> do
+  modifyPLS_ dl $ \pls -> do
     linkCmdLineLibs' hsc_env pls
 
 linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
@@ -548,8 +511,11 @@ linkExpr hsc_env span root_ul_bco
      -- Initialise the linker (if it's not been done already)
    ; initDynLinker hsc_env
 
+     -- Extract the DynLinker value for passing into required places
+   ; let dl = hsc_dynLinker hsc_env
+
      -- Take lock for the actual work.
-   ; modifyPLS $ \pls0 -> do {
+   ; modifyPLS dl $ \pls0 -> do {
 
      -- Link the packages and modules required
    ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
@@ -778,8 +744,11 @@ linkDecls hsc_env span cbc@CompiledByteCode{..} = do
     -- Initialise the linker (if it's not been done already)
     initDynLinker hsc_env
 
+    -- Extract the DynLinker for passing into required places
+    let dl = hsc_dynLinker hsc_env
+
     -- Take lock for the actual work.
-    modifyPLS $ \pls0 -> do
+    modifyPLS dl $ \pls0 -> do
 
     -- Link the packages and modules required
     (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
@@ -820,7 +789,8 @@ linkDecls hsc_env span cbc@CompiledByteCode{..} = do
 linkModule :: HscEnv -> Module -> IO ()
 linkModule hsc_env mod = do
   initDynLinker hsc_env
-  modifyPLS_ $ \pls -> do
+  let dl = hsc_dynLinker hsc_env
+  modifyPLS_ dl $ \pls -> do
     (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
     if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
       else return pls'
@@ -1084,8 +1054,11 @@ unload hsc_env linkables
         -- Initialise the linker (if it's not been done already)
         initDynLinker hsc_env
 
+        -- Extract DynLinker for passing into required places
+        let dl = hsc_dynLinker hsc_env
+
         new_pls
-            <- modifyPLS $ \pls -> do
+            <- modifyPLS dl $ \pls -> do
                  pls1 <- unload_wkr hsc_env linkables pls
                  return (pls1, pls1)
 
@@ -1206,9 +1179,6 @@ showLS (DLL nm)       = "(dynamic) " ++ nm
 showLS (DLLPath nm)   = "(dynamic) " ++ nm
 showLS (Framework nm) = "(framework) " ++ nm
 
--- TODO: Make this type more precise
-type LinkerUnitId = InstalledUnitId
-
 -- | 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
@@ -1227,7 +1197,8 @@ linkPackages hsc_env new_pkgs = do
   -- It's probably not safe to try to load packages concurrently, so we take
   -- a lock.
   initDynLinker hsc_env
-  modifyPLS_ $ \pls -> do
+  let dl = hsc_dynLinker hsc_env
+  modifyPLS_ dl $ \pls -> do
     linkPackages' hsc_env new_pkgs pls
 
 linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState
diff --git a/compiler/ghci/LinkerTypes.hs b/compiler/ghci/LinkerTypes.hs
new file mode 100644
index 0000000000..ca578de95a
--- /dev/null
+++ b/compiler/ghci/LinkerTypes.hs
@@ -0,0 +1,112 @@
+-----------------------------------------------------------------------------
+--
+-- Types for the Dynamic Linker
+--
+-- (c) The University of Glasgow 2019
+--
+-----------------------------------------------------------------------------
+
+module LinkerTypes (
+      DynLinker(..),
+      PersistentLinkerState(..),
+      LinkerUnitId,
+      Linkable(..),
+      Unlinked(..),
+      SptEntry(..)
+    ) where
+
+import GhcPrelude              ( FilePath, String, show )
+import Data.Time               ( UTCTime )
+import Data.Maybe              ( Maybe )
+import Control.Concurrent.MVar ( MVar )
+import Module                  ( InstalledUnitId, Module )
+import ByteCodeTypes           ( ItblEnv, CompiledByteCode )
+import Outputable
+import Var                     ( Id )
+import GHC.Fingerprint.Type    ( Fingerprint )
+import NameEnv                 ( NameEnv )
+import Name                    ( Name )
+import GHCi.RemoteTypes        ( ForeignHValue )
+
+type ClosureEnv = NameEnv (Name, ForeignHValue) 
+
+newtype DynLinker =
+  DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) }
+
+data PersistentLinkerState
+  = PersistentLinkerState {
+
+       -- Current global mapping from Names to their true values
+       closure_env :: ClosureEnv,
+
+       -- The current global mapping from RdrNames of DataCons to
+       -- info table addresses.
+       -- 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,
+
+       -- The currently loaded interpreted modules (home package)
+       bcos_loaded :: ![Linkable],
+
+       -- And the currently-loaded compiled modules (home package)
+       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 :: ![LinkerUnitId],
+
+       -- we need to remember the name of previous temporary DLL/.so
+       -- libraries so we can link them (see #10322)
+       temp_sos :: ![(FilePath, String)] }
+
+-- TODO: Make this type more precise
+type LinkerUnitId = InstalledUnitId
+
+-- | Information we can use to dynamically link modules into the compiler
+data Linkable = LM {
+  linkableTime     :: UTCTime,          -- ^ Time at which this linkable was built
+                                        -- (i.e. when the bytecodes were produced,
+                                        --       or the mod date on the files)
+  linkableModule   :: Module,           -- ^ The linkable module itself
+  linkableUnlinked :: [Unlinked]
+    -- ^ Those files and chunks of code we have yet to link.
+    --
+    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.
+    -- If this list is empty, the Linkable represents a fake linkable, which
+    -- is generated in HscNothing mode to avoid recompiling modules.
+    --
+    -- ToDo: Do items get removed from this list when they get linked?
+ }
+
+instance Outputable Linkable where
+  ppr (LM when_made mod unlinkeds)
+     = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
+       $$ nest 3 (ppr unlinkeds)
+
+-- | Objects which have yet to be linked by the compiler
+data Unlinked
+  = DotO FilePath      -- ^ An object file (.o)
+  | DotA FilePath      -- ^ Static archive file (.a)
+  | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)
+  | BCOs CompiledByteCode
+         [SptEntry]    -- ^ A byte-code object, lives only in memory. Also
+                       -- carries some static pointer table entries which
+                       -- should be loaded along with the BCOs.
+                       -- See Note [Grant plan for static forms] in
+                       -- StaticPtrTable.
+
+instance Outputable Unlinked where
+  ppr (DotO path)   = text "DotO" <+> text path
+  ppr (DotA path)   = text "DotA" <+> text path
+  ppr (DotDLL path) = text "DotDLL" <+> text path
+  ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt
+
+-- | An entry to be inserted into a module's static pointer table.
+-- See Note [Grand plan for static forms] in StaticPtrTable.
+data SptEntry = SptEntry Id Fingerprint
+
+instance Outputable SptEntry where
+  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 911d52cbfd..26d794e819 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -193,6 +193,7 @@ newHscEnv dflags = do
     nc_var  <- newIORef (initNameCache us knownKeyNames)
     fc_var  <- newIORef emptyInstalledModuleEnv
     iserv_mvar <- newMVar Nothing
+    emptyDynLinker <- uninitializedLinker
     return HscEnv {  hsc_dflags       = dflags
                   ,  hsc_targets      = []
                   ,  hsc_mod_graph    = emptyMG
@@ -202,7 +203,8 @@ newHscEnv dflags = do
                   ,  hsc_NC           = nc_var
                   ,  hsc_FC           = fc_var
                   ,  hsc_type_env_var = Nothing
-                  , hsc_iserv        = iserv_mvar
+                  ,  hsc_iserv        = iserv_mvar
+                  ,  hsc_dynLinker    = emptyDynLinker
                   }
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 8c41f9b9fc..15f515059d 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -181,6 +181,7 @@ import TysWiredIn
 import Packages hiding  ( Version(..) )
 import CmdLineParser
 import DynFlags
+import LinkerTypes      ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) )
 import DriverPhases     ( Phase, HscSource(..), hscSourceString
                         , isHsBootOrSig, isHsigFile )
 import qualified DriverPhases as Phase
@@ -375,8 +376,10 @@ shouldPrintWarning _ _
 
 -- | HscEnv is like 'Session', except that some of the fields are immutable.
 -- An HscEnv is used to compile a single module from plain Haskell source
--- code (after preprocessing) to either C, assembly or C--.  Things like
--- the module graph don't change during a single compilation.
+-- code (after preprocessing) to either C, assembly or C--. It's also used
+-- to store the dynamic linker state to allow for multiple linkers in the
+-- same address space.
+-- Things like the module graph don't change during a single compilation.
 --
 -- Historical note: \"hsc\" used to be the name of the compiler binary,
 -- when there was a separate driver and compiler.  To compile a single
@@ -438,6 +441,10 @@ data HscEnv
         , hsc_iserv :: MVar (Maybe IServ)
                 -- ^ interactive server process.  Created the first
                 -- time it is needed.
+
+        , hsc_dynLinker :: DynLinker
+                -- ^ dynamic linker. 
+
  }
 
 -- Note [hsc_type_env_var hack]
@@ -1388,13 +1395,6 @@ appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
 appendStubC NoStubs            c_code = ForeignStubs empty c_code
 appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
 
--- | An entry to be inserted into a module's static pointer table.
--- See Note [Grand plan for static forms] in StaticPtrTable.
-data SptEntry = SptEntry Id Fingerprint
-
-instance Outputable SptEntry where
-  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
-
 {-
 ************************************************************************
 *                                                                      *
@@ -2992,22 +2992,6 @@ This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs
 stuff is the *dynamic* linker, and isn't present in a stage-1 compiler
 -}
 
--- | Information we can use to dynamically link modules into the compiler
-data Linkable = LM {
-  linkableTime     :: UTCTime,          -- ^ Time at which this linkable was built
-                                        -- (i.e. when the bytecodes were produced,
-                                        --       or the mod date on the files)
-  linkableModule   :: Module,           -- ^ The linkable module itself
-  linkableUnlinked :: [Unlinked]
-    -- ^ Those files and chunks of code we have yet to link.
-    --
-    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.
-    -- If this list is empty, the Linkable represents a fake linkable, which
-    -- is generated in HscNothing mode to avoid recompiling modules.
-    --
-    -- ToDo: Do items get removed from this list when they get linked?
- }
-
 isObjectLinkable :: Linkable -> Bool
 isObjectLinkable l = not (null unlinked) && all isObject unlinked
   where unlinked = linkableUnlinked l
@@ -3019,31 +3003,8 @@ isObjectLinkable l = not (null unlinked) && all isObject unlinked
 linkableObjs :: Linkable -> [FilePath]
 linkableObjs l = [ f | DotO f <- linkableUnlinked l ]
 
-instance Outputable Linkable where
-   ppr (LM when_made mod unlinkeds)
-      = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
-        $$ nest 3 (ppr unlinkeds)
-
 -------------------------------------------
 
--- | Objects which have yet to be linked by the compiler
-data Unlinked
-   = DotO FilePath      -- ^ An object file (.o)
-   | DotA FilePath      -- ^ Static archive file (.a)
-   | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)
-   | BCOs CompiledByteCode
-          [SptEntry]    -- ^ A byte-code object, lives only in memory. Also
-                        -- carries some static pointer table entries which
-                        -- should be loaded along with the BCOs.
-                        -- See Note [Grant plan for static forms] in
-                        -- StaticPtrTable.
-
-instance Outputable Unlinked where
-   ppr (DotO path)   = text "DotO" <+> text path
-   ppr (DotA path)   = text "DotA" <+> text path
-   ppr (DotDLL path) = text "DotDLL" <+> text path
-   ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt
-
 -- | Is this an actual file on disk we can link in somehow?
 isObject :: Unlinked -> Bool
 isObject (DotO _)   = True
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 11b0e57126..5f322006eb 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -357,7 +357,8 @@ handleRunStatus step expr bindings final_ids status history
     = do hsc_env <- getSession
          let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
              final_names = map getName final_ids
-         liftIO $ Linker.extendLinkEnv (zip final_names hvals)
+             dl = hsc_dynLinker hsc_env
+         liftIO $ Linker.extendLinkEnv dl (zip final_names hvals)
          hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
          setSession hsc_env'
          return (ExecComplete (Right final_names) allocs)
@@ -396,7 +397,8 @@ resumeExec canLogSpan step
             new_names = [ n | thing <- ic_tythings ic
                             , let n = getName thing
                             , not (n `elem` old_names) ]
-        liftIO $ Linker.deleteFromLinkEnv new_names
+            dl        = hsc_dynLinker hsc_env
+        liftIO $ Linker.deleteFromLinkEnv dl new_names
 
         case r of
           Resume { resumeStmt = expr, resumeContext = fhv
@@ -490,8 +492,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 
        ictxt0 = hsc_IC hsc_env
        ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
+       dl     = hsc_dynLinker hsc_env
    --
-   Linker.extendLinkEnv [(exn_name, apStack)]
+   Linker.extendLinkEnv dl [(exn_name, apStack)]
    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
 
 -- Just case: we stopped at a breakpoint, we have information about the location
@@ -548,10 +551,11 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
        ictxt0 = hsc_IC hsc_env
        ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
        names  = map idName new_ids
+       dl     = hsc_dynLinker hsc_env
 
    let fhvs = catMaybes mb_hValues
-   Linker.extendLinkEnv (zip names fhvs)
-   when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
+   Linker.extendLinkEnv dl (zip names fhvs)
+   when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)]
    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
    return (hsc_env1, if result_ok then result_name:names else names, span, decl)
   where
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
index a54783af5c..3086bf411b 100644
--- a/docs/users_guide/8.10.1-notes.rst
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -66,6 +66,10 @@ Compiler
   support for 64-bit `MOV`s. In particular, `setByteArray#` and
   `copyByteArray#` calls that were not optimized before, now will
   be. See :ghc-ticket:`16052`.
+- GHC's runtime linker no longer uses global state. This allows programs
+  that use the GHC API to safely use multiple GHC sessions in a single 
+  process, as long as there are no native dependencies that rely on
+  global state.
 
 Runtime system
 ~~~~~~~~~~~~~~
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index da288c5e1e..5dc3aa7d4d 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -55,7 +55,8 @@ import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)
 import HsImpExp
 import HsSyn
 import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
-                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc )
+                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,
+                  hsc_dynLinker )
 import Module
 import Name
 import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,
@@ -2998,6 +2999,7 @@ showCmd "-a" = showOptions True
 showCmd str = do
     st <- getGHCiState
     dflags <- getDynFlags
+    hsc_env <- GHC.getSession
 
     let lookupCmd :: String -> Maybe (m ())
         lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds
@@ -3017,7 +3019,7 @@ showCmd str = do
             , action "imports"    $ showImports
             , action "modules"    $ showModules
             , action "bindings"   $ showBindings
-            , action "linker"     $ getDynFlags >>= liftIO . showLinkerState
+            , action "linker"     $ getDynFlags >>= liftIO . (showLinkerState (hsc_dynLinker hsc_env))
             , action "breaks"     $ showBkptTable
             , action "context"    $ showContext
             , action "packages"   $ showPackages
diff --git a/testsuite/tests/ghci/linking/dyn/T3372.hs b/testsuite/tests/ghci/linking/dyn/T3372.hs
new file mode 100644
index 0000000000..49b71488c2
--- /dev/null
+++ b/testsuite/tests/ghci/linking/dyn/T3372.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import Prelude hiding ( init )
+import System.Environment
+
+import Control.Monad ( join, forever )
+import Control.Concurrent ( forkIO )
+import Control.Concurrent.Chan
+
+import GHC ( Ghc )
+import qualified GHC
+import qualified MonadUtils as GHC
+
+import qualified GHC.Exts
+
+main :: IO ()
+main = do let test1 = "TestMain1.hs"
+          let test2 = "TestMain2.hs"
+          writeFile test1 "module Main where main = return () ; test1 = (1,2,3)"
+          writeFile test2 "module Main where main = return () ; test2 = (3,2,1)"
+          --
+          ghc_1 <- newGhcServer
+          ghc_2 <- newGhcServer
+          line "1" $ runInServer ghc_1 $ load (test1, "Main")
+          line "2" $ runInServer ghc_2 $ load (test2, "Main")
+          line "3" $ runInServer ghc_1 $ eval "test1"
+          line "4" $ runInServer ghc_2 $ eval "test2"
+  where line n a = putStr (n ++ ": ") >> a 
+
+type ModuleName = String
+type GhcServerHandle = Chan (Ghc ())
+
+newGhcServer :: IO GhcServerHandle
+newGhcServer = do (libdir:_) <- getArgs
+                  pChan <- newChan
+                  let be_a_server = forever $ join (GHC.liftIO $ readChan pChan)
+                  forkIO $ ghc be_a_server libdir
+                  return pChan 
+  where ghc action libdir = GHC.runGhc (Just libdir) (init >> action)
+        init = do df <- GHC.getSessionDynFlags
+                  GHC.setSessionDynFlags df{GHC.ghcMode    = GHC.CompManager,
+                                            GHC.hscTarget  = GHC.HscInterpreted,
+                                            GHC.ghcLink    = GHC.LinkInMemory,
+                                            GHC.verbosity  = 0}
+
+runInServer :: GhcServerHandle -> Ghc a -> IO a
+runInServer h action = do me <- newChan
+                          writeChan h $ action >>= (GHC.liftIO . writeChan me)
+                          readChan me
+
+load :: (FilePath,ModuleName) -> Ghc ()
+load (f,mn) = do target <- GHC.guessTarget f Nothing
+                 GHC.setTargets [target]
+                 res <- GHC.load GHC.LoadAllTargets
+                 GHC.liftIO $ putStrLn ("Load " ++ showSuccessFlag res)
+                 --
+                 m <- GHC.findModule (GHC.mkModuleName mn) Nothing
+                 GHC.setContext [GHC.IIModule $ GHC.moduleName $ m]
+    where showSuccessFlag GHC.Succeeded = "succeeded"
+          showSuccessFlag GHC.Failed    = "failed"
+
+eval :: String -> Ghc ()
+eval e = do show_e <- GHC.compileExpr $ "(show ("++ e ++")) :: String"
+            GHC.liftIO $ putStrLn (GHC.Exts.unsafeCoerce# show_e)
diff --git a/testsuite/tests/ghci/linking/dyn/T3372.stdout b/testsuite/tests/ghci/linking/dyn/T3372.stdout
new file mode 100644
index 0000000000..2299e35857
--- /dev/null
+++ b/testsuite/tests/ghci/linking/dyn/T3372.stdout
@@ -0,0 +1,4 @@
+1: Load succeeded
+2: Load succeeded
+3: (1,2,3)
+4: (3,2,1)
\ No newline at end of file
diff --git a/testsuite/tests/ghci/linking/dyn/all.T b/testsuite/tests/ghci/linking/dyn/all.T
index 2efcbbb4fa..75b1635dd0 100644
--- a/testsuite/tests/ghci/linking/dyn/all.T
+++ b/testsuite/tests/ghci/linking/dyn/all.T
@@ -44,3 +44,6 @@ test('T13606', [unless(doing_ghci, skip), unless(opsys('mingw32'), skip),
 test('big-obj', [extra_files(['big-obj-c.c', 'big-obj.hs']),
                     unless(doing_ghci, skip), unless(opsys('mingw32'), skip)],
      makefile_test, ['big-obj'])
+
+test('T3372', [unless(doing_ghci, skip), extra_run_opts('"' + config.libdir + '"')],
+     compile_and_run, ['-package ghc'])