Commit 32073806 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

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