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

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 81886ec..2b9cd43 100644 (file)
--- 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" ]
     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
     rtsOptsObj <- case rtsOpts dflags of
                   Just opts ->
                       do fn <- mkExtraCObj dflags

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6524ba6..2971aa1 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -19,6 +19,7 @@ module DynFlags (
         lopt_set_flattened,
         lopt_unset_flattened,
         DynFlags(..),
         lopt_set_flattened,
         lopt_unset_flattened,
         DynFlags(..),

+        RtsOptsEnabled(..),

         HscTarget(..), isObjectTarget, defaultObjectTarget,
         GhcMode(..), isOneShot,
         GhcLink(..), isNoLink,
         HscTarget(..), isObjectTarget, defaultObjectTarget,
         GhcMode(..), isOneShot,
         GhcLink(..), isNoLink,

@@ -234,7 +235,6 @@ data DynFlag
    | Opt_EagerBlackHoling
    | Opt_ReadUserPackageConf
    | Opt_NoHsMain
    | Opt_EagerBlackHoling
    | Opt_ReadUserPackageConf
    | Opt_NoHsMain

-   | Opt_RtsOptsEnabled

    | Opt_SplitObjs
    | Opt_StgStats
    | Opt_HideAllPackages
    | 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,
   ghcUsagePath          :: FilePath,    -- Filled in by SysTools
   ghciUsagePath         :: FilePath,    -- ditto
   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
   | SystemDependent
   deriving Eq
 
   | 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
 -- | 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,
         cmdlineFrameworks       = [],
         tmpDir                  = cDEFAULT_TMPDIR,
         rtsOpts                 = Nothing,

+        rtsOptsEnabled          = RtsOptsSafeOnly,

 
         hpcDir                  = ".hpc",
 
 
         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 "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
   , 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}
 
 setRtsOpts :: String -> DynP ()
 setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}
 

+setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()
+setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}
+

 -----------------------------------------------------------------------------
 -- Hpc stuff
 
 -----------------------------------------------------------------------------
 -- Hpc stuff
 

diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index efe1093..cb3700c 100644 (file)
--- 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>-</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
           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>
              <entry>dynamic</entry>
              <entry>-</entry>
            </row>

diff --git a/rts/RtsOpts.h b/includes/RtsOpts.h
similarity index 69%
rename from rts/RtsOpts.h
rename to includes/RtsOpts.h
index 381ee0e..e81a41c 100644 (file)
--- a/rts/RtsOpts.h
+++ b/includes/RtsOpts.h
@@ -9,6 +9,8 @@
 #ifndef RTSOPTS_H
 #define RTSOPTS_H
 
 #ifndef 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 */

diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 5eb7800..2e8ee9e 100644 (file)
--- 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) {
        char *ghc_rts = getenv("GHCRTS");
 
        if (ghc_rts != NULL) {

-            if (rtsOptsEnabled) {
+            if (rtsOptsEnabled != rtsOptsNone) {

                 splitRtsFlags(ghc_rts, rts_argc, rts_argv);
             }
             else {
                 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])) {
            break;
        }
        else if (strequal("+RTS", argv[arg])) {

-            if (rtsOptsEnabled) {
+            if (rtsOptsEnabled != rtsOptsNone) {

                 mode = RTS;
             }
             else {
                 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) {
            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];
        }
        else if (mode == PGM) {
            argv[(*argc)++] = argv[arg];

diff --git a/rts/hooks/RtsOptsEnabled.c b/rts/hooks/RtsOptsEnabled.c
index d7d6cb5..f5d8157 100644 (file)
--- a/rts/hooks/RtsOptsEnabled.c
+++ b/rts/hooks/RtsOptsEnabled.c
@@ -9,5 +9,5 @@
 #include "Rts.h"
 #include "RtsOpts.h"
 
 #include "Rts.h"
 #include "RtsOpts.h"
 

-const rtsBool rtsOptsEnabled = rtsFalse;
+const rtsOptsEnabledEnum rtsOptsEnabled = rtsOptsSafeOnly;