Commit c3c70244 authored by Moritz Angermann's avatar Moritz Angermann Committed by Tamar Christina

Make globals use sharedCAF

Summary:
The use of globals is quite painful when multiple rts are loaded, e.g.
when plugins are loaded, which bring in a second rts. The sharedCAF
appraoch was employed for the FastStringTable; I've taken the libery
to extend this to the other globals I could find.

This is a reboot of D2575, that should hopefully not exhibit the same
windows build issues.

Reviewers: Phyx, simonmar, goldfire, bgamari, austin, hvr, erikd

Reviewed By: Phyx, simonmar, bgamari

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D2773
parent 490b9429
......@@ -32,6 +32,22 @@ 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)) $
......
{-# 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,
......@@ -16,10 +15,7 @@ module Linker ( getHValue, showLinkerState,
extendLinkEnv, deleteFromLinkEnv,
extendLoadedPkgs,
linkPackages,initDynLinker,linkModule,
linkCmdLineLibs,
-- Saving/restoring globals
PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals
linkCmdLineLibs
) where
#include "HsVersions.h"
......@@ -66,6 +62,11 @@ import System.Directory
import Exception
#if __GLASGOW_HASKELL__ >= 709
import Foreign
#else
import Foreign.Safe
#endif
{- **********************************************************************
......@@ -84,9 +85,22 @@ 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
......@@ -1428,17 +1442,3 @@ 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
......@@ -221,7 +221,6 @@ import System.Console.Terminfo (SetupTermError, Terminal, getCapability,
setupTermFromEnv, termColors)
import System.Posix (queryTerminal, stdError)
#elif defined mingw32_HOST_OS
import Foreign (Ptr, with, peek)
import System.Environment (lookupEnv)
import qualified Graphics.Win32 as Win32
#endif
......@@ -234,6 +233,13 @@ 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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
......@@ -5142,7 +5148,15 @@ 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
......
......@@ -48,6 +48,12 @@ import Control.Monad
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
#if __GLASGOW_HASKELL__ >= 709
import Foreign
#else
import Foreign.Safe
#endif
-----------------------------------------------------------------------------
-- Static flags
......@@ -91,9 +97,21 @@ 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
......
......@@ -95,16 +95,8 @@ 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
{-
......@@ -509,12 +501,7 @@ 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,
#ifdef GHCI
cr_globals :: (MVar PersistentLinkerState, Bool)
#else
cr_globals :: ()
#endif
cr_visible_orphan_mods :: !ModuleSet
}
-- Note: CoreWriter used to be defined with data, rather than newtype. If it
......@@ -586,15 +573,13 @@ runCoreM :: HscEnv
-> CoreM a
-> IO (a, SimplCount)
runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
= do { glbls <- saveLinkerGlobals
; liftM extract $ runIOEnv (reader glbls) $ unCoreM m state }
= liftM extract $ runIOEnv reader $ unCoreM m state
where
reader glbls = CoreReader {
reader = 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
}
......@@ -690,59 +675,9 @@ getPackageFamInstEnv = do
eps <- liftIO $ hscEPS hsc_env
return $ eps_fam_inst_env eps
{-
************************************************************************
* *
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.
-}
{-# DEPRECATED reinitializeGlobals "It is not necessary to call reinitializeGlobals. Since GHC 8.2, this function is a no-op and will be removed in GHC 8.4" #-}
reinitializeGlobals :: CoreM ()
reinitializeGlobals = do
linker_globals <- read cr_globals
hsc_env <- getHscEnv
let dflags = hsc_dflags hsc_env
liftIO $ restoreLinkerGlobals linker_globals
liftIO $ setUnsafeGlobalDynFlags dflags
reinitializeGlobals = return ()
{-
************************************************************************
......
......@@ -285,13 +285,6 @@ 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
......
......@@ -104,6 +104,7 @@ module Util (
hSetTranslit,
global, consIORef, globalM,
sharedGlobal, sharedGlobalM,
-- * Filenames and paths
Suffix,
......@@ -144,6 +145,7 @@ 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 )
......@@ -930,6 +932,28 @@ 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
......@@ -942,6 +966,16 @@ 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
......
......@@ -305,7 +305,6 @@ just returns the original compilation pipeline, unmodified, and says
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todo = do
reinitializeGlobals
putMsgS "Hello!"
return todo
......@@ -314,16 +313,6 @@ cabal for instance,) you can then use it by just specifying
``-fplugin=DoNothing.Plugin`` on the command line, and during the
compilation you should see GHC say 'Hello'.
Note carefully the ``reinitializeGlobals`` call at the beginning of the
installation function. Due to bugs in the windows linker dealing with
``libghc``, this call is necessary to properly ensure compiler plugins
have the same global state as GHC at the time of invocation. Without
``reinitializeGlobals``, compiler plugins can crash at runtime because
they may require state that hasn't otherwise been initialized.
In the future, when the linking bugs are fixed, ``reinitializeGlobals``
will be deprecated with a warning, and changed to do nothing.
.. _core-plugins-in-more-detail:
Core plugins in more detail
......@@ -396,7 +385,6 @@ in a module it compiles:
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todo = do
reinitializeGlobals
return (CoreDoPluginPass "Say name" pass : todo)
pass :: ModGuts -> CoreM ModGuts
......@@ -446,7 +434,6 @@ will print out the name of any top-level non-recursive binding with the
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todo = do
reinitializeGlobals
return (CoreDoPluginPass "Say name" pass : todo)
pass :: ModGuts -> CoreM ModGuts
......
......@@ -17,14 +17,23 @@
#ifndef RTS_GLOBALS_H
#define RTS_GLOBALS_H
StgStablePtr getOrSetGHCConcSignalSignalHandlerStore(StgStablePtr value);
StgStablePtr getOrSetGHCConcWindowsPendingDelaysStore(StgStablePtr ptr);
StgStablePtr getOrSetGHCConcWindowsIOManagerThreadStore(StgStablePtr ptr);
StgStablePtr getOrSetGHCConcWindowsProddingStore(StgStablePtr ptr);
StgStablePtr getOrSetSystemEventThreadEventManagerStore(StgStablePtr ptr);
StgStablePtr getOrSetSystemEventThreadIOManagerThreadStore(StgStablePtr ptr);
StgStablePtr getOrSetSystemTimerThreadEventManagerStore(StgStablePtr ptr);
StgStablePtr getOrSetSystemTimerThreadIOManagerThreadStore(StgStablePtr ptr);
StgStablePtr getOrSetLibHSghcFastStringTable(StgStablePtr ptr);
#define mkStoreAccessorPrototype(name) \
StgStablePtr \
getOrSet##name(StgStablePtr ptr);
mkStoreAccessorPrototype(GHCConcSignalSignalHandlerStore)
mkStoreAccessorPrototype(GHCConcWindowsPendingDelaysStore)
mkStoreAccessorPrototype(GHCConcWindowsIOManagerThreadStore)
mkStoreAccessorPrototype(GHCConcWindowsProddingStore)
mkStoreAccessorPrototype(SystemEventThreadEventManagerStore)
mkStoreAccessorPrototype(SystemEventThreadIOManagerThreadStore)
mkStoreAccessorPrototype(SystemTimerThreadEventManagerStore)
mkStoreAccessorPrototype(SystemTimerThreadIOManagerThreadStore)
mkStoreAccessorPrototype(LibHSghcFastStringTable)
mkStoreAccessorPrototype(LibHSghcPersistentLinkerState)
mkStoreAccessorPrototype(LibHSghcInitLinkerDone)
mkStoreAccessorPrototype(LibHSghcGlobalDynFlags)
mkStoreAccessorPrototype(LibHSghcStaticOptions)
mkStoreAccessorPrototype(LibHSghcStaticOptionsReady)
#endif /* RTS_GLOBALS_H */
......@@ -856,7 +856,7 @@ modifyMVar_ m io =
-- Thread waiting
-----------------------------------------------------------------------------
-- Machinery needed to ensureb that we only have one copy of certain
-- Machinery needed to ensure that we only have one copy of certain
-- CAFs in this module even when the base package is present twice, as
-- it is when base is dynamically loaded into GHCi. The RTS keeps
-- track of the single true value of the CAF, so even when the CAFs in
......
......@@ -13,7 +13,7 @@
* dynamically loads
*
* libHSghc - a statically-linked ghc has its own copy and so will Core
* plugins it dynamically loads (cf CoreMonad.reinitializeGlobals)
* plugins it dynamically loads.
*
* ---------------------------------------------------------------------------*/
......@@ -33,6 +33,11 @@ typedef enum {
SystemTimerThreadEventManagerStore,
SystemTimerThreadIOManagerThreadStore,
LibHSghcFastStringTable,
LibHSghcPersistentLinkerState,
LibHSghcInitLinkerDone,
LibHSghcGlobalDynFlags,
LibHSghcStaticOptions,
LibHSghcStaticOptionsReady,
MaxStoreKey
} StoreKey;
......@@ -87,56 +92,22 @@ static StgStablePtr getOrSetKey(StoreKey key, StgStablePtr ptr)
return ret;
}
StgStablePtr
getOrSetGHCConcSignalSignalHandlerStore(StgStablePtr ptr)
{
return getOrSetKey(GHCConcSignalSignalHandlerStore,ptr);
}
StgStablePtr
getOrSetGHCConcWindowsPendingDelaysStore(StgStablePtr ptr)
{
return getOrSetKey(GHCConcWindowsPendingDelaysStore,ptr);
}
StgStablePtr
getOrSetGHCConcWindowsIOManagerThreadStore(StgStablePtr ptr)
{
return getOrSetKey(GHCConcWindowsIOManagerThreadStore,ptr);
}
StgStablePtr
getOrSetGHCConcWindowsProddingStore(StgStablePtr ptr)
{
return getOrSetKey(GHCConcWindowsProddingStore,ptr);
}
StgStablePtr
getOrSetSystemEventThreadEventManagerStore(StgStablePtr ptr)
{
return getOrSetKey(SystemEventThreadEventManagerStore,ptr);
}
StgStablePtr
getOrSetSystemEventThreadIOManagerThreadStore(StgStablePtr ptr)
{
return getOrSetKey(SystemEventThreadIOManagerThreadStore,ptr);
}
StgStablePtr
getOrSetSystemTimerThreadEventManagerStore(StgStablePtr ptr)
{
return getOrSetKey(SystemTimerThreadEventManagerStore,ptr);
}
StgStablePtr
getOrSetSystemTimerThreadIOManagerThreadStore(StgStablePtr ptr)
{
return getOrSetKey(SystemTimerThreadIOManagerThreadStore,ptr);
}
StgStablePtr
getOrSetLibHSghcFastStringTable(StgStablePtr ptr)
{
return getOrSetKey(LibHSghcFastStringTable,ptr);
}
#define mkStoreAccessor(name) \
StgStablePtr \
getOrSet##name(StgStablePtr ptr) \
{ return getOrSetKey(name, ptr); }
mkStoreAccessor(GHCConcSignalSignalHandlerStore)
mkStoreAccessor(GHCConcWindowsPendingDelaysStore)
mkStoreAccessor(GHCConcWindowsIOManagerThreadStore)
mkStoreAccessor(GHCConcWindowsProddingStore)
mkStoreAccessor(SystemEventThreadEventManagerStore)
mkStoreAccessor(SystemEventThreadIOManagerThreadStore)
mkStoreAccessor(SystemTimerThreadEventManagerStore)
mkStoreAccessor(SystemTimerThreadIOManagerThreadStore)
mkStoreAccessor(LibHSghcFastStringTable)
mkStoreAccessor(LibHSghcPersistentLinkerState)
mkStoreAccessor(LibHSghcInitLinkerDone)
mkStoreAccessor(LibHSghcGlobalDynFlags)
mkStoreAccessor(LibHSghcStaticOptions)
mkStoreAccessor(LibHSghcStaticOptionsReady)
......@@ -595,6 +595,11 @@
SymI_HasProto(getOrSetLibHSghcFastStringTable) \
SymI_HasProto(getRTSStats) \
SymI_HasProto(getRTSStatsEnabled) \
SymI_HasProto(getOrSetLibHSghcPersistentLinkerState) \
SymI_HasProto(getOrSetLibHSghcInitLinkerDone) \
SymI_HasProto(getOrSetLibHSghcGlobalDynFlags) \
SymI_HasProto(getOrSetLibHSghcStaticOptions) \
SymI_HasProto(getOrSetLibHSghcStaticOptionsReady) \
SymI_HasProto(genericRaise) \
SymI_HasProto(getProgArgv) \
SymI_HasProto(getFullProgArgv) \
......
......@@ -12,6 +12,4 @@ plugin = defaultPlugin {
-- or a new instance of it. If it is a new instance the staticFlags
-- won't have been initialised, so we'll get a GHC panic here:
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _options todos = reinitializeGlobals >> (length staticFlags `seq` return todos)
--- XXX: remove reinitializeGlobals when we have fixed the linker
-- problem (see comment with reinitializeGlobals in CoreMonad.hs)
install _options todos = length staticFlags `seq` return todos
......@@ -13,7 +13,6 @@ plugin = defaultPlugin {
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todo = do
reinitializeGlobals
return (CoreDoPluginPass "Say name" pass : todo)
pass :: ModGuts -> CoreM ModGuts
......
......@@ -8,7 +8,6 @@ plugin = defaultPlugin { installCoreToDos = install }
where
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todos = do
reinitializeGlobals
putMsgS "T7702Plugin"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment