[commit: ghc] master: base: Add handling of -- to getArgs for Windows (6ca6a36)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/6ca6a360c2b71d7e0c77a819dc463b37efe7a39d/ghc

>---------------------------------------------------------------

commit 6ca6a360c2b71d7e0c77a819dc463b37efe7a39d
Author: Andreas Klebinger <klebinger.andreas at gmx.at>
Date:   Thu Feb 23 13:46:15 2017 -0500

    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


>---------------------------------------------------------------

6ca6a360c2b71d7e0c77a819dc463b37efe7a39d
 libraries/base/System/Environment.hs     | 16 +++++++++++++++-
 rts/RtsFlags.c                           |  9 ++++++++-
 testsuite/tests/rts/T13287/T13287.hs     |  4 ++++
 testsuite/tests/rts/T13287/T13287.stdout |  1 +
 testsuite/tests/rts/T13287/all.T         |  4 ++++
 5 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs
index d8b3e03..61b728c 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 5fd368c..6ab70d4 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 0000000..d5b8b43
--- /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 0000000..d6df8ca
--- /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 0000000..0543e50
--- /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, [''])
+