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

3 files changed, 21 insertions, 54 deletions

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