projects
/
ghc-base.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
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
a54dd52
..
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
import GHC.Show
import GHC.Enum
import Data.Maybe
+#ifndef mingw32_HOST_OS
import Control.Monad
import Control.Monad
+#endif
import Data.Typeable
import GHC.IO
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 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
-- -----------------------------------------------------------------------------
-- The file-descriptor IO device
@@
-115,7
+117,7
@@
readBuf' fd buf = do
#endif
return (r,buf')
#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")
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-}
(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
#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
_ -> 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
#endif
case fd_type of
@@
-247,6
+251,11
@@
mkFD fd iomode mb_stat is_socket is_nonblock = do
},
fd_type)
},
fd_type)
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "__hscore_setmode"
+ setmode :: CInt -> Bool -> IO CInt
+#endif
+
-- -----------------------------------------------------------------------------
-- Standard file descriptors
-- -----------------------------------------------------------------------------
-- Standard file descriptors
@@
-284,12
+293,12
@@
close fd =
c_close (fdFD fd)
release :: FD -> IO ()
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
#endif
- let _ = fd -- warning suppression
- return ()
#ifdef mingw32_HOST_OS
foreign import stdcall unsafe "HsBase.h closesocket"
#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
seek :: FD -> SeekMode -> Integer -> IO ()
seek fd mode off = do
- throwErrnoIfMinus1Retry "seek" $
+ throwErrnoIfMinus1Retry_ "seek" $
c_lseek (fdFD fd) (fromIntegral off) seektype
c_lseek (fdFD fd) (fromIntegral off) seektype
- return ()
where
seektype :: CInt
seektype = case mode of
where
seektype :: CInt
seektype = case mode of
@@
-324,9
+332,8
@@
getSize fd = fdFileSize (fdFD fd)
setSize :: FD -> Integer -> IO ()
setSize fd size = do
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)
c_ftruncate (fdFD fd) (fromIntegral size)
- return ()
devType :: FD -> IO IODeviceType
devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
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
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
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
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
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
else return ()
-- XXX ToDo: this isn't non-blocking
@@
-447,7
+460,7
@@
indicates that there's no data, we call threadWaitRead.
-}
-}
-readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtr loc !fd buf off len
| isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- throwErrnoIfMinus1 loc
readRawBufferPtr loc !fd buf off len
| isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- throwErrnoIfMinus1 loc
@@
-456,14
+469,15
@@
readRawBufferPtr loc !fd buf off len
then read
else do threadWaitRead (fromIntegral (fdFD fd)); read
where
then read
else do threadWaitRead (fromIntegral (fdFD fd)); read
where
- do_read call = throwErrnoIfMinus1RetryMayBlock loc call
+ do_read call = fromIntegral `fmap`
+ throwErrnoIfMinus1RetryMayBlock loc call
(threadWaitRead (fromIntegral (fdFD fd)))
read = if threaded then safe_read else unsafe_read
(threadWaitRead (fromIntegral (fdFD fd)))
read = if threaded then safe_read else unsafe_read
- unsafe_read = do_read (read_off (fdFD fd) buf off len)
- safe_read = do_read (safe_read_off (fdFD fd) buf off len)
+ unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
+ safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
-- return: -1 indicates EOF, >=0 is bytes read
-- return: -1 indicates EOF, >=0 is bytes read
-readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtrNoBlock loc !fd buf off len
| isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
readRawBufferPtrNoBlock loc !fd buf off len
| isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
@@
-475,11
+489,11
@@
readRawBufferPtrNoBlock loc !fd buf off len
case r of
(-1) -> return 0
0 -> return (-1)
case r of
(-1) -> return 0
0 -> return (-1)
- n -> return n
- unsafe_read = do_read (read_off (fdFD fd) buf off len)
- safe_read = do_read (safe_read_off (fdFD fd) buf off len)
+ n -> return (fromIntegral n)
+ unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
+ safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
-writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd buf off len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
writeRawBufferPtr loc !fd buf off len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
@@
-487,13
+501,14
@@
writeRawBufferPtr loc !fd buf off len
then write
else do threadWaitWrite (fromIntegral (fdFD fd)); write
where
then write
else do threadWaitWrite (fromIntegral (fdFD fd)); write
where
- do_write call = throwErrnoIfMinus1RetryMayBlock loc call
+ do_write call = fromIntegral `fmap`
+ throwErrnoIfMinus1RetryMayBlock loc call
(threadWaitWrite (fromIntegral (fdFD fd)))
write = if threaded then safe_write else unsafe_write
(threadWaitWrite (fromIntegral (fdFD fd)))
write = if threaded then safe_write else unsafe_write
- unsafe_write = do_write (write_off (fdFD fd) buf off len)
- safe_write = do_write (safe_write_off (fdFD fd) buf off len)
+ unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
+ safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
-writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock loc !fd buf off len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
writeRawBufferPtrNoBlock loc !fd buf off len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
@@
-503,44
+518,38
@@
writeRawBufferPtrNoBlock loc !fd buf off len
do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
case r of
(-1) -> return 0
do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
case r of
(-1) -> return 0
- n -> return n
+ n -> return (fromIntegral n)
write = if threaded then safe_write else unsafe_write
write = if threaded then safe_write else unsafe_write
- unsafe_write = do_write (write_off (fdFD fd) buf off len)
- safe_write = do_write (safe_write_off (fdFD fd) buf off len)
+ unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
+ safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0
isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0
-foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
-
foreign import ccall unsafe "fdReady"
unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
#else /* mingw32_HOST_OS.... */
foreign import ccall unsafe "fdReady"
unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
#else /* mingw32_HOST_OS.... */
-readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtr loc !fd buf off len
| threaded = blockingReadRawBufferPtr loc fd buf off len
| otherwise = asyncReadRawBufferPtr loc fd buf off len
readRawBufferPtr loc !fd buf off len
| threaded = blockingReadRawBufferPtr loc fd buf off len
| otherwise = asyncReadRawBufferPtr loc fd buf off len
-writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd buf off len
| threaded = blockingWriteRawBufferPtr loc fd buf off len
| otherwise = asyncWriteRawBufferPtr loc fd buf off len
writeRawBufferPtr loc !fd buf off len
| threaded = blockingWriteRawBufferPtr loc fd buf off len
| otherwise = asyncWriteRawBufferPtr loc fd buf off len
-readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtrNoBlock = readRawBufferPtr
readRawBufferPtrNoBlock = readRawBufferPtr
-writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock = writeRawBufferPtr
-- Async versions of the read/write primitives, for the non-threaded RTS
writeRawBufferPtrNoBlock = writeRawBufferPtr
-- Async versions of the read/write primitives, for the non-threaded RTS
-asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncReadRawBufferPtr loc !fd buf off len = do
(l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off)
asyncReadRawBufferPtr loc !fd buf off len = do
(l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off)
@@
-549,7
+558,7
@@
asyncReadRawBufferPtr loc !fd buf off len = do
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
else return (fromIntegral l)
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
else return (fromIntegral l)
-asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncWriteRawBufferPtr loc !fd buf off len = do
(l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off)
asyncWriteRawBufferPtr loc !fd buf off len = do
(l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off)
@@
-560,48
+569,42
@@
asyncWriteRawBufferPtr loc !fd buf off len = do
-- Blocking versions of the read/write primitives, for the threaded RTS
-- Blocking versions of the read/write primitives, for the threaded RTS
-blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr loc fd buf off len
blockingReadRawBufferPtr loc fd buf off len
- = throwErrnoIfMinus1Retry loc $
+ = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
if fdIsSocket fd
if fdIsSocket fd
- then safe_recv_off (fdFD fd) buf off len
- else safe_read_off (fdFD fd) buf off len
+ then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
+ else c_safe_read (fdFD fd) (buf `plusPtr` off) len
-blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CInt -> IO CInt
+blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr loc fd buf off len
blockingWriteRawBufferPtr loc fd buf off len
- = throwErrnoIfMinus1Retry loc $
+ = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
if fdIsSocket fd
if fdIsSocket fd
- then safe_send_off (fdFD fd) buf off len
- else safe_write_off (fdFD fd) buf off len
+ then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
+ else c_safe_write (fdFD fd) (buf `plusPtr` off) len
-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.
-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.
-foreign import ccall safe "__hscore_PrelHandle_recv"
- safe_recv_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+foreign import stdcall safe "recv"
+ c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
-foreign import ccall safe "__hscore_PrelHandle_send"
- safe_send_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+foreign import stdcall safe "send"
+ c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
#endif
foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
#endif
foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
-foreign import ccall safe "__hscore_PrelHandle_read"
- safe_read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_write"
- safe_write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
-
-- -----------------------------------------------------------------------------
-- utils
#ifndef mingw32_HOST_OS
-- -----------------------------------------------------------------------------
-- utils
#ifndef mingw32_HOST_OS
-throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
+throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
throwErrnoIfMinus1RetryOnBlock loc f on_block =
do
res <- f
throwErrnoIfMinus1RetryOnBlock loc f on_block =
do
res <- f
- if (res :: CInt) == -1
+ if (res :: CSsize) == -1
then do
err <- getErrno
if err == eINTR
then do
err <- getErrno
if err == eINTR