base: Add handling of -- to getArgs for Windows

getArgs didn't match the treatmeant of -- in the RTS leading to
inconsistencies between behavior on Windows and other platforms. See #13287.

Reviewers: austin, hvr, bgamari, erikd, simonmar, rwbarton

Reviewed By: bgamari, rwbarton

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3147

5 files changed, 32 insertions, 2 deletions

diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs
index d8b3e03be5..61b728cb9c 100644
--- a/libraries/base/System/Environment.hs
+++ b/libraries/base/System/Environment.hs
@@ -67,12 +67,24 @@ import System.Environment.ExecutablePath
 
 #ifdef mingw32_HOST_OS
 
--- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
+{-
+Note [Ignore hs_init argv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ignore the arguments to hs_init on Windows for the sake of Unicode compat
+
+Instead on Windows we get the list of arguments from getCommandLineW and
+filter out arguments which the RTS would not have passed along.
+
+This is done to ensure we get the arguments in proper Unicode Encoding which
+the RTS at this moment does not seem provide. The filtering has to match the
+one done by the RTS to avoid inconsistencies like #13287.
+-}
 
 getWin32ProgArgv_certainly :: IO [String]
 getWin32ProgArgv_certainly = do
         mb_argv <- getWin32ProgArgv
         case mb_argv of
+          -- see Note [Ignore hs_init argv]
           Nothing   -> fmap dropRTSArgs getFullArgs
           Just argv -> return argv
 
@@ -106,8 +118,10 @@ foreign import ccall unsafe "getWin32ProgArgv"
 foreign import ccall unsafe "setWin32ProgArgv"
   c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO ()
 
+-- See Note [Ignore hs_init argv]
 dropRTSArgs :: [String] -> [String]
 dropRTSArgs []             = []
+dropRTSArgs rest@("--":_)  = rest
 dropRTSArgs ("+RTS":rest)  = dropRTSArgs (dropWhile (/= "-RTS") rest)
 dropRTSArgs ("--RTS":rest) = rest
 dropRTSArgs ("-RTS":rest)  = dropRTSArgs rest
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 5fd368cb61..6ab70d4888 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -512,6 +512,13 @@ static void errorRtsOptsDisabled(const char *s)
 
      - rtsConfig   (global) contains the supplied RtsConfig
 
+  On Windows getArgs ignores argv and instead takes the arguments directly
+  from the WinAPI and removes any which would have been parsed by the RTS.
+
+  If the handling of which arguments are passed to the Haskell side changes
+  these changes have to be synchronized with getArgs in base. See #13287 and
+  Note [Ignore hs_init argv] in System.Environment.
+
   -------------------------------------------------------------------------- */
 
 void setupRtsFlags (int *argc, char *argv[], RtsConfig rts_config)
@@ -566,7 +573,7 @@ void setupRtsFlags (int *argc, char *argv[], RtsConfig rts_config)
 
     // Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts
     //   argv[0] must be PGM argument -- leave in argv
-
+    //
     for (mode = PGM; arg < total_arg; arg++) {
         // The '--RTS' argument disables all future +RTS ... -RTS processing.
         if (strequal("--RTS", argv[arg])) {
diff --git a/testsuite/tests/rts/T13287/T13287.hs b/testsuite/tests/rts/T13287/T13287.hs
new file mode 100644
index 0000000000..d5b8b430db
--- /dev/null
+++ b/testsuite/tests/rts/T13287/T13287.hs
@@ -0,0 +1,4 @@
+import System.Environment (getArgs)
+
+main :: IO ()
+main = getArgs >>= print
diff --git a/testsuite/tests/rts/T13287/T13287.stdout b/testsuite/tests/rts/T13287/T13287.stdout
new file mode 100644
index 0000000000..d6df8ca157
--- /dev/null
+++ b/testsuite/tests/rts/T13287/T13287.stdout
@@ -0,0 +1 @@
+["a1","--","a2","+RTS","-RTS","a3"]
diff --git a/testsuite/tests/rts/T13287/all.T b/testsuite/tests/rts/T13287/all.T
new file mode 100644
index 0000000000..0543e504a8
--- /dev/null
+++ b/testsuite/tests/rts/T13287/all.T
@@ -0,0 +1,4 @@
+# Ensure that RTS flags past -- get ignored 

+

+test('T13287', [extra_run_opts('a1 +RTS -RTS -- a2 +RTS -RTS a3'), omit_ways(['ghci'])], compile_and_run, [''])

+