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".

6 files changed, 40 insertions, 17 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 81886ec774..2b9cd4347f 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6524ba6a83..2971aa11ca 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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
 
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index efe1093f86..cb3700c998 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -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>
diff --git a/rts/RtsOpts.h b/includes/RtsOpts.h
index 381ee0e3c5..e81a41c7df 100644
--- a/rts/RtsOpts.h
+++ b/includes/RtsOpts.h
@@ -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 */
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 5eb7800540..2e8ee9e9c8 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -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];
diff --git a/rts/hooks/RtsOptsEnabled.c b/rts/hooks/RtsOptsEnabled.c
index d7d6cb595f..f5d81579f6 100644
--- a/rts/hooks/RtsOptsEnabled.c
+++ b/rts/hooks/RtsOptsEnabled.c
@@ -9,5 +9,5 @@
 #include "Rts.h"
 #include "RtsOpts.h"
 
-const rtsBool rtsOptsEnabled = rtsFalse;
+const rtsOptsEnabledEnum rtsOptsEnabled = rtsOptsSafeOnly;