Commit 32073806 authored by Ian Lynagh's avatar Ian Lynagh

Make -rtsopts more flexible

The default is a new "some" state, which allows only known-safe flags
that we want on by default. Currently this is only "--info".
parent d0fb9a95
......@@ -1513,12 +1513,16 @@ linkBinary dflags o_files dep_packages = do
let no_hs_main = dopt Opt_NoHsMain dflags
let main_lib | no_hs_main = []
| otherwise = [ "-lHSrtsmain" ]
rtsEnabledObj <- if dopt Opt_RtsOptsEnabled dflags
then do fn <- mkExtraCObj dflags
["#include \"Rts.h\"",
"const rtsBool rtsOptsEnabled = rtsTrue;"]
return [fn]
else return []
let mkRtsEnabledObj val = do fn <- mkExtraCObj dflags
["#include \"Rts.h\"",
"#include \"RtsOpts.h\"",
"const rtsOptsEnabledEnum rtsOptsEnabled = "
++ val ++ ";"]
return [fn]
rtsEnabledObj <- case rtsOptsEnabled dflags of
RtsOptsNone -> mkRtsEnabledObj "rtsOptsNone"
RtsOptsSafeOnly -> return []
RtsOptsAll -> mkRtsEnabledObj "rtsOptsAll"
rtsOptsObj <- case rtsOpts dflags of
Just opts ->
do fn <- mkExtraCObj dflags
......
......@@ -19,6 +19,7 @@ module DynFlags (
lopt_set_flattened,
lopt_unset_flattened,
DynFlags(..),
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
GhcMode(..), isOneShot,
GhcLink(..), isNoLink,
......@@ -234,7 +235,6 @@ data DynFlag
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
| Opt_NoHsMain
| Opt_RtsOptsEnabled
| Opt_SplitObjs
| Opt_StgStats
| Opt_HideAllPackages
......@@ -418,6 +418,7 @@ data DynFlags = DynFlags {
ghcUsagePath :: FilePath, -- Filled in by SysTools
ghciUsagePath :: FilePath, -- ditto
rtsOpts :: Maybe String,
rtsOptsEnabled :: RtsOptsEnabled,
hpcDir :: String, -- ^ Path to store the .mix files
......@@ -592,6 +593,8 @@ data DynLibLoader
| SystemDependent
deriving Eq
data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
-- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
initDynFlags :: DynFlags -> IO DynFlags
initDynFlags dflags = do
......@@ -662,6 +665,7 @@ defaultDynFlags =
cmdlineFrameworks = [],
tmpDir = cDEFAULT_TMPDIR,
rtsOpts = Nothing,
rtsOptsEnabled = RtsOptsSafeOnly,
hpcDir = ".hpc",
......@@ -1247,8 +1251,11 @@ dynamic_flags = [
, Flag "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) Supported
, Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) Supported
, Flag "with-rtsopts" (HasArg setRtsOpts) Supported
, Flag "rtsopts" (NoArg (setDynFlag Opt_RtsOptsEnabled)) Supported
, Flag "no-rtsopts" (NoArg (unSetDynFlag Opt_RtsOptsEnabled)) Supported
, Flag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) Supported
, Flag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) Supported
, Flag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) Supported
, Flag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) Supported
, Flag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) Supported
, Flag "main-is" (SepArg setMainIs ) Supported
, Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) Supported
, Flag "haddock-opts" (HasArg (upd . addHaddockOpts)) Supported
......@@ -2198,6 +2205,9 @@ setTmpDir dir dflags = dflags{ tmpDir = normalise dir }
setRtsOpts :: String -> DynP ()
setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg}
setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()
setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg}
-----------------------------------------------------------------------------
-- Hpc stuff
......
......@@ -1832,10 +1832,10 @@ phase <replaceable>n</replaceable></entry>
<entry>-</entry>
</row>
<row>
<entry><option>-rtsopts</option></entry>
<entry>Allow the RTS behaviour to be tweaked via command-line
<entry><option>-rtsopts</option>, <option>-rtsopts={none,some,all}</option></entry>
<entry>Control whether the RTS behaviour can be tweaked via command-line
flags and the <literal>GHCRTS</literal> environment
variable.</entry>
variable. Using <literal>none</literal> means no RTS flags can be given; <literal>some</literal> means only a minimum of safe options can be given (the default), and <literal>all</literal> (or no argument at all) means that all RTS flags are permitted.</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
......
......@@ -9,6 +9,8 @@
#ifndef RTSOPTS_H
#define RTSOPTS_H
extern const rtsBool rtsOptsEnabled;
typedef enum {rtsOptsNone, rtsOptsSafeOnly, rtsOptsAll} rtsOptsEnabledEnum;
extern const rtsOptsEnabledEnum rtsOptsEnabled;
#endif /* RTSOPTS_H */
......@@ -413,7 +413,7 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
char *ghc_rts = getenv("GHCRTS");
if (ghc_rts != NULL) {
if (rtsOptsEnabled) {
if (rtsOptsEnabled != rtsOptsNone) {
splitRtsFlags(ghc_rts, rts_argc, rts_argv);
}
else {
......@@ -438,7 +438,7 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
break;
}
else if (strequal("+RTS", argv[arg])) {
if (rtsOptsEnabled) {
if (rtsOptsEnabled != rtsOptsNone) {
mode = RTS;
}
else {
......@@ -450,7 +450,14 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
mode = PGM;
}
else if (mode == RTS && *rts_argc < MAX_RTS_ARGS-1) {
rts_argv[(*rts_argc)++] = argv[arg];
if ((rtsOptsEnabled == rtsOptsAll) ||
strequal(argv[arg], "--info")) {
rts_argv[(*rts_argc)++] = argv[arg];
}
else {
errorBelch("Most RTS options are disabled. Link with -rtsopts to enable them.");
stg_exit(EXIT_FAILURE);
}
}
else if (mode == PGM) {
argv[(*argc)++] = argv[arg];
......
......@@ -9,5 +9,5 @@
#include "Rts.h"
#include "RtsOpts.h"
const rtsBool rtsOptsEnabled = rtsFalse;
const rtsOptsEnabledEnum rtsOptsEnabled = rtsOptsSafeOnly;
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