Big patch to improve Unicode support in GHC. Validated on OS X and Windows, this

[ghc-base.git] / GHC / IO / FD.hs

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 4c3e117..65ed913 100644 (file)
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -1,5 +1,13 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , BangPatterns
+           , ForeignFunctionInterface
+           , DeriveDataTypeable
+  #-}
+{-# OPTIONS_GHC -fno-warn-identities #-}
+-- Whether there are identities depends on the platform
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.FD
@@ -39,6 +47,9 @@ import qualified GHC.IO.Device
 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
 import GHC.Conc.IO
 import GHC.IO.Exception
+#ifdef mingw32_HOST_OS
+import GHC.Windows
+#endif
 
 import Foreign
 import Foreign.C
@@ -98,8 +109,15 @@ instance GHC.IO.Device.IODevice FD where
   dup           = dup
   dup2          = dup2
 
+-- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
+-- taken from the value of BUFSIZ on the current platform.  This value
+-- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
+-- on Linux.  So let's just use a decent size on every platform:
+dEFAULT_FD_BUFFER_SIZE :: Int
+dEFAULT_FD_BUFFER_SIZE = 8096
+
 instance BufferedIO FD where
-  newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
+  newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
   fillReadBuffer    fd buf = readBuf' fd buf
   fillReadBuffer0   fd buf = readBufNonBlocking fd buf
   flushWriteBuffer  fd buf = writeBuf' fd buf
@@ -124,10 +142,14 @@ writeBuf' fd buf = do
 -- opening files
 
 -- | Open a file and make an 'FD' for it.  Truncates the file to zero
--- size when the `IOMode` is `WriteMode`.  Puts the file descriptor
--- into non-blocking mode on Unix systems.
-openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
-openFile filepath iomode =
+-- size when the `IOMode` is `WriteMode`.
+openFile
+  :: FilePath -- ^ file to open
+  -> IOMode   -- ^ mode in which to open the file
+  -> Bool     -- ^ open the file in non-blocking mode?
+  -> IO (FD,IODeviceType)
+
+openFile filepath iomode non_blocking =
   withFilePath filepath $ \ f ->
 
     let 
@@ -147,7 +169,10 @@ openFile filepath iomode =
       binary_flags = 0
 #endif      
 
-      oflags = oflags1 .|. binary_flags
+      oflags2 = oflags1 .|. binary_flags
+
+      oflags | non_blocking = oflags2 .|. nonblock_flags
+             | otherwise    = oflags2
     in do
 
     -- the old implementation had a complicated series of three opens,
@@ -156,11 +181,12 @@ openFile filepath iomode =
     -- always returns EISDIR if the file is a directory and was opened
     -- for writing, so I think we're ok with a single open() here...
     fd <- throwErrnoIfMinus1Retry "openFile"
-                (c_open f oflags 0o666)
+                (if non_blocking then c_open      f oflags 0o666
+                                 else c_safe_open f oflags 0o666)
 
     (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                             False{-not a socket-} 
-                            True{-is non-blocking-}
+                            non_blocking
             `catchAny` \e -> do _ <- c_close fd
                                 throwIO e
 
@@ -176,13 +202,14 @@ openFile filepath iomode =
     return (fD,fd_type)
 
 std_flags, output_flags, read_flags, write_flags, rw_flags,
-    append_flags :: CInt
-std_flags    = o_NONBLOCK   .|. o_NOCTTY
+    append_flags, nonblock_flags :: CInt
+std_flags    = o_NOCTTY
 output_flags = std_flags    .|. o_CREAT
 read_flags   = std_flags    .|. o_RDONLY 
 write_flags  = output_flags .|. o_WRONLY
 rw_flags     = output_flags .|. o_RDWR
 append_flags = write_flags  .|. o_APPEND
+nonblock_flags = o_NONBLOCK
 
 
 -- | Make a 'FD' from an existing file descriptor.  Fails if the FD
@@ -278,15 +305,17 @@ stderr = stdFD 2
 close :: FD -> IO ()
 close fd =
 #ifndef mingw32_HOST_OS
-  (flip finally) (release fd) $ do
+  (flip finally) (release fd) $
 #endif
-  throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
+  do let closer realFd =
+           throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 #ifdef mingw32_HOST_OS
-    if fdIsSocket fd then
-       c_closesocket (fdFD fd)
-    else
+           if fdIsSocket fd then
+             c_closesocket (fromIntegral realFd)
+           else
 #endif
-       c_close (fdFD fd)
+             c_close (fromIntegral realFd)
+     closeFdWith closer (fromIntegral (fdFD fd))
 
 release :: FD -> IO ()
 #ifdef mingw32_HOST_OS
@@ -395,13 +424,14 @@ setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
 
 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
 fdRead fd ptr bytes
-  = readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
+  = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
+       ; return (fromIntegral r) }
 
 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
 fdReadNonBlocking fd ptr bytes = do
   r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr 
            0 (fromIntegral bytes)
-  case r of
+  case fromIntegral r of
     (-1) -> return (Nothing)
     n    -> return (Just n)
 
@@ -592,9 +622,6 @@ blockingWriteRawBufferPtr loc fd buf off len
       -- for this case.  We need to detect EPIPE correctly, because it
       -- shouldn't be reported as an error when it happens on stdout.
 
-foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
-   c_maperrno :: IO ()
-
 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 -- These calls may block, but that's ok.
 
@@ -637,8 +664,3 @@ foreign import ccall unsafe "lockFile"
 foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt
 #endif
-
-puts :: String -> IO ()
-puts s = do _ <- withCStringLen s $ \(p,len) ->
-                     c_write 1 (castPtr p) (fromIntegral len)
-            return ()