summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghci/Debugger.hs7
-rw-r--r--compiler/ghci/Linker.hs157
-rw-r--r--compiler/ghci/LinkerTypes.hs112
-rw-r--r--compiler/main/HscMain.hs4
-rw-r--r--compiler/main/HscTypes.hs57
-rw-r--r--compiler/main/InteractiveEval.hs14
-rw-r--r--docs/users_guide/8.10.1-notes.rst4
-rw-r--r--ghc/GHCi/UI.hs6
-rw-r--r--testsuite/tests/ghci/linking/dyn/T3372.hs66
-rw-r--r--testsuite/tests/ghci/linking/dyn/T3372.stdout4
-rw-r--r--testsuite/tests/ghci/linking/dyn/all.T3
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'])
View Lorry Controller Status