From 929d166932ee207871e66cc305059f356241c06b Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 13 Mar 2010 15:45:55 +0000 Subject: [PATCH] Add a link-time flag to en/disable the RTS options If RTS options are disabled then: * The ghc_rts_opts C code variable is processed as normal * The GHCRTS environment variable is ignored and, if it is defined, a warning is emitted * The +RTS flag gives an error and terminates the program --- compiler/main/DriverPipeline.hs | 21 +++++++++++++++++++++ compiler/main/DynFlags.hs | 4 ++++ rts/RtsFlags.c | 17 +++++++++++++++-- rts/RtsOpts.h | 14 ++++++++++++++ rts/hooks/RtsOptsEnabled.c | 13 +++++++++++++ 5 files changed, 67 insertions(+), 2 deletions(-) create mode 100644 rts/RtsOpts.h create mode 100644 rts/hooks/RtsOptsEnabled.c diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 0bac958..4e48a58 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1299,6 +1299,20 @@ wrapper_behaviour dflags mode dep_packages = putStrLn (unwords (map (packageIdString . packageConfigId) allpkg)) return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg)) +mkExtraCObj :: DynFlags -> [String] -> IO FilePath +mkExtraCObj dflags xs + = do cFile <- newTempName dflags "c" + oFile <- newTempName dflags "o" + writeFile cFile $ unlines xs + let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId + SysTools.runCc dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] ++ + map (FileOption "-I") (includeDirs rtsDetails)) + return oFile + -- generates a Perl skript starting a parallel prg under PVM mk_pvm_wrapper_script :: String -> String -> String -> String mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ @@ -1409,6 +1423,12 @@ linkBinary dflags o_files dep_packages = do let no_hs_main = dopt Opt_NoHsMain dflags let main_lib | no_hs_main = [] | otherwise = [ "-lHSrtsmain" ] + rtsEnabledLib <- if dopt Opt_RtsOptsEnabled dflags + then do fn <- mkExtraCObj dflags + ["#include \"Rts.h\"", + "const rtsBool rtsOptsEnabled = rtsTrue;"] + return [fn] + else return [] pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1483,6 +1503,7 @@ linkBinary dflags o_files dep_packages = do #endif ++ pkg_lib_path_opts ++ main_lib + ++ rtsEnabledLib ++ pkg_link_opts #ifdef darwin_TARGET_OS ++ pkg_framework_path_opts diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3a4f625..bb2d132 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -298,6 +298,7 @@ data DynFlag | Opt_EagerBlackHoling | Opt_ReadUserPackageConf | Opt_NoHsMain + | Opt_RtsOptsEnabled | Opt_SplitObjs | Opt_StgStats | Opt_HideAllPackages @@ -690,6 +691,7 @@ defaultDynFlags = dirsToClean = panic "defaultDynFlags: No dirsToClean", haddockOptions = Nothing, flags = [ + Opt_RtsOptsEnabled, Opt_AutoLinkPackages, Opt_ReadUserPackageConf, @@ -1108,6 +1110,8 @@ dynamic_flags = [ ------- Miscellaneous ---------------------------------------------- , Flag "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) Supported , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) Supported + , Flag "rtsopts" (NoArg (setDynFlag Opt_RtsOptsEnabled)) Supported + , Flag "no-rtsopts" (NoArg (unSetDynFlag Opt_RtsOptsEnabled)) Supported , Flag "main-is" (SepArg setMainIs ) Supported , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) Supported , Flag "haddock-opts" (HasArg (upd . addHaddockOpts)) Supported diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index b99995b..790bf42 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -10,6 +10,7 @@ #include "PosixSource.h" #include "Rts.h" +#include "RtsOpts.h" #include "RtsUtils.h" #include "Profiling.h" @@ -413,7 +414,13 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) char *ghc_rts = getenv("GHCRTS"); if (ghc_rts != NULL) { - splitRtsFlags(ghc_rts, rts_argc, rts_argv); + if (rtsOptsEnabled) { + splitRtsFlags(ghc_rts, rts_argc, rts_argv); + } + else { + errorBelch("Warning: Ignoring GHCRTS variable"); + // We don't actually exit, just warn + } } } @@ -432,7 +439,13 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) break; } else if (strequal("+RTS", argv[arg])) { - mode = RTS; + if (rtsOptsEnabled) { + mode = RTS; + } + else { + errorBelch("RTS options are disabled"); + stg_exit(EXIT_FAILURE); + } } else if (strequal("-RTS", argv[arg])) { mode = PGM; diff --git a/rts/RtsOpts.h b/rts/RtsOpts.h new file mode 100644 index 0000000..381ee0e --- /dev/null +++ b/rts/RtsOpts.h @@ -0,0 +1,14 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2010 + * + * En/disable RTS options + * + * ---------------------------------------------------------------------------*/ + +#ifndef RTSOPTS_H +#define RTSOPTS_H + +extern const rtsBool rtsOptsEnabled; + +#endif /* RTSOPTS_H */ diff --git a/rts/hooks/RtsOptsEnabled.c b/rts/hooks/RtsOptsEnabled.c new file mode 100644 index 0000000..d7d6cb5 --- /dev/null +++ b/rts/hooks/RtsOptsEnabled.c @@ -0,0 +1,13 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2010 + * + * En/disable RTS options + * + * ---------------------------------------------------------------------------*/ + +#include "Rts.h" +#include "RtsOpts.h" + +const rtsBool rtsOptsEnabled = rtsFalse; + -- 1.7.10.4