Generate the C main() function when linking a binary (fixes #5373)

Rather than have main() be statically compiled as part of the RTS, we
now generate it into the tiny C file that we compile when linking a
binary.

The main motivation is that we want to pass the settings for the
-rtsotps and -with-rtsopts flags into the RTS, rather than relying on
fragile linking semantics to override the defaults, which don't work
with DLLs on Windows (#5373).  In order to do this, we need to extend
the API for initialising the RTS, so now we have:

void hs_init_ghc (int *argc, char **argv[],   // program arguments
                  RtsConfig rts_config);      // RTS configuration

hs_init_ghc() can optionally be used instead of hs_init(), and allows
passing in configuration options for the RTS.  RtsConfig is a struct,
which currently has two fields:

typedef struct {
    RtsOptsEnabledEnum rts_opts_enabled;
    const char *rts_opts;
} RtsConfig;

but might have more in the future.  There is a default value for the
struct, defaultRtsConfig, the idea being that you start with this and
override individual fields as necessary.

In fact, main() was in a separate static library, libHSrtsmain.a.
That's now gone.

12 files changed, 114 insertions, 122 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 8c0f3a6098..4ef2bcbf9d 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1437,25 +1437,39 @@ mkExtraCObj dflags xs
                       ++ map (FileOption "-I") (includeDirs rtsDetails))
       return oFile
 
+-- When linking a binary, we need to create a C main() function that
+-- starts everything off.  This used to be compiled statically as part
+-- of the RTS, but that made it hard to change the -rtsopts setting,
+-- so now we generate and compile a main() stub as part of every
+-- binary and pass the -rtsopts setting directly to the RTS (#5373)
+--
 mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath
 mkExtraObjToLinkIntoBinary dflags dep_packages = do
    link_info <- getLinkInfo dflags dep_packages
-   mkExtraCObj dflags (showSDoc (vcat [rts_opts_enabled,
-                                       extra_rts_opts,
+
+   mkExtraCObj dflags (showSDoc (vcat [main,
                                        link_opts link_info]
                                    <> char '\n')) -- final newline, to
                                                   -- keep gcc happy
 
   where
-    rts_opts_enabled
-         = vcat [text "#include \"Rts.h\"",
-                 text "#include \"RtsOpts.h\"",
-                 text "const RtsOptsEnabledEnum rtsOptsEnabled = " <>
-                       text (show (rtsOptsEnabled dflags)) <> semi ]
-
-    extra_rts_opts = case rtsOpts dflags of
-          Nothing   -> empty
-          Just opts -> text "char *ghc_rts_opts = " <> text (show opts) <> semi
+    main
+      | dopt Opt_NoHsMain dflags = empty
+      | otherwise = vcat [
+             ptext (sLit "#include \"Rts.h\""),
+             ptext (sLit "extern StgClosure ZCMain_main_closure;"),
+             ptext (sLit "int main(int argc, char *argv[])"),
+             char '{',
+             ptext (sLit "    RtsConfig __conf = defaultRtsConfig;"),
+             ptext (sLit "    __conf.rts_opts_enabled = ")
+                 <> text (show (rtsOptsEnabled dflags)) <> semi,
+             case rtsOpts dflags of
+                Nothing   -> empty
+                Just opts -> ptext (sLit "    __conf.rts_opts= ") <>
+                               text (show opts) <> semi,
+             ptext (sLit "    return hs_main(argc, argv, &ZCMain_main_closure,__conf);"),
+             char '}'
+           ]
 
     link_opts info
      | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
@@ -1607,13 +1621,6 @@ linkBinary dflags o_files dep_packages = do
     let lib_paths = libraryPaths dflags
     let lib_path_opts = map ("-L"++) lib_paths
 
-    -- The C "main" function is not in the rts but in a separate static
-    -- library libHSrtsmain.a that sits next to the rts lib files. Assuming
-    -- we're using a Haskell main function then we need to link it in.
-    let no_hs_main = dopt Opt_NoHsMain dflags
-    let main_lib | no_hs_main = []
-                 | otherwise  = [ "-lHSrtsmain" ]
-
     extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
 
     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
@@ -1731,7 +1738,6 @@ linkBinary dflags o_files dep_packages = do
                       ++ framework_path_opts
                       ++ framework_opts
                       ++ pkg_lib_path_opts
-                      ++ main_lib
                       ++ [extraLinkObj]
                       ++ pkg_link_opts
                       ++ pkg_framework_path_opts
@@ -1852,8 +1858,6 @@ linkDynLib dflags o_files dep_packages = do
 
     let extra_ld_opts = getOpts dflags opt_l
 
-    extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
-
 #if defined(mingw32_HOST_OS)
     -----------------------------------------------------------------------------
     -- Making a DLL
@@ -1880,7 +1884,6 @@ linkDynLib dflags o_files dep_packages = do
          ++ lib_path_opts
          ++ extra_ld_opts
          ++ pkg_lib_path_opts
-         ++ [extraLinkObj]
          ++ pkg_link_opts
         ))
 #elif defined(darwin_TARGET_OS)
@@ -1936,7 +1939,6 @@ linkDynLib dflags o_files dep_packages = do
          ++ lib_path_opts
          ++ extra_ld_opts
          ++ pkg_lib_path_opts
-         ++ [extraLinkObj]
          ++ pkg_link_opts
         ))
 #else
@@ -1970,7 +1972,6 @@ linkDynLib dflags o_files dep_packages = do
          ++ lib_path_opts
          ++ extra_ld_opts
          ++ pkg_lib_path_opts
-         ++ [extraLinkObj]
          ++ pkg_link_opts
         ))
 #endif
