diff options
| -rw-r--r-- | compiler/HsVersions.h | 14 | ||||
| -rw-r--r-- | compiler/ghci/Linker.lhs | 56 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 24 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.lhs | 72 | ||||
| -rw-r--r-- | compiler/utils/Util.lhs | 10 |
5 files changed, 142 insertions, 34 deletions
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h index 303d2bdc65..b6f92ae2e7 100644 --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -36,19 +36,19 @@ you will screw up the layout where they are used in case expressions! name :: IORef (ty); \ name = Util.global (value); -#define GLOBAL_MVAR(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: MVar (ty); \ -name = Util.globalMVar (value); +#define GLOBAL_VAR_M(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.globalM (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); +#define GLOBAL_VAR_M(name,value,ty) \ +name :: IORef (ty); \ +name = Util.globalM (value); #endif #define COMMA , diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 8b56c4f3ae..9d3a3f7361 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -16,7 +16,10 @@ module Linker ( HValue, getHValue, showLinkerState, extendLinkEnv, deleteFromLinkEnv, extendLoadedPkgs, linkPackages,initDynLinker,linkModule, - dataConInfoPtrToName, lessUnsafeCoerce + dataConInfoPtrToName, lessUnsafeCoerce, + + -- Saving/restoring globals + PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) where #include "HsVersions.h" @@ -86,14 +89,23 @@ import Exception 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. +The global IORef used for PersistentLinkerState actually contains another MVar. +The reason for this is that we want to allow another loaded copy of the GHC +library to side-effect the PLS and for those changes to be reflected here. The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. \begin{code} -GLOBAL_MVAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState) +GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised +modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () +modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f + +modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a +modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f + data PersistentLinkerState = PersistentLinkerState { @@ -138,19 +150,19 @@ emptyPLS _ = PersistentLinkerState { \begin{code} extendLoadedPkgs :: [PackageId] -> IO () extendLoadedPkgs pkgs = - modifyMVar_ v_PersistentLinkerState $ \s -> + modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } extendLinkEnv :: [(Name,HValue)] -> IO () -- Automatically discards shadowed bindings extendLinkEnv new_bindings = - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \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 = - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let new_closure_env = delListFromNameEnv (closure_env pls) to_remove in return pls{ closure_env = new_closure_env } @@ -267,7 +279,7 @@ dataConInfoPtrToName x = do getHValue :: HscEnv -> Name -> IO HValue getHValue hsc_env name = do initDynLinker (hsc_dflags hsc_env) - pls <- modifyMVar v_PersistentLinkerState $ \pls -> do + pls <- modifyPLS $ \pls -> do if (isExternalName name) then do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] if (failed ok) then ghcError (ProgramError "") @@ -313,7 +325,7 @@ withExtendedLinkEnv new_env action -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ do - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } @@ -337,7 +349,7 @@ filterNameMap mods env -- | Display the persistent linker state. showLinkerState :: IO () showLinkerState - = do pls <- readMVar v_PersistentLinkerState + = do pls <- readIORef v_PersistentLinkerState >>= readMVar printDump (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), @@ -374,7 +386,7 @@ showLinkerState -- initDynLinker :: DynFlags -> IO () initDynLinker dflags = - modifyMVar_ v_PersistentLinkerState $ \pls0 -> do + modifyPLS_ $ \pls0 -> do done <- readIORef v_InitLinkerDone if done then return pls0 else do writeIORef v_InitLinkerDone True @@ -512,7 +524,7 @@ linkExpr hsc_env span root_ul_bco ; initDynLinker dflags -- Take lock for the actual work. - ; modifyMVar v_PersistentLinkerState $ \pls0 -> do { + ; modifyPLS $ \pls0 -> do { -- Link the packages and modules required ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods @@ -711,10 +723,10 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods linkModule :: HscEnv -> Module -> IO () linkModule hsc_env mod = do initDynLinker (hsc_dflags hsc_env) - modifyMVar v_PersistentLinkerState $ \pls -> do + modifyPLS_ $ \pls -> do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] if (failed ok) then ghcError (ProgramError "could not link module") - else return (pls',()) + else return pls' -- | Coerce a value as usual, but: -- @@ -921,7 +933,7 @@ unload dflags linkables initDynLinker dflags new_pls - <- modifyMVar v_PersistentLinkerState $ \pls -> do + <- modifyPLS $ \pls -> do pls1 <- unload_wkr dflags linkables pls return (pls1, pls1) @@ -1034,7 +1046,7 @@ linkPackages dflags new_pkgs = do -- It's probably not safe to try to load packages concurrently, so we take -- a lock. initDynLinker dflags - modifyMVar_ v_PersistentLinkerState $ \pls -> do + modifyPLS_ $ \pls -> do linkPackages' dflags new_pkgs pls linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState @@ -1248,3 +1260,19 @@ maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s | otherwise = return () \end{code} + +%************************************************************************ +%* * + Tunneling global variables into new instance of GHC library +%* * +%************************************************************************ + +\begin{code} +saveLinkerGlobals :: IO (MVar PersistentLinkerState, Bool) +saveLinkerGlobals = liftM2 (,) (readIORef v_PersistentLinkerState) (readIORef v_InitLinkerDone) + +restoreLinkerGlobals :: (MVar PersistentLinkerState, Bool) -> IO () +restoreLinkerGlobals (pls, ild) = do + writeIORef v_PersistentLinkerState pls + writeIORef v_InitLinkerDone ild +\end{code}
\ No newline at end of file diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index c542d761f0..307f6f104a 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -85,7 +85,10 @@ module StaticFlags ( opt_Ticky, -- For the parser - addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready + addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready, + + -- Saving/restoring globals + saveStaticFlagGlobals, restoreStaticFlagGlobals ) where #include "HsVersions.h" @@ -96,6 +99,7 @@ import Util import Maybes ( firstJusts, catMaybes ) import Panic +import Control.Monad ( liftM3 ) import Data.Maybe ( listToMaybe ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) @@ -562,3 +566,21 @@ way_details = [ "-XParr" , "-fvectorise"] ] + +----------------------------------------------------------------------------- +-- Tunneling our global variables into a new instance of the GHC library + +-- Ignore the v_Ld_inputs global because: +-- a) It is mutated even once GHC has been initialised, which means that I'd +-- have to add another layer of indirection to truly share the value +-- b) We can get away without sharing it because it only affects the link, +-- and is mutated by the GHC exe. Users who load up a new copy of the GHC +-- library while another is running almost certainly won't actually access it. +saveStaticFlagGlobals :: IO (Bool, [String], [Way]) +saveStaticFlagGlobals = liftM3 (,,) (readIORef v_opt_C_ready) (readIORef v_opt_C) (readIORef v_Ways) + +restoreStaticFlagGlobals :: (Bool, [String], [Way]) -> IO () +restoreStaticFlagGlobals (c_ready, c, ways) = do + writeIORef v_opt_C_ready c_ready + writeIORef v_opt_C c + writeIORef v_Ways ways diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index d03d2c4f37..8b4b4e382e 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -35,6 +35,9 @@ module CoreMonad ( liftIO, liftIOWithCount, liftIO1, liftIO2, liftIO3, liftIO4, + -- ** Global initialization + reinitializeGlobals, + -- ** Dealing with annotations getAnnotations, getFirstAnnotations, @@ -96,8 +99,16 @@ import Control.Monad import Prelude hiding ( read ) #ifdef GHCI +import Control.Concurrent.MVar (MVar) +import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) import qualified Language.Haskell.TH as TH +#else +saveLinkerGlobals :: IO () +saveLinkerGlobals = return () + +restoreLinkerGlobals :: () -> IO () +restoreLinkerGlobals () = return () #endif \end{code} @@ -688,7 +699,13 @@ newtype CoreState = CoreState { data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, - cr_module :: Module + cr_module :: Module, + cr_globals :: ((Bool, [String], [Way]), +#ifdef GHCI + (MVar PersistentLinkerState, Bool)) +#else + ()) +#endif } data CoreWriter = CoreWriter { @@ -746,13 +763,15 @@ runCoreM :: HscEnv -> Module -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base us mod m = - liftM extract $ runIOEnv reader $ unCoreM m state +runCoreM hsc_env rule_base us mod m = do + glbls <- liftM2 (,) saveStaticFlagGlobals saveLinkerGlobals + liftM extract $ runIOEnv (reader glbls) $ unCoreM m state where - reader = CoreReader { + reader glbls = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, - cr_module = mod + cr_module = mod, + cr_globals = glbls } state = CoreState { cs_uniq_supply = us @@ -841,6 +860,49 @@ getOrigNameCache = do liftIO $ fmap nsNames $ readIORef nameCacheRef \end{code} +%************************************************************************ +%* * + Initializing globals +%* * +%************************************************************************ + +This is a rather annoying function. When a plugin is loaded, it currently +gets linked against a *newly loaded* copy of the GHC package. This would +not be a problem, except that the new copy has its own mutable state +that is not shared with that state that has already been initialized by +the original GHC package. + +This leads to loaded plugins calling GHC code which pokes the static flags, +and then dying with a panic because the static flags *it* sees are uninitialized. + +There are two possible solutions: + 1. Export the symbols from the GHC executable from the GHC library and link + against this existing copy rather than a new copy of the GHC library + 2. Carefully ensure that the global state in the two copies of the GHC + library matches + +I tried 1. and it *almost* works (and speeds up plugin load times!) except +on Windows. On Windows the GHC library tends to export more than 65536 symbols +(see #5292) which overflows the limit of what we can export from the EXE and +causes breakage. + +(Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem, +because we could share the GHC library it links to.) + +We are going to try 2. instead. Unfortunately, this means that every plugin +will have to say `reinitializeGlobals` before it does anything, but never mind. + +I've threaded the cr_globals through CoreM rather than giving them as an +argument to the plugin function so that we can turn this function into +(return ()) without breaking any plugins when we eventually get 1. working. + +\begin{code} +reinitializeGlobals :: CoreM () +reinitializeGlobals = do + (sf_globals, linker_globals) <- read cr_globals + liftIO $ restoreStaticFlagGlobals sf_globals + liftIO $ restoreLinkerGlobals linker_globals +\end{code} %************************************************************************ %* * diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index ea46b28334..c5f1c0c2ed 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -74,7 +74,7 @@ module Util ( doesDirNameExist, modificationTimeIfExists, - global, consIORef, globalMVar, globalEmptyMVar, + global, consIORef, globalM, -- * Filenames and paths Suffix, @@ -99,7 +99,6 @@ import Data.Data import Data.IORef ( IORef, newIORef, atomicModifyIORef ) import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) -import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar ) #ifdef DEBUG import FastTypes @@ -857,11 +856,8 @@ consIORef var x = do \end{code} \begin{code} -globalMVar :: a -> MVar a -globalMVar a = unsafePerformIO (newMVar a) - -globalEmptyMVar :: MVar a -globalEmptyMVar = unsafePerformIO newEmptyMVar +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) \end{code} Module names: |