Tweak the BufferedIO class to enable a memory-mapped file implementation

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

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 76c0242..98eeeab 100644 (file)
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -30,7 +30,9 @@ import GHC.Real
 import GHC.Show
 import GHC.Enum
 import Data.Maybe
+#ifndef mingw32_HOST_OS
 import Control.Monad
+#endif
 import Data.Typeable
 
 import GHC.IO
@@ -47,7 +49,7 @@ import Foreign.C
 import qualified System.Posix.Internals
 import System.Posix.Internals hiding (FD, setEcho, getEcho)
 import System.Posix.Types
-import GHC.Ptr
+-- import GHC.Ptr
 
 -- -----------------------------------------------------------------------------
 -- The file-descriptor IO device
@@ -115,7 +117,7 @@ readBuf' fd buf = do
 #endif
   return (r,buf')
 
-writeBuf' :: FD -> Buffer Word8 -> IO ()
+writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
 writeBuf' fd buf = do
 #ifdef DEBUG_DUMP
   puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
@@ -163,7 +165,8 @@ openFile filepath iomode =
     (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                             False{-not a socket-} 
                             True{-is non-blocking-}
-            `catchAny` \e -> do c_close fd; throwIO e
+            `catchAny` \e -> do _ <- c_close fd
+                                throwIO e
 
 #ifndef mingw32_HOST_OS
         -- we want to truncate() if this is an open in WriteMode, but only
@@ -216,7 +219,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 +251,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
 
@@ -284,12 +293,12 @@ close fd =
        c_close (fdFD fd)
 
 release :: FD -> IO ()
-release fd = do
-#ifndef mingw32_HOST_OS
-   unlockFile (fdFD fd)
+#ifdef mingw32_HOST_OS
+release _ = return ()
+#else
+release fd = do _ <- unlockFile (fdFD fd)
+                return ()
 #endif
-   let _ = fd -- warning suppression
-   return ()
 
 #ifdef mingw32_HOST_OS
 foreign import stdcall unsafe "HsBase.h closesocket"
@@ -303,9 +312,8 @@ isSeekable fd = do
 
 seek :: FD -> SeekMode -> Integer -> IO ()
 seek fd mode off = do
-  throwErrnoIfMinus1Retry "seek" $
+  throwErrnoIfMinus1Retry_ "seek" $
      c_lseek (fdFD fd) (fromIntegral off) seektype
-  return ()
  where
     seektype :: CInt
     seektype = case mode of
@@ -324,9 +332,8 @@ getSize fd = fdFileSize (fdFD fd)
 
 setSize :: FD -> Integer -> IO () 
 setSize fd size = do
-  throwErrnoIf (/=0) "GHC.IO.FD.setSize"  $
+  throwErrnoIf_ (/=0) "GHC.IO.FD.setSize"  $
      c_ftruncate (fdFD fd) (fromIntegral size)
-  return ()
 
 devType :: FD -> IO IODeviceType
 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
@@ -339,12 +346,18 @@ dup fd = do
 dup2 :: FD -> FD -> IO FD
 dup2 fd fdto = do
   -- Windows' dup2 does not return the new descriptor, unlike Unix
-  throwErrnoIfMinus1 "GHC.IO.FD.dup2" $ 
+  throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
     c_dup2 (fdFD fd) (fdFD fdto)
   return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
 
-setNonBlockingMode :: FD -> IO ()
-setNonBlockingMode fd = setNonBlockingFD (fdFD fd)
+setNonBlockingMode :: FD -> Bool -> IO FD
+setNonBlockingMode fd set = do 
+  setNonBlockingFD (fdFD fd) set
+#if defined(mingw32_HOST_OS)
+  return fd
+#else
+  return fd{ fdIsNonBlocking = fromEnum set }
+#endif
 
 ready :: FD -> Bool -> Int -> IO Bool
 ready fd write msecs = do
@@ -398,7 +411,7 @@ fdWrite fd ptr bytes = do
   res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
   let res' = fromIntegral res
   if res' < bytes 
-     then fdWrite fd (ptr `plusPtr` bytes) (bytes - res')
+     then fdWrite fd (ptr `plusPtr` res') (bytes - res')
      else return ()
 
 -- XXX ToDo: this isn't non-blocking