Implement the RTS side of GHC.Environment.getFullArgs

diff --git a/compiler/Makefile b/compiler/Makefile
index dcaf18e..0b84536 100644 (file)
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -710,9 +710,17 @@ EXCLUDED_SRCS += $(INPLACE_HS)
 # will go wrong when we use it in a Haskell string below.
 TOP_ABS=$(subst \\,/,$(FPTOOLS_TOP_ABS_PLATFORM))
 
+ifeq "$(stage)" "1"
+EnvImport = System.Environment
+GetArgs = getArgs
+else
+EnvImport = GHC.Environment
+GetArgs = getFullArgs
+endif
+
 $(INPLACE_HS): Makefile $(FPTOOLS_TOP)/mk/config.mk
-       echo "import System.Cmd; import System.Environment; import System.Exit" > $@
-       echo "main = do args <- getArgs; rawSystem \"$(TOP_ABS)/$(GHC_COMPILER_DIR_REL)/$(GHC_PROG)\" (\"-B$(TOP_ABS)\":args) >>= exitWith" >> $@
+       echo "import System.Cmd; import $(EnvImport); import System.Exit" > $@
+       echo "main = do args <- $(GetArgs); rawSystem \"$(TOP_ABS)/$(GHC_COMPILER_DIR_REL)/$(GHC_PROG)\" (\"-B$(TOP_ABS)\":args) >>= exitWith" >> $@
 
 $(INPLACE_PROG): $(INPLACE_HS)
        $(HC) --make $< -o $@

diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 7d28328..54fa3ee 100644 (file)
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -42,6 +42,8 @@ extern void shutdownHaskell        ( void );
 extern void shutdownHaskellAndExit ( int exitCode );
 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[] );
 
 /* exit() override */
 extern void (*exitFn)(int);

diff --git a/rts/Linker.c b/rts/Linker.c
index d8d61a0..243eae1 100644 (file)
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -523,6 +523,7 @@ typedef struct _RtsSymbolVal {
       SymX(genSymZh)                           \
       SymX(genericRaise)                       \
       SymX(getProgArgv)                                \
+      SymX(getFullProgArgv)                            \
       SymX(getStablePtr)                       \
       SymX(hs_init)                            \
       SymX(hs_exit)                            \

diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 9dd6b19..a2d699d 100644 (file)
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -28,6 +28,8 @@ RTS_FLAGS RtsFlags;
  */
 int     prog_argc = 0;    /* an "int" so as to match normal "argc" */
 char  **prog_argv = NULL;
+int     full_prog_argc = 0;    /* an "int" so as to match normal "argc" */
+char  **full_prog_argv = NULL;
 char   *prog_name = NULL; /* 'basename' of prog_argv[0] */
 int     rts_argc = 0;  /* ditto */
 char   *rts_argv[MAX_RTS_ARGS];
@@ -2411,3 +2413,29 @@ setProgArgv(int argc, char *argv[])
    prog_argv = argv;
    setProgName(prog_argv);
 }
+
+/* These functions record and recall the full arguments, including the
+   +RTS ... -RTS options. The reason for adding them was so that the
+   ghc-inplace program can pass /all/ the arguments on to the real ghc. */
+void
+getFullProgArgv(int *argc, char **argv[])
+{
+    if (argc) { *argc = full_prog_argc; }
+    if (argv) { *argv = full_prog_argv; }
+}
+
+void
+setFullProgArgv(int argc, char *argv[])
+{
+    int i;
+    full_prog_argc = argc;
+    full_prog_argv = stgCallocBytes(argc + 1, sizeof (char *),
+                                    "setFullProgArgv 1");
+    for (i = 0; i < argc; i++) {
+        full_prog_argv[i] = stgMallocBytes(strlen(argv[i]) + 1,
+                                           "setFullProgArgv 2");
+        strcpy(full_prog_argv[i], argv[i]);
+    }
+    full_prog_argv[argc] = NULL;
+}
+

diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 7dce06e..a363c13 100644 (file)
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -199,6 +199,7 @@ 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, &rts_argc, rts_argv);
        setProgArgv(*argc,*argv);
     }