Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
df3f5880
Commit
df3f5880
authored
Sep 24, 2020
by
Sylvain Henry
Committed by
Marge Bot
Sep 30, 2020
Browse files
Remove unsafeGlobalDynFlags (
#17957
,
#14597
)
There are still global variables but only 3 booleans instead of a single DynFlags.
parent
6527fc57
Changes
17
Hide whitespace changes
Inline
Side-by-side
compiler/GHC/Core/Unfold.hs
View file @
df3f5880
...
...
@@ -1156,7 +1156,8 @@ tryUnfolding dflags id lone_variable
,
extra_doc
,
text
"ANSWER ="
<+>
if
yes_or_no
then
text
"YES"
else
text
"NO"
]
str
=
"Considering inlining: "
++
showSDocDump
dflags
(
ppr
id
)
ctx
=
initSDocContext
dflags
defaultDumpStyle
str
=
"Considering inlining: "
++
showSDocDump
ctx
(
ppr
id
)
n_val_args
=
length
arg_infos
-- some_benefit is used when the RHS is small enough
...
...
compiler/GHC/Driver/Ppr.hs
View file @
df3f5880
...
...
@@ -29,6 +29,7 @@ import GHC.Utils.Exception
import
GHC.Utils.Misc
import
GHC.Utils.Outputable
import
GHC.Utils.Panic
import
GHC.Utils.GlobalVars
import
GHC.Utils.Ppr
(
Mode
(
..
)
)
import
{-#
SOURCE
#-
}
GHC
.
Unit
.
State
...
...
@@ -43,7 +44,7 @@ showPpr :: Outputable a => DynFlags -> a -> String
showPpr
dflags
thing
=
showSDoc
dflags
(
ppr
thing
)
showPprUnsafe
::
Outputable
a
=>
a
->
String
showPprUnsafe
a
=
showPpr
unsafeGlobalDynFlags
a
showPprUnsafe
a
=
renderWithContext
defaultSDocContext
(
ppr
a
)
-- | Allows caller to specify the PrintUnqualified to use
showSDocForUser
::
DynFlags
->
PrintUnqualified
->
SDoc
->
String
...
...
@@ -53,8 +54,8 @@ showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags st
unit_state
=
unitState
dflags
doc'
=
pprWithUnitState
unit_state
doc
showSDocDump
::
DynFlags
->
SDoc
->
String
showSDocDump
dflags
d
=
renderWithContext
(
initSDocContext
dflags
defaultDumpStyle
)
d
showSDocDump
::
SDocContext
->
SDoc
->
String
showSDocDump
ctx
d
=
renderWithContext
ctx
(
withPprStyle
defaultDumpStyle
d
)
showSDocDebug
::
DynFlags
->
SDoc
->
String
showSDocDebug
dflags
d
=
renderWithContext
ctx
d
...
...
@@ -75,9 +76,9 @@ printForC dflags handle doc =
printSDocLn
ctx
LeftMode
handle
doc
where
ctx
=
initSDocContext
dflags
(
PprCode
CStyle
)
pprDebugAndThen
::
DynFlags
->
(
String
->
a
)
->
SDoc
->
SDoc
->
a
pprDebugAndThen
dflags
cont
heading
pretty_msg
=
cont
(
showSDocDump
dflags
doc
)
pprDebugAndThen
::
SDocContext
->
(
String
->
a
)
->
SDoc
->
SDoc
->
a
pprDebugAndThen
ctx
cont
heading
pretty_msg
=
cont
(
showSDocDump
ctx
doc
)
where
doc
=
sep
[
heading
,
nest
2
pretty_msg
]
...
...
@@ -85,19 +86,22 @@ pprDebugAndThen dflags cont heading pretty_msg
pprTraceWithFlags
::
DynFlags
->
String
->
SDoc
->
a
->
a
pprTraceWithFlags
dflags
str
doc
x
|
hasNoDebugOutput
dflags
=
x
|
otherwise
=
pprDebugAndThen
dflags
trace
(
text
str
)
doc
x
|
otherwise
=
pprDebugAndThen
(
initSDocContext
dflags
defaultDumpStyle
)
trace
(
text
str
)
doc
x
-- | If debug output is on, show some 'SDoc' on the screen
pprTrace
::
String
->
SDoc
->
a
->
a
pprTrace
str
doc
x
=
pprTraceWithFlags
unsafeGlobalDynFlags
str
doc
x
pprTrace
str
doc
x
|
unsafeHasNoDebugOutput
=
x
|
otherwise
=
pprDebugAndThen
defaultSDocContext
trace
(
text
str
)
doc
x
pprTraceM
::
Applicative
f
=>
String
->
SDoc
->
f
()
pprTraceM
str
doc
=
pprTrace
str
doc
(
pure
()
)
pprTraceDebug
::
String
->
SDoc
->
a
->
a
pprTraceDebug
str
doc
x
|
debugIsOn
&&
h
asPprDebug
unsafeGlobalDynFlags
=
pprTrace
str
doc
x
|
otherwise
=
x
|
debugIsOn
&&
unsafeH
asPprDebug
=
pprTrace
str
doc
x
|
otherwise
=
x
-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.
-- This allows you to print details from the returned value as well as from
...
...
@@ -114,7 +118,7 @@ pprTraceIt desc x = pprTraceWith desc ppr x
pprTraceException
::
ExceptionMonad
m
=>
String
->
SDoc
->
m
a
->
m
a
pprTraceException
heading
doc
=
handleGhcException
$
\
exc
->
liftIO
$
do
putStrLn
$
showSDocDump
unsafeGlobalDynFlags
(
sep
[
text
heading
,
nest
2
doc
])
putStrLn
$
showSDocDump
defaultSDocContext
(
sep
[
text
heading
,
nest
2
doc
])
throwGhcExceptionIO
exc
-- | If debug output is on, show some 'SDoc' on the screen along
...
...
@@ -127,10 +131,10 @@ warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a
-- Should typically be accessed with the WARN macros
warnPprTrace
_
_
_
_
x
|
not
debugIsOn
=
x
warnPprTrace
_
_file
_line
_msg
x
|
h
asNoDebugOutput
unsafeGlobalDynFlags
=
x
|
unsafeH
asNoDebugOutput
=
x
warnPprTrace
False
_file
_line
_msg
x
=
x
warnPprTrace
True
file
line
msg
x
=
pprDebugAndThen
unsafeGlobalDynFlags
trace
heading
=
pprDebugAndThen
defaultSDocContext
trace
heading
(
msg
$$
callStackDoc
)
x
where
...
...
compiler/GHC/Driver/Session.hs
View file @
df3f5880
...
...
@@ -15,8 +15,6 @@
--
-------------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module
GHC.Driver.Session
(
...
...
@@ -199,7 +197,7 @@ module GHC.Driver.Session (
wordAlignment
,
unsafeGlobalDynFlags
,
setUnsafeGlobalDynFlags
,
setUnsafeGlobalDynFlags
,
-- * SSE and AVX
isSseEnabled
,
...
...
@@ -256,6 +254,7 @@ import GHC.Settings.Constants
import
GHC.Utils.Panic
import
qualified
GHC.Utils.Ppr.Colour
as
Col
import
GHC.Utils.Misc
import
GHC.Utils.GlobalVars
import
GHC.Data.Maybe
import
GHC.Utils.Monad
import
qualified
GHC.Utils.Ppr
as
Pretty
...
...
@@ -275,7 +274,6 @@ import GHC.Utils.Json
import
GHC.SysTools.Terminal
(
stderrSupportsAnsiColors
)
import
GHC.SysTools.BaseDir
(
expandToolDir
,
expandTopDir
)
import
System.IO.Unsafe
(
unsafePerformIO
)
import
Data.IORef
import
Control.Arrow
((
&&&
))
import
Control.Monad
...
...
@@ -305,11 +303,6 @@ import qualified GHC.Data.EnumSet as EnumSet
import
GHC.Foreign
(
withCString
,
peekCString
)
import
qualified
GHC.LanguageExtensions
as
LangExt
#
if
GHC_STAGE
>=
2
-- used by SHARED_GLOBAL_VAR
import
Foreign
(
Ptr
)
#
endif
-- Note [Updating flag description in the User's Guide]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
...
...
@@ -4892,40 +4885,12 @@ makeDynFlagsConsistent dflags
os
=
platformOS
platform
--------------------------------------------------------------------------
-- Do not use unsafeGlobalDynFlags!
--
-- unsafeGlobalDynFlags is a hack, necessary because we need to be able
-- to show SDocs when tracing, but we don't always have DynFlags
-- available.
--
-- Do not use it if you can help it. You may get the wrong value, or this
-- panic!
-- | This is the value that 'unsafeGlobalDynFlags' takes before it is
-- initialized.
defaultGlobalDynFlags
::
DynFlags
defaultGlobalDynFlags
=
(
defaultDynFlags
settings
llvmConfig
)
{
verbosity
=
2
}
where
settings
=
panic
"v_unsafeGlobalDynFlags: settings not initialised"
llvmConfig
=
panic
"v_unsafeGlobalDynFlags: llvmConfig not initialised"
#
if
GHC_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
setUnsafeGlobalDynFlags
::
DynFlags
->
IO
()
setUnsafeGlobalDynFlags
=
writeIORef
v_unsafeGlobalDynFlags
setUnsafeGlobalDynFlags
dflags
=
do
writeIORef
v_unsafeHasPprDebug
(
hasPprDebug
dflags
)
writeIORef
v_unsafeHasNoDebugOutput
(
hasNoDebugOutput
dflags
)
writeIORef
v_unsafeHasNoStateHack
(
hasNoStateHack
dflags
)
-- -----------------------------------------------------------------------------
-- SSE and AVX
...
...
compiler/GHC/Driver/Session.hs-boot
View file @
df3f5880
...
...
@@ -9,7 +9,6 @@ data DynFlags
targetPlatform
::
DynFlags
->
Platform
unitState
::
DynFlags
->
UnitState
unsafeGlobalDynFlags
::
DynFlags
hasPprDebug
::
DynFlags
->
Bool
hasNoDebugOutput
::
DynFlags
->
Bool
initSDocContext
::
DynFlags
->
PprStyle
->
SDocContext
compiler/GHC/StgToCmm/Bind.hs
View file @
df3f5880
...
...
@@ -755,14 +755,15 @@ link_caf node = do
-- name of the data constructor itself. Otherwise it is determined by
-- @closureDescription@ from the let binding information.
closureDescription
::
DynFlags
->
Module
-- Module
->
Name
-- Id of closure binding
->
String
closureDescription
::
DynFlags
->
Module
-- Module
->
Name
-- Id of closure binding
->
String
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.hs with a description generated from the data constructor
closureDescription
dflags
mod_name
name
=
showSDocDump
dflags
(
char
'<'
<>
=
showSDocDump
(
initSDocContext
dflags
defaultDumpStyle
)
(
char
'<'
<>
(
if
isExternalName
name
then
ppr
name
-- ppr will include the module name prefix
else
pprModule
mod_name
<>
char
'.'
<>
ppr
name
)
<>
...
...
compiler/GHC/Types/Id.hs
View file @
df3f5880
...
...
@@ -123,7 +123,6 @@ module GHC.Types.Id (
import
GHC.Prelude
import
GHC.Driver.Session
import
GHC.Core
(
CoreRule
,
isStableUnfolding
,
evaldUnfolding
,
isCompulsoryUnfolding
,
Unfolding
(
NoUnfolding
)
)
...
...
@@ -161,6 +160,7 @@ import GHC.Core.Multiplicity
import
GHC.Utils.Misc
import
GHC.Utils.Outputable
import
GHC.Utils.Panic
import
GHC.Utils.GlobalVars
import
GHC.Driver.Ppr
...
...
@@ -843,7 +843,7 @@ typeOneShot ty
isStateHackType
::
Type
->
Bool
isStateHackType
ty
|
h
asNoStateHack
unsafeGlobalDynFlags
|
unsafeH
asNoStateHack
=
False
|
otherwise
=
case
tyConAppTyCon_maybe
ty
of
...
...
compiler/GHC/Utils/Error.hs
View file @
df3f5880
...
...
@@ -820,13 +820,15 @@ prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors
dflags
=
MC
.
handle
$
\
e
->
case
e
of
PprPanic
str
doc
->
pprDebugAndThen
dflags
panic
(
text
str
)
doc
pprDebugAndThen
ctx
panic
(
text
str
)
doc
PprSorry
str
doc
->
pprDebugAndThen
dflags
sorry
(
text
str
)
doc
pprDebugAndThen
ctx
sorry
(
text
str
)
doc
PprProgramError
str
doc
->
pprDebugAndThen
dflags
pgmError
(
text
str
)
doc
pprDebugAndThen
ctx
pgmError
(
text
str
)
doc
_
->
liftIO
$
throwIO
e
where
ctx
=
initSDocContext
dflags
defaultUserStyle
-- | Checks if given 'WarnMsg' is a fatal warning.
isWarnMsgFatal
::
DynFlags
->
WarnMsg
->
Maybe
(
Maybe
WarningFlag
)
...
...
compiler/GHC/Utils/GlobalVars.hs
0 → 100644
View file @
df3f5880
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
module
GHC.Utils.GlobalVars
(
v_unsafeHasPprDebug
,
v_unsafeHasNoDebugOutput
,
v_unsafeHasNoStateHack
,
unsafeHasPprDebug
,
unsafeHasNoDebugOutput
,
unsafeHasNoStateHack
,
global
,
consIORef
,
globalM
,
sharedGlobal
,
sharedGlobalM
)
where
#
include
"HsVersions.h"
import
GHC.Prelude
import
GHC.Conc.Sync
(
sharedCAF
)
import
System.IO.Unsafe
import
Data.IORef
import
Foreign
(
Ptr
)
--------------------------------------------------------------------------
-- Do not use global variables!
--
-- Global variables are a hack. Do not use them if you can help it.
#
if
GHC_STAGE
<
2
GLOBAL_VAR
(
v_unsafeHasPprDebug
,
False
,
Bool
)
GLOBAL_VAR
(
v_unsafeHasNoDebugOutput
,
False
,
Bool
)
GLOBAL_VAR
(
v_unsafeHasNoStateHack
,
False
,
Bool
)
#
else
SHARED_GLOBAL_VAR
(
v_unsafeHasPprDebug
,
getOrSetLibHSghcGlobalHasPprDebug
,
"getOrSetLibHSghcGlobalHasPprDebug"
,
False
,
Bool
)
SHARED_GLOBAL_VAR
(
v_unsafeHasNoDebugOutput
,
getOrSetLibHSghcGlobalHasNoDebugOutput
,
"getOrSetLibHSghcGlobalHasNoDebugOutput"
,
False
,
Bool
)
SHARED_GLOBAL_VAR
(
v_unsafeHasNoStateHack
,
getOrSetLibHSghcGlobalHasNoStateHack
,
"getOrSetLibHSghcGlobalHasNoStateHack"
,
False
,
Bool
)
#
endif
unsafeHasPprDebug
::
Bool
unsafeHasPprDebug
=
unsafePerformIO
$
readIORef
v_unsafeHasPprDebug
unsafeHasNoDebugOutput
::
Bool
unsafeHasNoDebugOutput
=
unsafePerformIO
$
readIORef
v_unsafeHasNoDebugOutput
unsafeHasNoStateHack
::
Bool
unsafeHasNoStateHack
=
unsafePerformIO
$
readIORef
v_unsafeHasNoStateHack
{-
************************************************************************
* *
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
global
a
=
unsafePerformIO
(
newIORef
a
)
consIORef
::
IORef
[
a
]
->
a
->
IO
()
consIORef
var
x
=
do
atomicModifyIORef'
var
(
\
xs
->
(
x
:
xs
,
()
))
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
compiler/GHC/Utils/Misc.hs
View file @
df3f5880
...
...
@@ -107,9 +107,6 @@ module GHC.Utils.Misc (
modificationTimeIfExists
,
withAtomicRename
,
global
,
consIORef
,
globalM
,
sharedGlobal
,
sharedGlobalM
,
-- * Filenames and paths
Suffix
,
splitLongestPrefix
,
...
...
@@ -143,8 +140,6 @@ import GHC.Utils.Exception
import
GHC.Utils.Panic.Plain
import
Data.Data
import
Data.IORef
(
IORef
,
newIORef
,
atomicModifyIORef'
)
import
System.IO.Unsafe
(
unsafePerformIO
)
import
Data.List
hiding
(
group
)
import
Data.List.NonEmpty
(
NonEmpty
(
..
)
)
...
...
@@ -154,7 +149,6 @@ import GHC.Stack (HasCallStack)
import
Control.Applicative
(
liftA2
)
import
Control.Monad
(
liftM
,
guard
)
import
Control.Monad.IO.Class
(
MonadIO
,
liftIO
)
import
GHC.Conc.Sync
(
sharedCAF
)
import
System.IO.Error
as
IO
(
isDoesNotExistError
)
import
System.Directory
(
doesDirectoryExist
,
getModificationTime
,
renameFile
)
import
System.FilePath
...
...
@@ -1070,48 +1064,6 @@ strictMap f (x : xs) =
in
x'
:
xs'
{-
************************************************************************
* *
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
global
a
=
unsafePerformIO
(
newIORef
a
)
consIORef
::
IORef
[
a
]
->
a
->
IO
()
consIORef
var
x
=
do
atomicModifyIORef'
var
(
\
xs
->
(
x
:
xs
,
()
))
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:
...
...
compiler/GHC/Utils/Panic.hs
View file @
df3f5880
...
...
@@ -47,8 +47,6 @@ import GHC.Prelude
import
GHC.Stack
import
GHC.Utils.Outputable
import
{-#
SOURCE
#-
}
GHC
.
Driver
.
Session
(
DynFlags
,
unsafeGlobalDynFlags
)
import
{-#
SOURCE
#-
}
GHC
.
Driver
.
Ppr
(
showSDoc
)
import
GHC.Utils.Panic.Plain
import
GHC.Utils.Exception
as
Exception
...
...
@@ -146,16 +144,14 @@ safeShowException e = do
-- | Append a description of the given exception to this string.
--
-- Note that this uses 'GHC.Driver.Session.unsafeGlobalDynFlags', which may have some
-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called.
-- If the error message to be printed includes a pretty-printer document
-- which forces one of these fields this call may bottom.
-- Note that this uses 'defaultSDocContext', which doesn't use the options
-- set by the user via DynFlags.
showGhcExceptionUnsafe
::
GhcException
->
ShowS
showGhcExceptionUnsafe
=
showGhcException
unsafeGlobalDynFlags
showGhcExceptionUnsafe
=
showGhcException
defaultSDocContext
-- | Append a description of the given exception to this string.
showGhcException
::
DynFlags
->
GhcException
->
ShowS
showGhcException
dflags
=
showPlainGhcException
.
\
case
showGhcException
::
SDocContext
->
GhcException
->
ShowS
showGhcException
ctx
=
showPlainGhcException
.
\
case
Signal
n
->
PlainSignal
n
UsageError
str
->
PlainUsageError
str
CmdLineError
str
->
PlainCmdLineError
str
...
...
@@ -165,11 +161,11 @@ showGhcException dflags = showPlainGhcException . \case
ProgramError
str
->
PlainProgramError
str
PprPanic
str
sdoc
->
PlainPanic
$
concat
[
str
,
"
\n\n
"
,
showSDoc
dflags
sdoc
]
concat
[
str
,
"
\n\n
"
,
renderWithContext
ctx
sdoc
]
PprSorry
str
sdoc
->
PlainProgramError
$
concat
[
str
,
"
\n\n
"
,
showSDoc
dflags
sdoc
]
concat
[
str
,
"
\n\n
"
,
renderWithContext
ctx
sdoc
]
PprProgramError
str
sdoc
->
PlainProgramError
$
concat
[
str
,
"
\n\n
"
,
showSDoc
dflags
sdoc
]
concat
[
str
,
"
\n\n
"
,
renderWithContext
ctx
sdoc
]
throwGhcException
::
GhcException
->
a
throwGhcException
=
Exception
.
throw
...
...
compiler/HsVersions.h
View file @
df3f5880
...
...
@@ -15,25 +15,25 @@ you will screw up the layout where they are used in case expressions!
#define GLOBAL_VAR(name,value,ty) \
{-# NOINLINE name #-}; \
name :: IORef (ty); \
name = GHC.Utils.
Misc
.global (value);
name = GHC.Utils.
GlobalVars
.global (value);
#define GLOBAL_VAR_M(name,value,ty) \
{-# NOINLINE name #-}; \
name :: IORef (ty); \
name = GHC.Utils.
Misc
.globalM (value);
name = GHC.Utils.
GlobalVars
.globalM (value);
#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \
{-# NOINLINE name #-}; \
name :: IORef (ty); \
name = GHC.Utils.
Misc
.sharedGlobal (value) (accessor);
\
name = GHC.Utils.
GlobalVars
.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 = GHC.Utils.
Misc
.sharedGlobalM (value) (accessor);
\
name = GHC.Utils.
GlobalVars
.sharedGlobalM (value) (accessor); \
foreign import ccall unsafe saccessor \
accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));
...
...
compiler/ghc.cabal.in
View file @
df3f5880
...
...
@@ -177,6 +177,7 @@ Library
GHC.Types.Cpr
GHC.Cmm.DebugBlock
GHC.Utils.Exception
GHC.Utils.GlobalVars
GHC.Types.FieldLabel
GHC.Driver.Monad
GHC.Driver.Hooks
...
...
includes/rts/Globals.h
View file @
df3f5880
...
...
@@ -31,6 +31,8 @@ mkStoreAccessorPrototype(SystemTimerThreadIOManagerThreadStore)
mkStoreAccessorPrototype
(
LibHSghcFastStringTable
)
mkStoreAccessorPrototype
(
LibHSghcPersistentLinkerState
)
mkStoreAccessorPrototype
(
LibHSghcInitLinkerDone
)
mkStoreAccessorPrototype
(
LibHSghcGlobalDynFlags
)
mkStoreAccessorPrototype
(
LibHSghcGlobalHasPprDebug
)
mkStoreAccessorPrototype
(
LibHSghcGlobalHasNoDebugOutput
)
mkStoreAccessorPrototype
(
LibHSghcGlobalHasNoStateHack
)
mkStoreAccessorPrototype
(
LibHSghcStaticOptions
)
mkStoreAccessorPrototype
(
LibHSghcStaticOptionsReady
)
rts/Globals.c
View file @
df3f5880
...
...
@@ -35,7 +35,9 @@ typedef enum {
LibHSghcFastStringTable
,
LibHSghcPersistentLinkerState
,
LibHSghcInitLinkerDone
,
LibHSghcGlobalDynFlags
,
LibHSghcGlobalHasPprDebug
,
LibHSghcGlobalHasNoDebugOutput
,
LibHSghcGlobalHasNoStateHack
,
LibHSghcStaticOptions
,
LibHSghcStaticOptionsReady
,
MaxStoreKey
...
...
@@ -108,6 +110,8 @@ mkStoreAccessor(SystemTimerThreadIOManagerThreadStore)
mkStoreAccessor
(
LibHSghcFastStringTable
)
mkStoreAccessor
(
LibHSghcPersistentLinkerState
)
mkStoreAccessor
(
LibHSghcInitLinkerDone
)
mkStoreAccessor
(
LibHSghcGlobalDynFlags
)
mkStoreAccessor
(
LibHSghcGlobalHasPprDebug
)
mkStoreAccessor
(
LibHSghcGlobalHasNoDebugOutput
)
mkStoreAccessor
(
LibHSghcGlobalHasNoStateHack
)
mkStoreAccessor
(
LibHSghcStaticOptions
)
mkStoreAccessor
(
LibHSghcStaticOptionsReady
)
rts/RtsSymbols.c
View file @
df3f5880
...
...
@@ -644,7 +644,9 @@
SymI_HasProto(getRTSStatsEnabled) \
SymI_HasProto(getOrSetLibHSghcPersistentLinkerState) \
SymI_HasProto(getOrSetLibHSghcInitLinkerDone) \
SymI_HasProto(getOrSetLibHSghcGlobalDynFlags) \
SymI_HasProto(getOrSetLibHSghcGlobalHasPprDebug) \
SymI_HasProto(getOrSetLibHSghcGlobalHasNoDebugOutput) \
SymI_HasProto(getOrSetLibHSghcGlobalHasNoStateHack) \
SymI_HasProto(genericRaise) \
SymI_HasProto(getProgArgv) \
SymI_HasProto(getFullProgArgv) \
...
...
testsuite/tests/plugins/LinkerTicklingPlugin.hs
View file @
df3f5880
...
...
@@ -2,14 +2,19 @@ module LinkerTicklingPlugin where
import
GHC.Plugins
import
GHC.Driver.Session
import
GHC.Utils.GlobalVars
plugin
::
Plugin
plugin
=
defaultPlugin
{
installCoreToDos
=
install
}
plugin
=
defaultPlugin
{
installCoreToDos
=
install
}
-- This tests whether plugins are linking against the *running* GHC or a new
-- instance of it. If it is a new instance (settings unsafeGlobalDynFlags) won't
-- have been initialised, so we'll get a GHC panic here:
install
::
[
CommandLineOption
]
->
[
CoreToDo
]
->
CoreM
[
CoreToDo
]
install
_options
todos
=
settings
unsafeGlobalDynFlags
`
seq
`
return
todos
install
_options
todos
=
io
`
seq
`
return
todos
where
io
=
if
not
unsafeHasPprDebug
then
error
"unsafePprDebug should be set: plugin linked against a different GHC?"
else
()
testsuite/tests/plugins/all.T
View file @
df3f5880
...
...
@@ -44,7 +44,7 @@ test('plugins06',
[
extra_files
(['
LinkerTicklingPlugin.hs
']),
unless
(
have_dynamic
(),
skip
),
only_ways
([
config
.
ghc_plugin_way
])],
multimod_compile_and_run
,
['
plugins06
',
'
-package ghc
'])
multimod_compile_and_run
,
['
plugins06
',
'
-package ghc
-dppr-debug
'])
test
('
plugins07
',
[
extra_files
(['
rule-defining-plugin/
']),
...
...
Write