import GHC.Num ( Integer(..), Num(..) )
import GHC.Show
import GHC.Real ( toInteger )
+#if defined(DEBUG_DUMP)
+import GHC.Pack
+#endif
import GHC.Conc
puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
# endif
throwErrnoIfMinus1Retry "flushReadBuffer"
- (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
+ (c_lseek fd (fromIntegral off) sEEK_CUR)
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
if bytes == 0
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
- res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
+ res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
(fromIntegral r) (fromIntegral bytes)
let res' = fromIntegral res
if res' < bytes
-- buffer better be empty:
assert (r == 0 && w == 0) $ do
#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
+ puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
#endif
res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
0 (fromIntegral size)
writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
writeRawBuffer loc fd is_stream buf off len =
throwErrnoIfMinus1RetryMayBlock loc
- (write_rawBuffer (fromIntegral fd) buf off len)
+ (write_rawBuffer fd buf off len)
(threadWaitWrite (fromIntegral fd))
writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
writeRawBufferPtr loc fd is_stream buf off len =
throwErrnoIfMinus1RetryMayBlock loc
- (write_off (fromIntegral fd) buf off len)
+ (write_off fd buf off len)
(threadWaitWrite (fromIntegral fd))
foreign import ccall unsafe "__hscore_PrelHandle_read"
-- ToDo: we don't have a non-blocking primitve read on Win32
readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock = readRawBufferNoBlock
+readRawBufferNoBlock = readRawBuffer
-- Async versions of the read/write primitives, for the non-threaded RTS
blockingWriteRawBuffer loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- send_rawBuffer (fromIntegral fd) buf off len
+ send_rawBuffer fd buf off len
blockingWriteRawBuffer loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- write_rawBuffer (fromIntegral fd) buf off len
+ write_rawBuffer fd buf off len
blockingWriteRawBufferPtr loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- send_off (fromIntegral fd) buf off len
+ send_off fd buf off len
blockingWriteRawBufferPtr loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- write_off (fromIntegral fd) buf off len
+ write_off fd buf off len
-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.
-- directories. However, the man pages I've read say that open()
-- 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 <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "openFile"
+ fd <- throwErrnoIfMinus1Retry "openFile"
(c_open f (fromIntegral oflags) 0o666)
- h <- openFd fd Nothing False filepath mode binary
- `catchException` \e -> do c_close (fromIntegral fd); throw e
+ fd_type <- fdType fd
+
+ h <- openFd fd (Just fd_type) False filepath mode binary
+ `catchException` \e -> do c_close fd; throw e
-- NB. don't forget to close the FD if openFd fails, otherwise
-- this FD leaks.
-- ASSERT: if we just created the file, then openFd won't fail
-- (so we don't need to worry about removing the newly created file
-- in the event of an error).
+
#ifndef mingw32_HOST_OS
- if mode == WriteMode
+ -- we want to truncate() if this is an open in WriteMode, but only
+ -- if the target is a RegularFile. ftruncate() fails on special files
+ -- like /dev/null.
+ if mode == WriteMode && fd_type == RegularFile
then throwErrnoIf (/=0) "openFile"
- (c_ftruncate (fromIntegral fd) 0)
+ (c_ftruncate fd 0)
else return 0
#endif
return h
then findTempName (x+1)
else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
else do
- h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True
- `catchException` \e -> do c_close (fromIntegral fd); throw e
+ h <- openFd fd Nothing False filepath ReadWriteMode True
+ `catchException` \e -> do c_close fd; throw e
return (filepath, h)
where
filename = prefix ++ show x ++ suffix
ioException (IOError Nothing InappropriateType "openFile"
"is a directory" Nothing)
- Stream
- | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
- | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
-
-- regular files need to be locked
RegularFile -> do
#ifndef mingw32_HOST_OS
- r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
+ r <- lockFile fd (fromBool write) 1{-exclusive-}
when (r == -1) $
ioException (IOError Nothing ResourceBusy "openFile"
"file is locked" Nothing)
#endif
mkFileHandle fd is_socket filepath ha_type binary
+ Stream
+ -- only *Streams* can be DuplexHandles. Other read/write
+ -- Handles must share a buffer.
+ | ReadWriteHandle <- ha_type ->
+ mkDuplexHandle fd is_socket filepath binary
+ | otherwise ->
+ mkFileHandle fd is_socket filepath ha_type binary
+
+ RawDevice ->
+ mkFileHandle fd is_socket filepath ha_type binary
fdToHandle :: FD -> IO Handle
fdToHandle fd = do
mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd is_stream filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
+
+#ifdef mingw32_HOST_OS
+ -- On Windows, if this is a read/write handle and we are in text mode,
+ -- turn off buffering. We don't correctly handle the case of switching
+ -- from read mode to write mode on a buffered text-mode handle, see bug
+ -- \#679.
+ bmode <- case ha_type of
+ ReadWriteHandle | not binary -> return NoBuffering
+ _other -> return bmode
+#endif
+
spares <- newIORef BufferListNil
newFileHandle filepath (handleFinalizer filepath)
(Handle__ { haFD = fd,
hClose_handle_ handle_ = do
let fd = haFD handle_
- c_fd = fromIntegral fd
-- close the file descriptor, but not when this is the read
-- side of a duplex handle.
Nothing ->
throwErrnoIfMinus1Retry_ "hClose"
#ifdef mingw32_HOST_OS
- (closeFd (haIsStream handle_) c_fd)
+ (closeFd (haIsStream handle_) fd)
#else
- (c_close c_fd)
+ (c_close fd)
#endif
Just _ -> return ()
#ifndef mingw32_HOST_OS
-- unlock it
- unlockFile c_fd
+ unlockFile fd
#endif
-- we must set the fd to -1, because the finalizer is going
SemiClosedHandle -> ioe_closedHandle
_ -> do flushWriteBufferOnly handle_
throwErrnoIf (/=0) "hSetFileSize"
- (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
+ (c_ftruncate (haFD handle_) (fromIntegral size))
return ()
-- ---------------------------------------------------------------------------
-- fill up the read buffer if necessary
new_buf <- if bufferEmpty buf
- then fillReadBuffer fd is_line (haIsStream handle_) buf
+ then fillReadBuffer fd True (haIsStream handle_) buf
else return buf
writeIORef ref new_buf
-- 'raw' mode under win32 is a bit too specialised (and troublesome
-- for most common uses), so simply disable its use here.
NoBuffering -> setCooked (haFD handle_) False
+#else
+ NoBuffering -> return ()
#endif
_ -> setCooked (haFD handle_) True
let do_seek =
throwErrnoIfMinus1Retry_ "hSeek"
- (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+ (c_lseek (haFD handle_) (fromIntegral offset) whence)
whence :: CInt
whence = case mode of
-- current buffer size. Just flush instead.
flushBuffer handle_
#endif
- let fd = fromIntegral (haFD handle_)
+ let fd = haFD handle_
posn <- fromIntegral `liftM`
throwErrnoIfMinus1Retry "hGetPosn"
(c_lseek fd 0 sEEK_CUR)
SemiClosedHandle -> ioe_closedHandle
AppendHandle -> return False
_ -> do t <- fdType (haFD handle_)
- return (t == RegularFile
- && (haIsBin handle_
- || tEXT_MODE_SEEK_ALLOWED))
+ return ((t == RegularFile || t == RawDevice)
+ && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
-- -----------------------------------------------------------------------------
-- Changing echo status (Non-standard GHC extensions)
hSetBinaryMode handle bin =
withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
do throwErrnoIfMinus1_ "hSetBinaryMode"
- (setmode (fromIntegral (haFD handle_)) bin)
+ (setmode (haFD handle_) bin)
return handle_{haIsBin=bin}
foreign import ccall unsafe "__hscore_setmode"
-- flush the buffer first, so we don't have to copy its contents
flushBuffer h_
new_fd <- throwErrnoIfMinus1 "dupHandle" $
- c_dup (fromIntegral (haFD h_))
+ c_dup (haFD h_)
dupHandle_ other_side h_ new_fd
dupHandleTo other_side hto_ h_ = do
flushBuffer h_
- new_fd <- throwErrnoIfMinus1 "dupHandleTo" $
- c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_))
- dupHandle_ other_side h_ new_fd
+ -- Windows' dup2 does not return the new descriptor, unlike Unix
+ throwErrnoIfMinus1 "dupHandleTo" $
+ c_dup2 (haFD h_) (haFD hto_)
+ dupHandle_ other_side h_ (haFD hto_)
+dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
+ -> IO (Handle__, Handle__)
dupHandle_ other_side h_ new_fd = do
buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
ioref <- newIORef buffer
ioref_buffers <- newIORef BufferListNil
- let new_handle_ = h_{ haFD = fromIntegral new_fd,
+ let new_handle_ = h_{ haFD = new_fd,
haBuffer = ioref,
haBuffers = ioref_buffers,
haOtherSide = other_side }
-- ---------------------------------------------------------------------------
-- debugging
-#ifdef DEBUG_DUMP
+#if defined(DEBUG_DUMP)
puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
- return ()
+puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
+ return ()
#endif
-- -----------------------------------------------------------------------------
projects / ghc-base.git / blobdiff