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
scpmw · Mar 13, 2010 · 929d166 · 929d166
1 parent 1e31c29
commit 929d166
Show file tree

Hide file tree

Showing 5 changed files with 67 additions and 2 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -0,0 +1,13 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2010
+ *
+ * En/disable RTS options
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsOpts.h"
+
+const rtsBool rtsOptsEnabled = rtsFalse;
+