diff --git a/includes/Rts.h b/includes/Rts.h
index 91ec76d467..5caba59dbe 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -213,6 +213,7 @@ void _assertFail(const char *filename, unsigned int linenum)
 #include "rts/TTY.h"
 #include "rts/Utils.h"
 #include "rts/PrimFloat.h"
+#include "rts/Main.h"
 
 /* Misc stuff without a home */
 DLL_IMPORT_RTS extern char **prog_argv;	/* so we can get at these from Haskell */
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index dc151faf07..329b1569ab 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -38,26 +38,64 @@ typedef struct StgClosure_ *HaskellObj;
 typedef struct Capability_ Capability;
 
 /* ----------------------------------------------------------------------------
+   RTS configuration settings, for passing to hs_init_ghc()
+   ------------------------------------------------------------------------- */
+
+typedef enum {
+    RtsOptsNone,         // +RTS causes an error
+    RtsOptsSafeOnly,     // safe RTS options allowed; others cause an error
+    RtsOptsAll           // all RTS options allowed
+  } RtsOptsEnabledEnum;
+
+// The RtsConfig struct is passed (by value) to hs_init_ghc().  The
+// reason for using a struct is extensibility: we can add more
+// fields to this later without breaking existing client code.
+typedef struct {
+    RtsOptsEnabledEnum rts_opts_enabled;
+    const char *rts_opts;
+} RtsConfig;
+
+// Clients should start with defaultRtsConfig and then customise it.
+// Bah, I really wanted this to be a const struct value, but it seems
+// you can't do that in C (it generates code).
+extern const RtsConfig defaultRtsConfig;
+
+/* ----------------------------------------------------------------------------
    Starting up and shutting down the Haskell RTS.
    ------------------------------------------------------------------------- */
