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
53 import qualified System.Posix.Internals
54 import System.Posix.Internals hiding (FD, setEcho, getEcho)
55 import System.Posix.Types
61 -- -----------------------------------------------------------------------------
62 -- The file-descriptor IO device
65 fdFD :: {-# UNPACK #-} !CInt,
66 #ifdef mingw32_HOST_OS
67 -- On Windows, a socket file descriptor needs to be read and written
68 -- using different functions (send/recv).
69 fdIsSocket_ :: {-# UNPACK #-} !Int
71 -- On Unix we need to know whether this FD has O_NONBLOCK set.
72 -- If it has, then we can use more efficient routines to read/write to it.
73 -- It is always safe for this to be off.
74 fdIsNonBlocking :: {-# UNPACK #-} !Int
79 #ifdef mingw32_HOST_OS
80 fdIsSocket :: FD -> Bool
81 fdIsSocket fd = fdIsSocket_ fd /= 0
84 instance Show FD where
85 show fd = show (fdFD fd)
87 instance GHC.IO.Device.RawIO FD where
89 readNonBlocking = fdReadNonBlocking
91 writeNonBlocking = fdWriteNonBlocking
93 instance GHC.IO.Device.IODevice FD where
96 isTerminal = isTerminal
97 isSeekable = isSeekable
109 -- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
110 -- taken from the value of BUFSIZ on the current platform. This value
111 -- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
112 -- on Linux. So let's just use a decent size on every platform:
113 dEFAULT_FD_BUFFER_SIZE :: Int
114 dEFAULT_FD_BUFFER_SIZE = 8096
116 instance BufferedIO FD where
117 newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
118 fillReadBuffer fd buf = readBuf' fd buf
119 fillReadBuffer0 fd buf = readBufNonBlocking fd buf
120 flushWriteBuffer fd buf = writeBuf' fd buf
121 flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
123 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
126 puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
127 (r,buf') <- readBuf fd buf
129 puts ("after: " ++ summaryBuffer buf' ++ "\n")
132 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
133 writeBuf' fd buf = do
135 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
138 -- -----------------------------------------------------------------------------
141 -- | Open a file and make an 'FD' for it. Truncates the file to zero
142 -- size when the `IOMode` is `WriteMode`. Puts the file descriptor
143 -- into non-blocking mode on Unix systems.
144 openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
145 openFile filepath iomode =
146 withFilePath filepath $ \ f ->
149 oflags1 = case iomode of
150 ReadMode -> read_flags
151 #ifdef mingw32_HOST_OS
152 WriteMode -> write_flags .|. o_TRUNC
154 WriteMode -> write_flags
156 ReadWriteMode -> rw_flags
157 AppendMode -> append_flags
159 #ifdef mingw32_HOST_OS
160 binary_flags = o_BINARY
165 oflags = oflags1 .|. binary_flags
168 -- the old implementation had a complicated series of three opens,
169 -- which is perhaps because we have to be careful not to open
170 -- directories. However, the man pages I've read say that open()
171 -- always returns EISDIR if the file is a directory and was opened
172 -- for writing, so I think we're ok with a single open() here...
173 fd <- throwErrnoIfMinus1Retry "openFile"
174 (c_open f oflags 0o666)
176 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
177 False{-not a socket-}
178 True{-is non-blocking-}
179 `catchAny` \e -> do _ <- c_close fd
182 #ifndef mingw32_HOST_OS
183 -- we want to truncate() if this is an open in WriteMode, but only
184 -- if the target is a RegularFile. ftruncate() fails on special files
186 if iomode == WriteMode && fd_type == RegularFile
193 std_flags, output_flags, read_flags, write_flags, rw_flags,
195 std_flags = o_NONBLOCK .|. o_NOCTTY
196 output_flags = std_flags .|. o_CREAT
197 read_flags = std_flags .|. o_RDONLY
198 write_flags = output_flags .|. o_WRONLY
199 rw_flags = output_flags .|. o_RDWR
200 append_flags = write_flags .|. o_APPEND
203 -- | Make a 'FD' from an existing file descriptor. Fails if the FD
204 -- refers to a directory. If the FD refers to a file, `mkFD` locks
205 -- the file according to the Haskell 98 single writer/multiple reader
206 -- locking semantics (this is why we need the `IOMode` argument too).
209 -> Maybe (IODeviceType, CDev, CIno)
210 -- the results of fdStat if we already know them, or we want
211 -- to prevent fdToHandle_stat from doing its own stat.
212 -- These are used for:
213 -- - we fail if the FD refers to a directory
214 -- - if the FD refers to a file, we lock it using (cdev,cino)
215 -> Bool -- ^ is a socket (on Windows)
216 -> Bool -- ^ is in non-blocking mode on Unix
217 -> IO (FD,IODeviceType)
219 mkFD fd iomode mb_stat is_socket is_nonblock = do
221 let _ = (is_socket, is_nonblock) -- warning suppression
226 Just stat -> return stat
228 let write = case iomode of
232 #ifdef mingw32_HOST_OS
233 _ <- setmode fd True -- unconditionally set binary mode
234 let _ = (dev,ino,write) -- warning suppression
239 ioException (IOError Nothing InappropriateType "openFile"
240 "is a directory" Nothing Nothing)
242 #ifndef mingw32_HOST_OS
243 -- regular files need to be locked
245 -- On Windows we use explicit exclusion via sopen() to implement
246 -- this locking (see __hscore_open()); on Unix we have to
247 -- implment it in the RTS.
248 r <- lockFile fd dev ino (fromBool write)
250 ioException (IOError Nothing ResourceBusy "openFile"
251 "file is locked" Nothing Nothing)
254 _other_type -> return ()
256 return (FD{ fdFD = fd,
257 #ifndef mingw32_HOST_OS
258 fdIsNonBlocking = fromEnum is_nonblock
260 fdIsSocket_ = fromEnum is_socket
265 #ifdef mingw32_HOST_OS
266 foreign import ccall unsafe "__hscore_setmode"
267 setmode :: CInt -> Bool -> IO CInt
270 -- -----------------------------------------------------------------------------
271 -- Standard file descriptors
274 stdFD fd = FD { fdFD = fd,
275 #ifdef mingw32_HOST_OS
279 -- We don't set non-blocking mode on standard handles, because it may
280 -- confuse other applications attached to the same TTY/pipe
281 -- see Note [nonblock]
285 stdin, stdout, stderr :: FD
290 -- -----------------------------------------------------------------------------
291 -- Operations on file descriptors
295 #ifndef mingw32_HOST_OS
296 (flip finally) (release fd) $
298 do let closer realFd =
299 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
300 #ifdef mingw32_HOST_OS
301 if fdIsSocket fd then
302 c_closesocket (fromIntegral realFd)
305 c_close (fromIntegral realFd)
306 closeFdWith closer (fromIntegral (fdFD fd))
308 release :: FD -> IO ()
309 #ifdef mingw32_HOST_OS
310 release _ = return ()
312 release fd = do _ <- unlockFile (fdFD fd)
316 #ifdef mingw32_HOST_OS
317 foreign import stdcall unsafe "HsBase.h closesocket"
318 c_closesocket :: CInt -> IO CInt
321 isSeekable :: FD -> IO Bool
324 return (t == RegularFile || t == RawDevice)
326 seek :: FD -> SeekMode -> Integer -> IO ()
327 seek fd mode off = do
328 throwErrnoIfMinus1Retry_ "seek" $
329 c_lseek (fdFD fd) (fromIntegral off) seektype
332 seektype = case mode of
333 AbsoluteSeek -> sEEK_SET
334 RelativeSeek -> sEEK_CUR
335 SeekFromEnd -> sEEK_END
337 tell :: FD -> IO Integer
340 (throwErrnoIfMinus1Retry "hGetPosn" $
341 c_lseek (fdFD fd) 0 sEEK_CUR)
343 getSize :: FD -> IO Integer
344 getSize fd = fdFileSize (fdFD fd)
346 setSize :: FD -> Integer -> IO ()
348 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
349 c_ftruncate (fdFD fd) (fromIntegral size)
351 devType :: FD -> IO IODeviceType
352 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
356 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
357 return fd{ fdFD = newfd }
359 dup2 :: FD -> FD -> IO FD
361 -- Windows' dup2 does not return the new descriptor, unlike Unix
362 throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
363 c_dup2 (fdFD fd) (fdFD fdto)
364 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
366 setNonBlockingMode :: FD -> Bool -> IO FD
367 setNonBlockingMode fd set = do
368 setNonBlockingFD (fdFD fd) set
369 #if defined(mingw32_HOST_OS)
372 return fd{ fdIsNonBlocking = fromEnum set }
375 ready :: FD -> Bool -> Int -> IO Bool
376 ready fd write msecs = do
377 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
378 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
380 #if defined(mingw32_HOST_OS)
381 (fromIntegral $ fromEnum $ fdIsSocket fd)
385 return (toEnum (fromIntegral r))
387 foreign import ccall safe "fdReady"
388 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
390 -- ---------------------------------------------------------------------------
391 -- Terminal-related stuff
393 isTerminal :: FD -> IO Bool
395 #if defined(mingw32_HOST_OS)
396 is_console (fdFD fd) >>= return.toBool
398 c_isatty (fdFD fd) >>= return.toBool
401 setEcho :: FD -> Bool -> IO ()
402 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
404 getEcho :: FD -> IO Bool
405 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
407 setRaw :: FD -> Bool -> IO ()
408 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
410 -- -----------------------------------------------------------------------------
411 -- Reading and Writing
413 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
415 = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
416 ; return (fromIntegral r) }
418 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
419 fdReadNonBlocking fd ptr bytes = do
420 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
421 0 (fromIntegral bytes)
422 case fromIntegral r of
423 (-1) -> return (Nothing)
427 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
428 fdWrite fd ptr bytes = do
429 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
430 let res' = fromIntegral res
432 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
435 -- XXX ToDo: this isn't non-blocking
436 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
437 fdWriteNonBlocking fd ptr bytes = do
438 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
440 return (fromIntegral res)
442 -- -----------------------------------------------------------------------------
445 -- Low level routines for reading/writing to (raw)buffers:
447 #ifndef mingw32_HOST_OS
452 Unix has broken semantics when it comes to non-blocking I/O: you can
453 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
454 attached to the same underlying file, pipe or TTY; there's no way to
455 have private non-blocking behaviour for an FD. See bug #724.
457 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
458 come from external sources or are exposed externally are left in
459 blocking mode. This solution has some problems though. We can't
460 completely simulate a non-blocking read without O_NONBLOCK: several
461 cases are wrong here. The cases that are wrong:
463 * reading/writing to a blocking FD in non-threaded mode.
464 In threaded mode, we just make a safe call to read().
465 In non-threaded mode we call select() before attempting to read,
466 but that leaves a small race window where the data can be read
467 from the file descriptor before we issue our blocking read().
468 * readRawBufferNoBlock for a blocking FD
472 In the threaded RTS we could just make safe calls to read()/write()
473 for file descriptors in blocking mode without worrying about blocking
474 other threads, but the problem with this is that the thread will be
475 uninterruptible while it is blocked in the foreign call. See #2363.
476 So now we always call fdReady() before reading, and if fdReady
477 indicates that there's no data, we call threadWaitRead.
481 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
482 readRawBufferPtr loc !fd buf off len
483 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
484 | otherwise = do r <- throwErrnoIfMinus1 loc
485 (unsafe_fdReady (fdFD fd) 0 0 0)
488 else do threadWaitRead (fromIntegral (fdFD fd)); read
490 do_read call = fromIntegral `fmap`
491 throwErrnoIfMinus1RetryMayBlock loc call
492 (threadWaitRead (fromIntegral (fdFD fd)))
493 read = if threaded then safe_read else unsafe_read
494 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
495 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
497 -- return: -1 indicates EOF, >=0 is bytes read
498 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
499 readRawBufferPtrNoBlock loc !fd buf off len
500 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
501 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
502 if r /= 0 then safe_read
504 -- XXX see note [nonblock]
506 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
510 n -> return (fromIntegral n)
511 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
512 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
514 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
515 writeRawBufferPtr loc !fd buf off len
516 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
517 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
520 else do threadWaitWrite (fromIntegral (fdFD fd)); write
522 do_write call = fromIntegral `fmap`
523 throwErrnoIfMinus1RetryMayBlock loc call
524 (threadWaitWrite (fromIntegral (fdFD fd)))
525 write = if threaded then safe_write else unsafe_write
526 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
527 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
529 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
530 writeRawBufferPtrNoBlock loc !fd buf off len
531 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
532 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
536 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
539 n -> return (fromIntegral n)
540 write = if threaded then safe_write else unsafe_write
541 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
542 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
544 isNonBlocking :: FD -> Bool
545 isNonBlocking fd = fdIsNonBlocking fd /= 0
547 foreign import ccall unsafe "fdReady"
548 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
550 #else /* mingw32_HOST_OS.... */
552 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
553 readRawBufferPtr loc !fd buf off len
554 | threaded = blockingReadRawBufferPtr loc fd buf off len
555 | otherwise = asyncReadRawBufferPtr loc fd buf off len
557 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
558 writeRawBufferPtr loc !fd buf off len
559 | threaded = blockingWriteRawBufferPtr loc fd buf off len
560 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
562 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
563 readRawBufferPtrNoBlock = readRawBufferPtr
565 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
566 writeRawBufferPtrNoBlock = writeRawBufferPtr
568 -- Async versions of the read/write primitives, for the non-threaded RTS
570 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
571 asyncReadRawBufferPtr loc !fd buf off len = do
572 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
573 (fromIntegral len) (buf `plusPtr` off)
576 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
577 else return (fromIntegral l)
579 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
580 asyncWriteRawBufferPtr loc !fd buf off len = do
581 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
582 (fromIntegral len) (buf `plusPtr` off)
585 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
586 else return (fromIntegral l)
588 -- Blocking versions of the read/write primitives, for the threaded RTS
590 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
591 blockingReadRawBufferPtr loc fd buf off len
592 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
594 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
595 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
597 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
598 blockingWriteRawBufferPtr loc fd buf off len
599 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
601 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
603 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
604 when (r == -1) c_maperrno
606 -- we don't trust write() to give us the correct errno, and
607 -- instead do the errno conversion from GetLastError()
608 -- ourselves. The main reason is that we treat ERROR_NO_DATA
609 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
610 -- for this case. We need to detect EPIPE correctly, because it
611 -- shouldn't be reported as an error when it happens on stdout.
613 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
616 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
617 -- These calls may block, but that's ok.
619 foreign import stdcall safe "recv"
620 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
622 foreign import stdcall safe "send"
623 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
627 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
629 -- -----------------------------------------------------------------------------
632 #ifndef mingw32_HOST_OS
633 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
634 throwErrnoIfMinus1RetryOnBlock loc f on_block =
637 if (res :: CSsize) == -1
641 then throwErrnoIfMinus1RetryOnBlock loc f on_block
642 else if err == eWOULDBLOCK || err == eAGAIN
648 -- -----------------------------------------------------------------------------
651 #ifndef mingw32_HOST_OS
652 foreign import ccall unsafe "lockFile"
653 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
655 foreign import ccall unsafe "unlockFile"
656 unlockFile :: CInt -> IO CInt
659 puts :: String -> IO ()
660 puts s = do _ <- withCStringLen s $ \(p,len) ->
661 c_write 1 (castPtr p) (fromIntegral len)