diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/HsVersions.h | 16 | ||||
-rw-r--r-- | compiler/ghci/Linker.hs | 44 | ||||
-rw-r--r-- | compiler/main/DynFlags.hs | 15 | ||||
-rw-r--r-- | compiler/main/StaticFlags.hs | 20 | ||||
-rw-r--r-- | compiler/simplCore/CoreMonad.hs | 75 | ||||
-rw-r--r-- | compiler/utils/FastString.hs | 7 | ||||
-rw-r--r-- | compiler/utils/Util.hs | 34 |
7 files changed, 100 insertions, 111 deletions
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h index 4a0b04ad70..83cbcf15cb 100644 --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -32,22 +32,6 @@ name = Util.global (value); name :: IORef (ty); \ name = Util.globalM (value); - -#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.sharedGlobal (value) (accessor); \ -foreign import ccall unsafe saccessor \ - accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); - -#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.sharedGlobalM (value) (accessor); \ -foreign import ccall unsafe saccessor \ - accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); - - #define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else #define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else #define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 7379c46772..4a0b62f904 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} {-# OPTIONS_GHC -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - -- -- (c) The University of Glasgow 2002-2006 -- + +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + -- | The dynamic linker for GHCi. -- -- This module deals with the top-level issues of dynamic linking, @@ -15,7 +16,10 @@ module Linker ( getHValue, showLinkerState, extendLinkEnv, deleteFromLinkEnv, extendLoadedPkgs, linkPackages,initDynLinker,linkModule, - linkCmdLineLibs + linkCmdLineLibs, + + -- Saving/restoring globals + PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) where #include "HsVersions.h" @@ -62,11 +66,6 @@ import System.Directory import Exception -#if __GLASGOW_HASKELL__ >= 709 -import Foreign -#else -import Foreign.Safe -#endif {- ********************************************************************** @@ -85,22 +84,9 @@ 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. -} -#if STAGE < 2 + 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 -#else -SHARED_GLOBAL_VAR_M( v_PersistentLinkerState - , getOrSetLibHSghcPersistentLinkerState - , "getOrSetLibHSghcPersistentLinkerState" - , newMVar (panic "Dynamic linker not initialised") - , MVar PersistentLinkerState) --- Set True when dynamic linker is initialised -SHARED_GLOBAL_VAR( v_InitLinkerDone - , getOrSetLibHSghcInitLinkerDone - , "getOrSetLibHSghcInitLinkerDone" - , False - , Bool) -#endif modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f @@ -1442,3 +1428,17 @@ maybePutStr dflags s maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") + +{- ********************************************************************** + + Tunneling global variables into new instance of GHC library + + ********************************************************************* -} + +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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index c35834f935..f56ec63ead 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -232,13 +232,6 @@ import qualified Data.IntSet as IntSet import GHC.Foreign (withCString, peekCString) import qualified GHC.LanguageExtensions as LangExt -#if __GLASGOW_HASKELL__ >= 709 -import Foreign -#else -import Foreign.Safe -#endif - - -- Note [Updating flag description in the User's Guide] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -5144,15 +5137,7 @@ defaultGlobalDynFlags = where settings = panic "v_unsafeGlobalDynFlags: not initialised" -#if STAGE < 2 GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) -#else -SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags - , getOrSetLibHSghcGlobalDynFlags - , "getOrSetLibHSghcGlobalDynFlags" - , defaultGlobalDynFlags - , DynFlags ) -#endif unsafeGlobalDynFlags :: DynFlags unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index af8f4e64d4..a89f3c54ab 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -48,12 +48,6 @@ import Control.Monad import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) -#if __GLASGOW_HASKELL__ >= 709 -import Foreign -#else -import Foreign.Safe -#endif - ----------------------------------------------------------------------------- -- Static flags @@ -97,21 +91,9 @@ parseStaticFlagsFull flagsAvailable args = do -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. -#if STAGE < 2 GLOBAL_VAR(v_opt_C, [], [String]) GLOBAL_VAR(v_opt_C_ready, False, Bool) -#else -SHARED_GLOBAL_VAR( v_opt_C - , getOrSetLibHSghcStaticOptions - , "getOrSetLibHSghcStaticOptions" - , [] - , [String]) -SHARED_GLOBAL_VAR( v_opt_C_ready - , getOrSetLibHSghcStaticOptionsReady - , "getOrSetLibHSghcStaticOptionsReady" - , False - , Bool) -#endif + staticFlags :: [String] staticFlags = unsafePerformIO $ do diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 0667675d7e..314d0945d5 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -95,8 +95,16 @@ import Control.Applicative ( Alternative(..) ) 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 {- @@ -501,7 +509,12 @@ data CoreReader = CoreReader { cr_print_unqual :: PrintUnqualified, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file - cr_visible_orphan_mods :: !ModuleSet + cr_visible_orphan_mods :: !ModuleSet, +#ifdef GHCI + cr_globals :: (MVar PersistentLinkerState, Bool) +#else + cr_globals :: () +#endif } -- Note: CoreWriter used to be defined with data, rather than newtype. If it @@ -573,13 +586,15 @@ runCoreM :: HscEnv -> CoreM a -> IO (a, SimplCount) runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m - = liftM extract $ runIOEnv reader $ unCoreM m state + = do { glbls <- 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_visible_orphan_mods = orph_imps, + cr_globals = glbls, cr_print_unqual = print_unqual, cr_loc = loc } @@ -675,9 +690,59 @@ getPackageFamInstEnv = do eps <- liftIO $ hscEPS hsc_env return $ eps_fam_inst_env eps -{-# DEPRECATED reinitializeGlobals "reinitializing globals is now a no-op." #-} +{- +************************************************************************ +* * + 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. + +(NB This mechanism is sufficient for granting plugins read-only access to +globals that are guaranteed to be initialized before the plugin is loaded. If +any further synchronization is necessary, I would suggest using the more +sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to +share a single instance of the global variable among the compiler and the +plugins. Perhaps we should migrate all global variables to use that mechanism, +for robustness... -- NSF July 2013) + +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 executable 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. +-} + reinitializeGlobals :: CoreM () -reinitializeGlobals = return () +reinitializeGlobals = do + linker_globals <- read cr_globals + hsc_env <- getHscEnv + let dflags = hsc_dflags hsc_env + liftIO $ restoreLinkerGlobals linker_globals + liftIO $ setUnsafeGlobalDynFlags dflags {- ************************************************************************ diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs index 8f76584875..1496a8686e 100644 --- a/compiler/utils/FastString.hs +++ b/compiler/utils/FastString.hs @@ -285,6 +285,13 @@ originally assigned to those FastStrings. Thus the lookup fails since the domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's unique. +The old `reinitializeGlobals` mechanism is enough to provide the plugin with +read-access to the table, but it insufficient in the general case where the +plugin may allocate FastStrings. This mutates the supply for the FastStrings' +unique, and that needs to be propagated back to the compiler's instance of the +global variable. Such propagation is beyond the `reinitializeGlobals` +mechanism. + Maintaining synchronization of the two instances of this global is rather difficult because of the uses of `unsafePerformIO` in this module. Not synchronizing them risks breaking the rather major invariant that two diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 88b5090f0a..3104c747a1 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -104,7 +104,6 @@ module Util ( hSetTranslit, global, consIORef, globalM, - sharedGlobal, sharedGlobalM, -- * Filenames and paths Suffix, @@ -145,7 +144,6 @@ import qualified GHC.Stack import Control.Applicative ( liftA2 ) import Control.Monad ( liftM ) import GHC.IO.Encoding (mkTextEncoding, textEncodingName) -import GHC.Conc.Sync ( sharedCAF ) import System.IO (Handle, hGetEncoding, hSetEncoding) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime ) @@ -932,28 +930,6 @@ seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x `seq` seqList xs b - -{- -************************************************************************ -* * - Globals and the RTS -* * -************************************************************************ - -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. - -(Note that if the GHC executable was dynamically linked this -wouldn't be a problem, because we could share the GHC library it -links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) - -The solution is to make use of @sharedCAF@ through @sharedGlobal@ -for globals that are shared between multiple copies of ghc packages. --} - -- Global variables: global :: a -> IORef a @@ -966,16 +942,6 @@ consIORef var x = do globalM :: IO a -> IORef a globalM ma = unsafePerformIO (ma >>= newIORef) --- Shared global variables: - -sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobal a get_or_set = unsafePerformIO $ - newIORef a >>= flip sharedCAF get_or_set - -sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobalM ma get_or_set = unsafePerformIO $ - ma >>= newIORef >>= flip sharedCAF get_or_set - -- Module names: looksLikeModuleName :: String -> Bool |