From: Ian Lynagh Date: Thu, 5 Aug 2010 01:11:37 +0000 (+0000) Subject: Make -rtsopts more flexible X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=320738062c7a81f062c5adab98a1a1c4fdbd4bc7 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 --- 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 6524ba6..2971aa1 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 efe1093..cb3700c 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1832,10 +1832,10 @@ phase n - - - Allow the RTS behaviour to be tweaked via command-line + , + Control whether the RTS behaviour can be tweaked via command-line flags and the GHCRTS environment - variable. + variable. Using none means no RTS flags can be given; some means only a minimum of safe options can be given (the default), and all (or no argument at all) means that all RTS flags are permitted. dynamic - 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 --- 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 5eb7800..2e8ee9e 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 d7d6cb5..f5d8157 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;