65ed91378888f04b6916bea659a2d0024652588c
[ghc.git] / libraries / base / GHC / IO / FD.hs
1 {-# LANGUAGE CPP
2 , NoImplicitPrelude
3 , BangPatterns
4 , ForeignFunctionInterface
5 , DeriveDataTypeable
6 #-}
7 {-# OPTIONS_GHC -fno-warn-identities #-}
8 -- Whether there are identities depends on the platform
9 {-# OPTIONS_HADDOCK hide #-}
10
11 -----------------------------------------------------------------------------
12 -- |
13 -- Module : GHC.IO.FD
14 -- Copyright : (c) The University of Glasgow, 1994-2008
15 -- License : see libraries/base/LICENSE
16 --
17 -- Maintainer : libraries@haskell.org
18 -- Stability : internal
19 -- Portability : non-portable
20 --
21 -- Raw read/write operations on file descriptors
22 --
23 -----------------------------------------------------------------------------
24
25 module GHC.IO.FD (
26 FD(..),
27 openFile, mkFD, release,
28 setNonBlockingMode,
29 readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
30 stdin, stdout, stderr
31 ) where
32
33 import GHC.Base
34 import GHC.Num
35 import GHC.Real
36 import GHC.Show
37 import GHC.Enum
38 import Data.Maybe
39 import Control.Monad
40 import Data.Typeable
41
42 import GHC.IO
43 import GHC.IO.IOMode
44 import GHC.IO.Buffer
45 import GHC.IO.BufferedIO
46 import qualified GHC.IO.Device
47 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
48 import GHC.Conc.IO
49 import GHC.IO.Exception
50 #ifdef mingw32_HOST_OS
51 import GHC.Windows
52 #endif
53
54 import Foreign
55 import Foreign.C
56 import qualified System.Posix.Internals
57 import System.Posix.Internals hiding (FD, setEcho, getEcho)
58 import System.Posix.Types
59 -- import GHC.Ptr
60
61 c_DEBUG_DUMP :: Bool
62 c_DEBUG_DUMP = False
63
64 -- -----------------------------------------------------------------------------
65 -- The file-descriptor IO device
66
67 data FD = FD {
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
73 #else
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
78 #endif
79 }
80 deriving Typeable
81
82 #ifdef mingw32_HOST_OS
83 fdIsSocket :: FD -> Bool
84 fdIsSocket fd = fdIsSocket_ fd /= 0
85 #endif
86
87 instance Show FD where
88 show fd = show (fdFD fd)
89
90 instance GHC.IO.Device.RawIO FD where
91 read = fdRead
92 readNonBlocking = fdReadNonBlocking
93 write = fdWrite
94 writeNonBlocking = fdWriteNonBlocking
95
96 instance GHC.IO.Device.IODevice FD where
97 ready = ready
98 close = close
99 isTerminal = isTerminal
100 isSeekable = isSeekable
101 seek = seek
102 tell = tell
103 getSize = getSize
104 setSize = setSize
105 setEcho = setEcho
106 getEcho = getEcho
107 setRaw = setRaw
108 devType = devType
109 dup = dup
110 dup2 = dup2
111
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
118
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
125
126 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
127 readBuf' fd buf = do
128 when c_DEBUG_DUMP $
129 puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
130 (r,buf') <- readBuf fd buf
131 when c_DEBUG_DUMP $
132 puts ("after: " ++ summaryBuffer buf' ++ "\n")
133 return (r,buf')
134
135 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
136 writeBuf' fd buf = do
137 when c_DEBUG_DUMP $
138 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
139 writeBuf fd buf
140
141 -- -----------------------------------------------------------------------------
142 -- opening files
143
144 -- | Open a file and make an 'FD' for it. Truncates the file to zero
145 -- size when the `IOMode` is `WriteMode`.
146 openFile
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)
151
152 openFile filepath iomode non_blocking =
153 withFilePath filepath $ \ f ->
154
155 let
156 oflags1 = case iomode of
157 ReadMode -> read_flags
158 #ifdef mingw32_HOST_OS
159 WriteMode -> write_flags .|. o_TRUNC
160 #else
161 WriteMode -> write_flags
162 #endif
163 ReadWriteMode -> rw_flags
164 AppendMode -> append_flags
165
166 #ifdef mingw32_HOST_OS
167 binary_flags = o_BINARY
168 #else
169 binary_flags = 0
170 #endif
171
172 oflags2 = oflags1 .|. binary_flags
173
174 oflags | non_blocking = oflags2 .|. nonblock_flags
175 | otherwise = oflags2
176 in do
177
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)
186
187 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
188 False{-not a socket-}
189 non_blocking
190 `catchAny` \e -> do _ <- c_close fd
191 throwIO e
192
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
196 -- like /dev/null.
197 if iomode == WriteMode && fd_type == RegularFile
198 then setSize fD 0
199 else return ()
200 #endif
201
202 return (fD,fd_type)
203
204 std_flags, output_flags, read_flags, write_flags, rw_flags,
205 append_flags, nonblock_flags :: CInt
206 std_flags = o_NOCTTY
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
213
214
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).
219 mkFD :: CInt
220 -> IOMode
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)
230
231 mkFD fd iomode mb_stat is_socket is_nonblock = do
232
233 let _ = (is_socket, is_nonblock) -- warning suppression
234
235 (fd_type,dev,ino) <-
236 case mb_stat of
237 Nothing -> fdStat fd
238 Just stat -> return stat
239
240 let write = case iomode of
241 ReadMode -> False
242 _ -> True
243
244 #ifdef mingw32_HOST_OS
245 _ <- setmode fd True -- unconditionally set binary mode
246 let _ = (dev,ino,write) -- warning suppression
247 #endif
248
249 case fd_type of
250 Directory ->
251 ioException (IOError Nothing InappropriateType "openFile"
252 "is a directory" Nothing Nothing)
253
254 #ifndef mingw32_HOST_OS
255 -- regular files need to be locked
256 RegularFile -> do
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)
261 when (r == -1) $
262 ioException (IOError Nothing ResourceBusy "openFile"
263 "file is locked" Nothing Nothing)
264 #endif
265
266 _other_type -> return ()
267
268 return (FD{ fdFD = fd,
269 #ifndef mingw32_HOST_OS
270 fdIsNonBlocking = fromEnum is_nonblock
271 #else
272 fdIsSocket_ = fromEnum is_socket
273 #endif
274 },
275 fd_type)
276
277 #ifdef mingw32_HOST_OS
278 foreign import ccall unsafe "__hscore_setmode"
279 setmode :: CInt -> Bool -> IO CInt
280 #endif
281
282 -- -----------------------------------------------------------------------------
283 -- Standard file descriptors
284
285 stdFD :: CInt -> FD
286 stdFD fd = FD { fdFD = fd,
287 #ifdef mingw32_HOST_OS
288 fdIsSocket_ = 0
289 #else
290 fdIsNonBlocking = 0
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]
294 #endif
295 }
296
297 stdin, stdout, stderr :: FD
298 stdin = stdFD 0
299 stdout = stdFD 1
300 stderr = stdFD 2
301
302 -- -----------------------------------------------------------------------------
303 -- Operations on file descriptors
304
305 close :: FD -> IO ()
306 close fd =
307 #ifndef mingw32_HOST_OS
308 (flip finally) (release fd) $
309 #endif
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)
315 else
316 #endif
317 c_close (fromIntegral realFd)
318 closeFdWith closer (fromIntegral (fdFD fd))
319
320 release :: FD -> IO ()
321 #ifdef mingw32_HOST_OS
322 release _ = return ()
323 #else
324 release fd = do _ <- unlockFile (fdFD fd)
325 return ()
326 #endif
327
328 #ifdef mingw32_HOST_OS
329 foreign import stdcall unsafe "HsBase.h closesocket"
330 c_closesocket :: CInt -> IO CInt
331 #endif
332
333 isSeekable :: FD -> IO Bool
334 isSeekable fd = do
335 t <- devType fd
336 return (t == RegularFile || t == RawDevice)
337
338 seek :: FD -> SeekMode -> Integer -> IO ()
339 seek fd mode off = do
340 throwErrnoIfMinus1Retry_ "seek" $
341 c_lseek (fdFD fd) (fromIntegral off) seektype
342 where
343 seektype :: CInt
344 seektype = case mode of
345 AbsoluteSeek -> sEEK_SET
346 RelativeSeek -> sEEK_CUR
347 SeekFromEnd -> sEEK_END
348
349 tell :: FD -> IO Integer
350 tell fd =
351 fromIntegral `fmap`
352 (throwErrnoIfMinus1Retry "hGetPosn" $
353 c_lseek (fdFD fd) 0 sEEK_CUR)
354
355 getSize :: FD -> IO Integer
356 getSize fd = fdFileSize (fdFD fd)
357
358 setSize :: FD -> Integer -> IO ()
359 setSize fd size = do
360 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
361 c_ftruncate (fdFD fd) (fromIntegral size)
362
363 devType :: FD -> IO IODeviceType
364 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
365
366 dup :: FD -> IO FD
367 dup fd = do
368 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
369 return fd{ fdFD = newfd }
370
371 dup2 :: FD -> FD -> IO FD
372 dup2 fd fdto = do
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
377
378 setNonBlockingMode :: FD -> Bool -> IO FD
379 setNonBlockingMode fd set = do
380 setNonBlockingFD (fdFD fd) set
381 #if defined(mingw32_HOST_OS)
382 return fd
383 #else
384 return fd{ fdIsNonBlocking = fromEnum set }
385 #endif
386
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)
391 (fromIntegral msecs)
392 #if defined(mingw32_HOST_OS)
393 (fromIntegral $ fromEnum $ fdIsSocket fd)
394 #else
395 0
396 #endif
397 return (toEnum (fromIntegral r))
398
399 foreign import ccall safe "fdReady"
400 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
401
402 -- ---------------------------------------------------------------------------
403 -- Terminal-related stuff
404
405 isTerminal :: FD -> IO Bool
406 isTerminal fd =
407 #if defined(mingw32_HOST_OS)
408 is_console (fdFD fd) >>= return.toBool
409 #else
410 c_isatty (fdFD fd) >>= return.toBool
411 #endif
412
413 setEcho :: FD -> Bool -> IO ()
414 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
415
416 getEcho :: FD -> IO Bool
417 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
418
419 setRaw :: FD -> Bool -> IO ()
420 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
421
422 -- -----------------------------------------------------------------------------
423 -- Reading and Writing
424
425 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
426 fdRead fd ptr bytes
427 = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
428 ; return (fromIntegral r) }
429
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)
436 n -> return (Just n)
437
438
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
443 if res' < bytes
444 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
445 else return ()
446
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
451 (fromIntegral bytes)
452 return (fromIntegral res)
453
454 -- -----------------------------------------------------------------------------
455 -- FD operations
456
457 -- Low level routines for reading/writing to (raw)buffers:
458
459 #ifndef mingw32_HOST_OS
460
461 {-
462 NOTE [nonblock]:
463
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.
468
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:
474
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
481
482 NOTE [2363]:
483
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.
490
491 -}
492
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)
498 if r /= 0
499 then read
500 else do threadWaitRead (fromIntegral (fdFD fd)); read
501 where
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)
508
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
515 else return 0
516 -- XXX see note [nonblock]
517 where
518 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
519 case r of
520 (-1) -> return 0
521 0 -> 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)
525
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
530 if r /= 0
531 then write
532 else do threadWaitWrite (fromIntegral (fdFD fd)); write
533 where
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)
540
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
545 if r /= 0 then write
546 else return 0
547 where
548 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
549 case r of
550 (-1) -> return 0
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)
555
556 isNonBlocking :: FD -> Bool
557 isNonBlocking fd = fdIsNonBlocking fd /= 0
558
559 foreign import ccall unsafe "fdReady"
560 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
561
562 #else /* mingw32_HOST_OS.... */
563
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
568
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
573
574 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
575 readRawBufferPtrNoBlock = readRawBufferPtr
576
577 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
578 writeRawBufferPtrNoBlock = writeRawBufferPtr
579
580 -- Async versions of the read/write primitives, for the non-threaded RTS
581
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)
586 if l == (-1)
587 then
588 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
589 else return (fromIntegral l)
590
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)
595 if l == (-1)
596 then
597 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
598 else return (fromIntegral l)
599
600 -- Blocking versions of the read/write primitives, for the threaded RTS
601
602 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
603 blockingReadRawBufferPtr loc fd buf off len
604 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
605 if fdIsSocket fd
606 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
607 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
608
609 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
610 blockingWriteRawBufferPtr loc fd buf off len
611 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
612 if fdIsSocket fd
613 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
614 else do
615 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
616 when (r == -1) c_maperrno
617 return r
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.
624
625 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
626 -- These calls may block, but that's ok.
627
628 foreign import stdcall safe "recv"
629 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
630
631 foreign import stdcall safe "send"
632 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
633
634 #endif
635
636 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
637
638 -- -----------------------------------------------------------------------------
639 -- utils
640
641 #ifndef mingw32_HOST_OS
642 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
643 throwErrnoIfMinus1RetryOnBlock loc f on_block =
644 do
645 res <- f
646 if (res :: CSsize) == -1
647 then do
648 err <- getErrno
649 if err == eINTR
650 then throwErrnoIfMinus1RetryOnBlock loc f on_block
651 else if err == eWOULDBLOCK || err == eAGAIN
652 then do on_block
653 else throwErrno loc
654 else return res
655 #endif
656
657 -- -----------------------------------------------------------------------------
658 -- Locking/unlocking
659
660 #ifndef mingw32_HOST_OS
661 foreign import ccall unsafe "lockFile"
662 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
663
664 foreign import ccall unsafe "unlockFile"
665 unlockFile :: CInt -> IO CInt
666 #endif