-extern void startupHaskell         ( int argc, char *argv[], 
+
+/* DEPRECATED, use hs_init() or hs_init_ghc() instead  */
+extern void startupHaskell         ( int argc, char *argv[],
 				     void (*init_root)(void) );
+
+/* DEPRECATED, use hs_exit() instead  */
 extern void shutdownHaskell        ( void );
+
+/*
+ * GHC-specific version of hs_init() that allows specifying whether
+ * +RTS ... -RTS options are allowed or not (default: only "safe"
+ * options are allowed), and allows passing an option string that is
+ * to be interpreted by the RTS only, not passed to the program.
+ */
+extern void hs_init_ghc (int *argc, char **argv[],   // program arguments
+                         RtsConfig rts_config);      // RTS configuration
+
 extern void shutdownHaskellAndExit ( int exitCode )
 #if __GNUC__ >= 3
     __attribute__((__noreturn__))
 #endif
     ;
+
+#ifndef mingw32_HOST_OS
+extern void shutdownHaskellAndSignal (int sig);
+#endif
+
 extern void getProgArgv            ( int *argc, char **argv[] );
 extern void setProgArgv            ( int argc, char *argv[] );
 extern void getFullProgArgv        ( int *argc, char **argv[] );
 extern void setFullProgArgv        ( int argc, char *argv[] );
 extern void freeFullProgArgv       ( void ) ;
 
-#ifndef mingw32_HOST_OS
-extern void shutdownHaskellAndSignal (int sig);
-#endif
-
 /* exit() override */
 extern void (*exitFn)(int);
 
diff --git a/includes/RtsOpts.h b/includes/RtsOpts.h
deleted file mode 100644
index b8eab68d3b..0000000000
--- a/includes/RtsOpts.h
+++ /dev/null
@@ -1,20 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 2010
- *
- * En/disable RTS options
- *
- * ---------------------------------------------------------------------------*/
-
-#ifndef RTSOPTS_H
-#define RTSOPTS_H
-
-typedef enum {
-    RtsOptsNone,         // +RTS causes an error
-    RtsOptsSafeOnly,     // safe RTS options allowed; others cause an error
-    RtsOptsAll           // all RTS options allowed
-  } RtsOptsEnabledEnum;
-
-extern const RtsOptsEnabledEnum rtsOptsEnabled;
-
-#endif /* RTSOPTS_H */
diff --git a/rts/RtsMain.h b/includes/rts/Main.h
index e004480cce..1c332fc95c 100644
--- a/rts/RtsMain.h
+++ b/includes/rts/Main.h
@@ -13,7 +13,9 @@
  * The entry point for Haskell programs that use a Haskell main function
  * -------------------------------------------------------------------------- */
 
-int hs_main(int argc, char *argv[], StgClosure *main_closure)
+int hs_main (int argc, char *argv[],     // program args
+             StgClosure *main_closure,   // closure for Main.main
+             RtsConfig rts_config)       // RTS configuration
    GNUC3_ATTRIBUTE(__noreturn__);
 
 #endif /* RTSMAIN_H */
diff --git a/rts/Main.c b/rts/Main.c
deleted file mode 100644
index c7a559fc14..0000000000
--- a/rts/Main.c
+++ /dev/null
@@ -1,24 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team 2009
- *
- * The C main() function for a standalone Haskell program.
- *
- * Note that this is not part of the RTS. It calls into the RTS to get things
- * going. It is compiled to a separate Main.o which is linked into every
- * standalone Haskell program that uses a Haskell Main.main function
- * (as opposed to a mixed Haskell C program using a C main function).
- *
- * ---------------------------------------------------------------------------*/
-
-#include "PosixSource.h"
-#include "Rts.h"
-#include "RtsMain.h"
-
-/* Similarly, we can refer to the ZCMain_main_closure here */
-extern StgClosure ZCMain_main_closure;
-
-int main(int argc, char *argv[])
-{
-    return hs_main(argc, argv, &ZCMain_main_closure);
-}
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index d2b4945c19..d8bcf1c915 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -10,7 +10,6 @@
 #include "PosixSource.h"
 #include "Rts.h"
 
-#include "RtsOpts.h"
 #include "RtsUtils.h"
 #include "Profiling.h"
 #include "RtsFlags.h"
@@ -396,9 +395,10 @@ strequal(const char *a, const char * b)
     return(strcmp(a, b) == 0);
 }
 
-static void splitRtsFlags(char *s)
+static void splitRtsFlags(const char *s)
 {
-    char *c1, *c2;
+    const char *c1, *c2;
+    char *t;
 
     c1 = s;
     do {
@@ -408,10 +408,10 @@ static void splitRtsFlags(char *s)
 	
 	if (c1 == c2) { break; }
 	
-        s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
-        strncpy(s, c1, c2-c1);
-        s[c2-c1] = '\0';
-        rts_argv[rts_argc++] = s;
+        t = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
+        strncpy(t, c1, c2-c1);
+        t[c2-c1] = '\0';
+        rts_argv[rts_argc++] = t;
 
 	c1 = c2;
     } while (*c1 != '\0');
@@ -434,7 +434,9 @@ static void splitRtsFlags(char *s)
 
   -------------------------------------------------------------------------- */
 
-void setupRtsFlags (int *argc, char *argv[])
+void setupRtsFlags (int *argc, char *argv[],
+                    RtsOptsEnabledEnum rtsOptsEnabled,
+                    const char *ghc_rts_opts)
 {
     nat mode;
     nat total_arg;
@@ -554,14 +556,14 @@ static void checkUnsafe(RtsOptsEnabledEnum enabled)
     }
 }
 
