From 59862080d2abe6fa0f8f0e3e46391f54d4f76e84 Mon Sep 17 00:00:00 2001
From: Max Bolingbroke <batterseapower@hotmail.com>
Date: Fri, 29 Jul 2011 12:05:46 +0100
Subject: [PATCH] Add CoreMonad.reinitializeGlobals so plugins can work around
linker issues
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.
---
compiler/HsVersions.h | 14 +++----
compiler/ghci/Linker.lhs | 56 ++++++++++++++++++-------
compiler/main/StaticFlags.hs | 24 ++++++++++-
compiler/simplCore/CoreMonad.lhs | 72 +++++++++++++++++++++++++++++---
compiler/utils/Util.lhs | 10 ++---
5 files changed, 142 insertions(+), 34 deletions(-)
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h
index 303d2bdc652b..b6f92ae2e71b 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 8b56c4f3aec2..9d3a3f7361e6 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 c542d761f091..307f6f104a51 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 7a0f41e32442..347200d769ad 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -37,6 +37,9 @@ module CoreMonad (
liftIO, liftIOWithCount,
liftIO1, liftIO2, liftIO3, liftIO4,
+ -- ** Global initialization
+ reinitializeGlobals,
+
-- ** Dealing with annotations
getAnnotations, getFirstAnnotations,
@@ -98,8 +101,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}
@@ -704,7 +715,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 {
@@ -762,13 +779,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
@@ -857,6 +876,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 ea46b28334d2..c5f1c0c2ed6b 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:
--
GitLab