From: Simon Marlow <marlowsd@gmail.com>
Date: Fri, 26 Jun 2009 12:05:22 +0000 (+0000)
Subject: set binary mode for existing FDs on Windows (fixes some GHCi test failures)
X-Git-Tag: ghc-darcs-git-switchover~380
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d181127657f46b1d0acd3dc94ccce4c0e6241095;p=ghc-base.git

set binary mode for existing FDs on Windows (fixes some GHCi test failures)
---

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 464097e..32f4e9b 100644
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -216,7 +216,8 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do
                    _ -> True
 
 #ifdef mingw32_HOST_OS
-    let _ = (dev,ino,write,fd) -- warning suppression
+    setmode fd True -- unconditionally set binary mode
+    let _ = (dev,ino,write) -- warning suppression
 #endif
 
     case fd_type of
@@ -247,6 +248,11 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do
               },
             fd_type)
 
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "__hscore_setmode"
+  setmode :: CInt -> Bool -> IO CInt
+#endif
+
 -- -----------------------------------------------------------------------------
 -- Standard file descriptors
 
diff --git a/GHC/IO/Handle/FD.hs b/GHC/IO/Handle/FD.hs
index a2a3d14..ec215ec 100644
--- a/GHC/IO/Handle/FD.hs
+++ b/GHC/IO/Handle/FD.hs
@@ -53,6 +53,7 @@ import qualified System.Posix.Internals as Posix
 stdin :: Handle
 stdin = unsafePerformIO $ do
    -- ToDo: acquire lock
+   setBinaryMode FD.stdin
    mkHandle FD.stdin "<stdin>" ReadHandle True (Just localeEncoding)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
@@ -61,6 +62,7 @@ stdin = unsafePerformIO $ do
 stdout :: Handle
 stdout = unsafePerformIO $ do
    -- ToDo: acquire lock
+   setBinaryMode FD.stdout
    mkHandle FD.stdout "<stdout>" WriteHandle True (Just localeEncoding)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
@@ -69,6 +71,7 @@ stdout = unsafePerformIO $ do
 stderr :: Handle
 stderr = unsafePerformIO $ do
     -- ToDo: acquire lock
+   setBinaryMode FD.stderr
    mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-} 
                 (Just localeEncoding)
                 nativeNewlineMode{-translate newlines-}
@@ -80,6 +83,20 @@ stdHandleFinalizer fp m = do
   flushWriteBuffer h_
   putMVar m (ioe_finalizedHandle fp)
 
+-- We have to put the FDs into binary mode on Windows to avoid the newline
+-- translation that the CRT IO library does.
+setBinaryMode :: FD -> IO ()
+#ifdef mingw32_HOST_OS
+setBinaryMode fd = do setmode (fdFD fd) True; return ()
+#else
+setBinaryMode _ = return ()
+#endif
+
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "__hscore_setmode"
+  setmode :: CInt -> Bool -> IO CInt
+#endif
+
 -- ---------------------------------------------------------------------------
 -- isEOF