-static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled)
+static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum rtsOptsEnabled)
 {
     rtsBool error = rtsFalse;
     int arg;
 
     if (!(rts_argc0 < rts_argc)) return;
 
-    if (enabled == RtsOptsNone) {
+    if (rtsOptsEnabled == RtsOptsNone) {
         errorBelch("RTS options are disabled. Link with -rtsopts to enable them.");
         stg_exit(EXIT_FAILURE);
     }
@@ -578,7 +580,7 @@ static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled)
         rtsBool option_checked = rtsFalse;
 
 #define OPTION_SAFE option_checked = rtsTrue;
-#define OPTION_UNSAFE checkUnsafe(enabled); option_checked = rtsTrue;
+#define OPTION_UNSAFE checkUnsafe(rtsOptsEnabled); option_checked = rtsTrue;
 
         if (rts_argv[arg][0] != '-') {
 	    fflush(stdout);
@@ -1142,7 +1144,7 @@ error = rtsTrue;
 		      errorBelch("bad value for -N");
 		      error = rtsTrue;
 		    }
-                    if (enabled == RtsOptsSafeOnly &&
+                    if (rtsOptsEnabled == RtsOptsSafeOnly &&
                 	nNodes > (int)getNumberOfProcessors()) {
                       errorBelch("Using large values for -N is not allowed by default. Link with -rtsopts to allow full control.");
                       stg_exit(EXIT_FAILURE);
diff --git a/rts/RtsFlags.h b/rts/RtsFlags.h
index a6bfe0a924..73eb6688a6 100644
--- a/rts/RtsFlags.h
+++ b/rts/RtsFlags.h
@@ -15,7 +15,9 @@
 /* Routines that operate-on/to-do-with RTS flags: */
 
 void initRtsFlagsDefaults (void);
-void setupRtsFlags        (int *argc, char *argv[]);
+void setupRtsFlags        (int *argc, char *argv[],
+                           RtsOptsEnabledEnum rtsOptsEnabled,
+                           const char *ghc_rts_opts);
 void setProgName          (char *argv[]);
 void freeRtsArgs          (void);
 
diff --git a/rts/RtsMain.c b/rts/RtsMain.c
index a822da9749..0f6ca82382 100644
--- a/rts/RtsMain.c
+++ b/rts/RtsMain.c
@@ -13,7 +13,6 @@
 #include "RtsAPI.h"
 
 #include "RtsUtils.h"
-#include "RtsMain.h"
 #include "Prelude.h"
 #include "Task.h"
 #if defined(mingw32_HOST_OS)
@@ -33,8 +32,9 @@
 static int progargc;
 static char **progargv;
 static StgClosure *progmain_closure;  /* This will be ZCMain_main_closure */
+static RtsConfig rtsconfig;
 
-/* Hack: we assume that we're building a batch-mode system unless 
+/* Hack: we assume that we're building a batch-mode system unless
  * INTERPRETER is set
  */
 #ifndef INTERPRETER /* Hack */
@@ -43,9 +43,8 @@ static void real_main(void)
 {
     int exit_status;
     SchedulerStatus status;
-    /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */
 
-    startupHaskell(progargc,progargv,NULL);
+    hs_init_ghc(&progargc, &progargv, rtsconfig);
 
     /* kick off the computation by creating the main thread with a pointer
        to mainIO_closure representing the computation of the overall program;
@@ -89,22 +88,26 @@ static void real_main(void)
     shutdownHaskellAndExit(exit_status);
 }
 
-/* The rts entry point from a compiled program using a Haskell main function.
- * This gets called from a tiny main function which gets linked into each
- * compiled Haskell program that uses a Haskell main function.
+/* The rts entry point from a compiled program using a Haskell main
+ * function.  This gets called from a tiny main function generated by
+ * GHC and linked into each compiled Haskell program that uses a
+ * Haskell main function.
  *
  * We expect the caller to pass ZCMain_main_closure for
  * main_closure. The reason we cannot refer to this symbol directly
  * is because we're inside the rts and we do not know for sure that
  * we'll be using a Haskell main function.
  */
-int hs_main(int argc, char *argv[], StgClosure *main_closure)
+int hs_main (int argc, char *argv[],     // program args
+             StgClosure *main_closure,   // closure for Main.main
+             RtsConfig rts_config)    // RTS configuration
 {
     /* We do this dance with argc and argv as otherwise the SEH exception
        stuff (the BEGIN/END CATCH below) on Windows gets confused */
     progargc = argc;
     progargv = argv;
     progmain_closure = main_closure;
+    rtsconfig = rts_config;
 
 #if defined(mingw32_HOST_OS)
     BEGIN_CATCH
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index de8bf792c4..e8ed86c994 100755
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -71,6 +71,11 @@ static int hs_init_count = 0;
 
 static void flushStdHandles(void);
 
+const RtsConfig defaultRtsConfig  = {
+    .rts_opts_enabled = RtsOptsSafeOnly,
+    .rts_opts = NULL
+};
+
 /* -----------------------------------------------------------------------------
    Initialise floating point unit on x86 (currently disabled; See Note
    [x86 Floating point precision] in compiler/nativeGen/X86/Instr.hs)
@@ -106,6 +111,12 @@ x86_init_fpu ( void )
 void
 hs_init(int *argc, char **argv[])
 {
+    hs_init_ghc(argc, argv, defaultRtsConfig);
+}
+
+void
+hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
+{
     hs_init_count++;
     if (hs_init_count > 1) {
 	// second and subsequent inits are ignored
@@ -132,7 +143,8 @@ hs_init(int *argc, char **argv[])
     /* Parse the flags, separating the RTS flags from the programs args */
     if (argc != NULL && argv != NULL) {
 	setFullProgArgv(*argc,*argv);
-        setupRtsFlags(argc, *argv);
+        setupRtsFlags(argc, *argv,
+                      rts_config.rts_opts_enabled, rts_config.rts_opts);
     }
 
     /* Initialise the stats department, phase 1 */
diff --git a/rts/ghc.mk b/rts/ghc.mk
index 54c941d019..40ff02fcc4 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -20,8 +20,7 @@ rts_dist_HC = $(GHC_STAGE1)
 rts_WAYS = $(GhcLibWays) $(filter-out $(GhcLibWays),$(GhcRTSWays))
 rts_dist_WAYS = $(rts_WAYS)
 
-ALL_RTS_LIBS = rts/dist/build/libHSrtsmain.a \
-             $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf))
+ALL_RTS_LIBS = $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf))
 all_rts : $(ALL_RTS_LIBS)
 
 # -----------------------------------------------------------------------------
@@ -36,7 +35,6 @@ ALL_DIRS += posix
 endif
 
 EXCLUDED_SRCS :=
-EXCLUDED_SRCS += rts/Main.c
 EXCLUDED_SRCS += rts/parallel/SysMan.c
 EXCLUDED_SRCS += $(wildcard rts/Vis*.c)
 
@@ -485,15 +483,6 @@ $(DTRACEPROBES_H): $(DTRACEPROBES_SRC) includes/ghcplatform.h | $$(dir $$@)/.
 endif
 
 # -----------------------------------------------------------------------------
-# build the static lib containing the C main symbol
-
-ifneq "$(BINDIST)" "YES"
-rts/dist/build/libHSrtsmain.a : rts/dist/build/Main.o
-	"$(RM)" $(RM_OPTS) $@
-	"$(AR_STAGE1)" $(AR_OPTS_STAGE1) $(EXTRA_AR_ARGS_STAGE1) $@ $<
-endif
-
-# -----------------------------------------------------------------------------
 # The RTS package config
 
 # If -DDEBUG is in effect, adjust package conf accordingly..
diff --git a/rts/hooks/RtsOpts.c b/rts/hooks/RtsOpts.c
deleted file mode 100644
index 2aae37246e..0000000000
--- a/rts/hooks/RtsOpts.c
+++ /dev/null
@@ -1,14 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * Default RTS options.
- *
- * ---------------------------------------------------------------------------*/
-
-#include "PosixSource.h"
-#include "Rts.h"
-
-#include <stdlib.h>
-
-// Default RTS options can be given by providing an alternate
-// definition for this variable, pointing to a string of RTS options.
-char *ghc_rts_opts = NULL;