4 , ForeignFunctionInterface
7 {-# OPTIONS_GHC -fno-warn-identities #-}
8 -- Whether there are identities depends on the platform
9 {-# OPTIONS_HADDOCK hide #-}
11 -----------------------------------------------------------------------------
14 -- Copyright : (c) The University of Glasgow, 1994-2008
15 -- License : see libraries/base/LICENSE
17 -- Maintainer : libraries@haskell.org
18 -- Stability : internal
19 -- Portability : non-portable
21 -- Raw read/write operations on file descriptors
23 -----------------------------------------------------------------------------
27 openFile, mkFD, release,
29 readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
45 import GHC.IO.BufferedIO
46 import qualified GHC.IO.Device
47 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
49 import GHC.IO.Exception
50 #ifdef mingw32_HOST_OS
56 import qualified System.Posix.Internals
57 import System.Posix.Internals hiding (FD, setEcho, getEcho)
58 import System.Posix.Types
64 -- -----------------------------------------------------------------------------
65 -- The file-descriptor IO device
68 fdFD :: {-# UNPACK #-} !CInt,
69 #ifdef mingw32_HOST_OS
70 -- On Windows, a socket file descriptor needs to be read and written
71 -- using different functions (send/recv).
72 fdIsSocket_ :: {-# UNPACK #-} !Int
74 -- On Unix we need to know whether this FD has O_NONBLOCK set.
75 -- If it has, then we can use more efficient routines to read/write to it.
76 -- It is always safe for this to be off.
77 fdIsNonBlocking :: {-# UNPACK #-} !Int
82 #ifdef mingw32_HOST_OS
83 fdIsSocket :: FD -> Bool
84 fdIsSocket fd = fdIsSocket_ fd /= 0
87 instance Show FD where
88 show fd = show (fdFD fd)
90 instance GHC.IO.Device.RawIO FD where
92 readNonBlocking = fdReadNonBlocking
94 writeNonBlocking = fdWriteNonBlocking
96 instance GHC.IO.Device.IODevice FD where
99 isTerminal = isTerminal
100 isSeekable = isSeekable
112 -- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
113 -- taken from the value of BUFSIZ on the current platform. This value
114 -- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
115 -- on Linux. So let's just use a decent size on every platform:
116 dEFAULT_FD_BUFFER_SIZE :: Int
117 dEFAULT_FD_BUFFER_SIZE = 8096
119 instance BufferedIO FD where
120 newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
121 fillReadBuffer fd buf = readBuf' fd buf
122 fillReadBuffer0 fd buf = readBufNonBlocking fd buf
123 flushWriteBuffer fd buf = writeBuf' fd buf
124 flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
126 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
129 puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
130 (r,buf') <- readBuf fd buf
132 puts ("after: " ++ summaryBuffer buf' ++ "\n")
135 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
136 writeBuf' fd buf = do
138 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
141 -- -----------------------------------------------------------------------------
144 -- | Open a file and make an 'FD' for it. Truncates the file to zero
145 -- size when the `IOMode` is `WriteMode`.
147 :: FilePath -- ^ file to open
148 -> IOMode -- ^ mode in which to open the file
149 -> Bool -- ^ open the file in non-blocking mode?
150 -> IO (FD,IODeviceType)
152 openFile filepath iomode non_blocking =
153 withFilePath filepath $ \ f ->
156 oflags1 = case iomode of
157 ReadMode -> read_flags
158 #ifdef mingw32_HOST_OS
159 WriteMode -> write_flags .|. o_TRUNC
161 WriteMode -> write_flags
163 ReadWriteMode -> rw_flags
164 AppendMode -> append_flags
166 #ifdef mingw32_HOST_OS
167 binary_flags = o_BINARY
172 oflags2 = oflags1 .|. binary_flags
174 oflags | non_blocking = oflags2 .|. nonblock_flags
175 | otherwise = oflags2
178 -- the old implementation had a complicated series of three opens,
179 -- which is perhaps because we have to be careful not to open
180 -- directories. However, the man pages I've read say that open()
181 -- always returns EISDIR if the file is a directory and was opened
182 -- for writing, so I think we're ok with a single open() here...
183 fd <- throwErrnoIfMinus1Retry "openFile"
184 (if non_blocking then c_open f oflags 0o666
185 else c_safe_open f oflags 0o666)
187 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
188 False{-not a socket-}
190 `catchAny` \e -> do _ <- c_close fd
193 #ifndef mingw32_HOST_OS
194 -- we want to truncate() if this is an open in WriteMode, but only
195 -- if the target is a RegularFile. ftruncate() fails on special files
197 if iomode == WriteMode && fd_type == RegularFile
204 std_flags, output_flags, read_flags, write_flags, rw_flags,
205 append_flags, nonblock_flags :: CInt
207 output_flags = std_flags .|. o_CREAT
208 read_flags = std_flags .|. o_RDONLY
209 write_flags = output_flags .|. o_WRONLY
210 rw_flags = output_flags .|. o_RDWR
211 append_flags = write_flags .|. o_APPEND
212 nonblock_flags = o_NONBLOCK
215 -- | Make a 'FD' from an existing file descriptor. Fails if the FD
216 -- refers to a directory. If the FD refers to a file, `mkFD` locks
217 -- the file according to the Haskell 98 single writer/multiple reader
218 -- locking semantics (this is why we need the `IOMode` argument too).
221 -> Maybe (IODeviceType, CDev, CIno)
222 -- the results of fdStat if we already know them, or we want
223 -- to prevent fdToHandle_stat from doing its own stat.
224 -- These are used for:
225 -- - we fail if the FD refers to a directory
226 -- - if the FD refers to a file, we lock it using (cdev,cino)
227 -> Bool -- ^ is a socket (on Windows)
228 -> Bool -- ^ is in non-blocking mode on Unix
229 -> IO (FD,IODeviceType)
231 mkFD fd iomode mb_stat is_socket is_nonblock = do
233 let _ = (is_socket, is_nonblock) -- warning suppression
238 Just stat -> return stat
240 let write = case iomode of
244 #ifdef mingw32_HOST_OS
245 _ <- setmode fd True -- unconditionally set binary mode
246 let _ = (dev,ino,write) -- warning suppression
251 ioException (IOError Nothing InappropriateType "openFile"
252 "is a directory" Nothing Nothing)
254 #ifndef mingw32_HOST_OS
255 -- regular files need to be locked
257 -- On Windows we use explicit exclusion via sopen() to implement
258 -- this locking (see __hscore_open()); on Unix we have to
259 -- implment it in the RTS.
260 r <- lockFile fd dev ino (fromBool write)
262 ioException (IOError Nothing ResourceBusy "openFile"
263 "file is locked" Nothing Nothing)
266 _other_type -> return ()
268 return (FD{ fdFD = fd,
269 #ifndef mingw32_HOST_OS
270 fdIsNonBlocking = fromEnum is_nonblock
272 fdIsSocket_ = fromEnum is_socket
277 #ifdef mingw32_HOST_OS
278 foreign import ccall unsafe "__hscore_setmode"
279 setmode :: CInt -> Bool -> IO CInt
282 -- -----------------------------------------------------------------------------
283 -- Standard file descriptors
286 stdFD fd = FD { fdFD = fd,
287 #ifdef mingw32_HOST_OS
291 -- We don't set non-blocking mode on standard handles, because it may
292 -- confuse other applications attached to the same TTY/pipe
293 -- see Note [nonblock]
297 stdin, stdout, stderr :: FD
302 -- -----------------------------------------------------------------------------
303 -- Operations on file descriptors
307 #ifndef mingw32_HOST_OS
308 (flip finally) (release fd) $
310 do let closer realFd =
311 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
312 #ifdef mingw32_HOST_OS
313 if fdIsSocket fd then
314 c_closesocket (fromIntegral realFd)
317 c_close (fromIntegral realFd)
318 closeFdWith closer (fromIntegral (fdFD fd))
320 release :: FD -> IO ()
321 #ifdef mingw32_HOST_OS
322 release _ = return ()
324 release fd = do _ <- unlockFile (fdFD fd)
328 #ifdef mingw32_HOST_OS
329 foreign import stdcall unsafe "HsBase.h closesocket"
330 c_closesocket :: CInt -> IO CInt
333 isSeekable :: FD -> IO Bool
336 return (t == RegularFile || t == RawDevice)
338 seek :: FD -> SeekMode -> Integer -> IO ()
339 seek fd mode off = do
340 throwErrnoIfMinus1Retry_ "seek" $
341 c_lseek (fdFD fd) (fromIntegral off) seektype
344 seektype = case mode of
345 AbsoluteSeek -> sEEK_SET
346 RelativeSeek -> sEEK_CUR
347 SeekFromEnd -> sEEK_END
349 tell :: FD -> IO Integer
352 (throwErrnoIfMinus1Retry "hGetPosn" $
353 c_lseek (fdFD fd) 0 sEEK_CUR)
355 getSize :: FD -> IO Integer
356 getSize fd = fdFileSize (fdFD fd)
358 setSize :: FD -> Integer -> IO ()
360 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
361 c_ftruncate (fdFD fd) (fromIntegral size)
363 devType :: FD -> IO IODeviceType
364 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
368 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
369 return fd{ fdFD = newfd }
371 dup2 :: FD -> FD -> IO FD
373 -- Windows' dup2 does not return the new descriptor, unlike Unix
374 throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
375 c_dup2 (fdFD fd) (fdFD fdto)
376 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
378 setNonBlockingMode :: FD -> Bool -> IO FD
379 setNonBlockingMode fd set = do
380 setNonBlockingFD (fdFD fd) set
381 #if defined(mingw32_HOST_OS)
384 return fd{ fdIsNonBlocking = fromEnum set }
387 ready :: FD -> Bool -> Int -> IO Bool
388 ready fd write msecs = do
389 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
390 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
392 #if defined(mingw32_HOST_OS)
393 (fromIntegral $ fromEnum $ fdIsSocket fd)
397 return (toEnum (fromIntegral r))
399 foreign import ccall safe "fdReady"
400 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
402 -- ---------------------------------------------------------------------------
403 -- Terminal-related stuff
405 isTerminal :: FD -> IO Bool
407 #if defined(mingw32_HOST_OS)
408 is_console (fdFD fd) >>= return.toBool
410 c_isatty (fdFD fd) >>= return.toBool
413 setEcho :: FD -> Bool -> IO ()
414 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
416 getEcho :: FD -> IO Bool
417 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
419 setRaw :: FD -> Bool -> IO ()
420 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
422 -- -----------------------------------------------------------------------------
423 -- Reading and Writing
425 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
427 = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
428 ; return (fromIntegral r) }
430 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
431 fdReadNonBlocking fd ptr bytes = do
432 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
433 0 (fromIntegral bytes)
434 case fromIntegral r of
435 (-1) -> return (Nothing)
439 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
440 fdWrite fd ptr bytes = do
441 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
442 let res' = fromIntegral res
444 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
447 -- XXX ToDo: this isn't non-blocking
448 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
449 fdWriteNonBlocking fd ptr bytes = do
450 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
452 return (fromIntegral res)
454 -- -----------------------------------------------------------------------------
457 -- Low level routines for reading/writing to (raw)buffers:
459 #ifndef mingw32_HOST_OS
464 Unix has broken semantics when it comes to non-blocking I/O: you can
465 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
466 attached to the same underlying file, pipe or TTY; there's no way to
467 have private non-blocking behaviour for an FD. See bug #724.
469 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
470 come from external sources or are exposed externally are left in
471 blocking mode. This solution has some problems though. We can't
472 completely simulate a non-blocking read without O_NONBLOCK: several
473 cases are wrong here. The cases that are wrong:
475 * reading/writing to a blocking FD in non-threaded mode.
476 In threaded mode, we just make a safe call to read().
477 In non-threaded mode we call select() before attempting to read,
478 but that leaves a small race window where the data can be read
479 from the file descriptor before we issue our blocking read().
480 * readRawBufferNoBlock for a blocking FD
484 In the threaded RTS we could just make safe calls to read()/write()
485 for file descriptors in blocking mode without worrying about blocking
486 other threads, but the problem with this is that the thread will be
487 uninterruptible while it is blocked in the foreign call. See #2363.
488 So now we always call fdReady() before reading, and if fdReady
489 indicates that there's no data, we call threadWaitRead.
493 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
494 readRawBufferPtr loc !fd buf off len
495 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
496 | otherwise = do r <- throwErrnoIfMinus1 loc
497 (unsafe_fdReady (fdFD fd) 0 0 0)
500 else do threadWaitRead (fromIntegral (fdFD fd)); read
502 do_read call = fromIntegral `fmap`
503 throwErrnoIfMinus1RetryMayBlock loc call
504 (threadWaitRead (fromIntegral (fdFD fd)))
505 read = if threaded then safe_read else unsafe_read
506 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
507 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
509 -- return: -1 indicates EOF, >=0 is bytes read
510 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
511 readRawBufferPtrNoBlock loc !fd buf off len
512 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
513 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
514 if r /= 0 then safe_read
516 -- XXX see note [nonblock]
518 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
522 n -> return (fromIntegral n)
523 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
524 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
526 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
527 writeRawBufferPtr loc !fd buf off len
528 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
529 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
532 else do threadWaitWrite (fromIntegral (fdFD fd)); write
534 do_write call = fromIntegral `fmap`
535 throwErrnoIfMinus1RetryMayBlock loc call
536 (threadWaitWrite (fromIntegral (fdFD fd)))
537 write = if threaded then safe_write else unsafe_write
538 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
539 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
541 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
542 writeRawBufferPtrNoBlock loc !fd buf off len
543 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
544 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
548 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
551 n -> return (fromIntegral n)
552 write = if threaded then safe_write else unsafe_write
553 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
554 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
556 isNonBlocking :: FD -> Bool
557 isNonBlocking fd = fdIsNonBlocking fd /= 0
559 foreign import ccall unsafe "fdReady"
560 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
562 #else /* mingw32_HOST_OS.... */
564 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
565 readRawBufferPtr loc !fd buf off len
566 | threaded = blockingReadRawBufferPtr loc fd buf off len
567 | otherwise = asyncReadRawBufferPtr loc fd buf off len
569 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
570 writeRawBufferPtr loc !fd buf off len
571 | threaded = blockingWriteRawBufferPtr loc fd buf off len
572 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
574 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
575 readRawBufferPtrNoBlock = readRawBufferPtr
577 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
578 writeRawBufferPtrNoBlock = writeRawBufferPtr
580 -- Async versions of the read/write primitives, for the non-threaded RTS
582 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
583 asyncReadRawBufferPtr loc !fd buf off len = do
584 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
585 (fromIntegral len) (buf `plusPtr` off)
588 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
589 else return (fromIntegral l)
591 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
592 asyncWriteRawBufferPtr loc !fd buf off len = do
593 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
594 (fromIntegral len) (buf `plusPtr` off)
597 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
598 else return (fromIntegral l)
600 -- Blocking versions of the read/write primitives, for the threaded RTS
602 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
603 blockingReadRawBufferPtr loc fd buf off len
604 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
606 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
607 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
609 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
610 blockingWriteRawBufferPtr loc fd buf off len
611 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
613 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
615 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
616 when (r == -1) c_maperrno
618 -- we don't trust write() to give us the correct errno, and
619 -- instead do the errno conversion from GetLastError()
620 -- ourselves. The main reason is that we treat ERROR_NO_DATA
621 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
622 -- for this case. We need to detect EPIPE correctly, because it
623 -- shouldn't be reported as an error when it happens on stdout.
625 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
626 -- These calls may block, but that's ok.
628 foreign import stdcall safe "recv"
629 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
631 foreign import stdcall safe "send"
632 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
636 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
638 -- -----------------------------------------------------------------------------
641 #ifndef mingw32_HOST_OS
642 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
643 throwErrnoIfMinus1RetryOnBlock loc f on_block =
646 if (res :: CSsize) == -1
650 then throwErrnoIfMinus1RetryOnBlock loc f on_block
651 else if err == eWOULDBLOCK || err == eAGAIN
657 -- -----------------------------------------------------------------------------
660 #ifndef mingw32_HOST_OS
661 foreign import ccall unsafe "lockFile"
662 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
664 foreign import ccall unsafe "unlockFile"
665 unlockFile :: CInt -> IO CInt