SafeHaskell: Added SafeHaskell to base
[packages/base.git] / 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
60 c_DEBUG_DUMP :: Bool
61 c_DEBUG_DUMP = False
62
63 -- -----------------------------------------------------------------------------
64 -- The file-descriptor IO device
65
66 data FD = FD {
67 fdFD :: {-# UNPACK #-} !CInt,
68 #ifdef mingw32_HOST_OS
69 -- On Windows, a socket file descriptor needs to be read and written
70 -- using different functions (send/recv).
71 fdIsSocket_ :: {-# UNPACK #-} !Int
72 #else
73 -- On Unix we need to know whether this FD has O_NONBLOCK set.
74 -- If it has, then we can use more efficient routines to read/write to it.
75 -- It is always safe for this to be off.
76 fdIsNonBlocking :: {-# UNPACK #-} !Int
77 #endif
78 }
79 deriving Typeable
80
81 #ifdef mingw32_HOST_OS
82 fdIsSocket :: FD -> Bool
83 fdIsSocket fd = fdIsSocket_ fd /= 0
84 #endif
85
86 instance Show FD where
87 show fd = show (fdFD fd)
88
89 instance GHC.IO.Device.RawIO FD where
90 read = fdRead
91 readNonBlocking = fdReadNonBlocking
92 write = fdWrite
93 writeNonBlocking = fdWriteNonBlocking
94
95 instance GHC.IO.Device.IODevice FD where
96 ready = ready
97 close = close
98 isTerminal = isTerminal
99 isSeekable = isSeekable
100 seek = seek
101 tell = tell
102 getSize = getSize
103 setSize = setSize
104 setEcho = setEcho
105 getEcho = getEcho
106 setRaw = setRaw
107 devType = devType
108 dup = dup
109 dup2 = dup2
110
111 -- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
112 -- taken from the value of BUFSIZ on the current platform. This value
113 -- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
114 -- on Linux. So let's just use a decent size on every platform:
115 dEFAULT_FD_BUFFER_SIZE :: Int
116 dEFAULT_FD_BUFFER_SIZE = 8096
117
118 instance BufferedIO FD where
119 newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
120 fillReadBuffer fd buf = readBuf' fd buf
121 fillReadBuffer0 fd buf = readBufNonBlocking fd buf
122 flushWriteBuffer fd buf = writeBuf' fd buf
123 flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
124
125 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
126 readBuf' fd buf = do
127 when c_DEBUG_DUMP $
128 puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
129 (r,buf') <- readBuf fd buf
130 when c_DEBUG_DUMP $
131 puts ("after: " ++ summaryBuffer buf' ++ "\n")
132 return (r,buf')
133
134 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
135 writeBuf' fd buf = do
136 when c_DEBUG_DUMP $
137 puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
138 writeBuf fd buf
139
140 -- -----------------------------------------------------------------------------
141 -- opening files
142
143 -- | Open a file and make an 'FD' for it. Truncates the file to zero
144 -- size when the `IOMode` is `WriteMode`.
145 openFile
146 :: FilePath -- ^ file to open
147 -> IOMode -- ^ mode in which to open the file
148 -> Bool -- ^ open the file in non-blocking mode?
149 -> IO (FD,IODeviceType)
150
151 openFile filepath iomode non_blocking =
152 withFilePath filepath $ \ f ->
153
154 let
155 oflags1 = case iomode of
156 ReadMode -> read_flags
157 #ifdef mingw32_HOST_OS
158 WriteMode -> write_flags .|. o_TRUNC
159 #else
160 WriteMode -> write_flags
161 #endif
162 ReadWriteMode -> rw_flags
163 AppendMode -> append_flags
164
165 #ifdef mingw32_HOST_OS
166 binary_flags = o_BINARY
167 #else
168 binary_flags = 0
169 #endif
170
171 oflags2 = oflags1 .|. binary_flags
172
173 oflags | non_blocking = oflags2 .|. nonblock_flags
174 | otherwise = oflags2
175 in do
176
177 -- the old implementation had a complicated series of three opens,
178 -- which is perhaps because we have to be careful not to open
179 -- directories. However, the man pages I've read say that open()
180 -- always returns EISDIR if the file is a directory and was opened
181 -- for writing, so I think we're ok with a single open() here...
182 fd <- throwErrnoIfMinus1Retry "openFile"
183 (if non_blocking then c_open f oflags 0o666
184 else c_safe_open f oflags 0o666)
185
186 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
187 False{-not a socket-}
188 non_blocking
189 `catchAny` \e -> do _ <- c_close fd
190 throwIO e
191
192 #ifndef mingw32_HOST_OS
193 -- we want to truncate() if this is an open in WriteMode, but only
194 -- if the target is a RegularFile. ftruncate() fails on special files
195 -- like /dev/null.
196 if iomode == WriteMode && fd_type == RegularFile
197 then setSize fD 0
198 else return ()
199 #endif
200
201 return (fD,fd_type)
202
203 std_flags, output_flags, read_flags, write_flags, rw_flags,
204 append_flags, nonblock_flags :: CInt
205 std_flags = o_NOCTTY
206 output_flags = std_flags .|. o_CREAT
207 read_flags = std_flags .|. o_RDONLY
208 write_flags = output_flags .|. o_WRONLY
209 rw_flags = output_flags .|. o_RDWR
210 append_flags = write_flags .|. o_APPEND
211 nonblock_flags = o_NONBLOCK
212
213
214 -- | Make a 'FD' from an existing file descriptor. Fails if the FD
215 -- refers to a directory. If the FD refers to a file, `mkFD` locks
216 -- the file according to the Haskell 98 single writer/multiple reader
217 -- locking semantics (this is why we need the `IOMode` argument too).
218 mkFD :: CInt
219 -> IOMode
220 -> Maybe (IODeviceType, CDev, CIno)
221 -- the results of fdStat if we already know them, or we want
222 -- to prevent fdToHandle_stat from doing its own stat.
223 -- These are used for:
224 -- - we fail if the FD refers to a directory
225 -- - if the FD refers to a file, we lock it using (cdev,cino)
226 -> Bool -- ^ is a socket (on Windows)
227 -> Bool -- ^ is in non-blocking mode on Unix
228 -> IO (FD,IODeviceType)
229
230 mkFD fd iomode mb_stat is_socket is_nonblock = do
231
232 let _ = (is_socket, is_nonblock) -- warning suppression
233
234 (fd_type,dev,ino) <-
235 case mb_stat of
236 Nothing -> fdStat fd
237 Just stat -> return stat
238
239 let write = case iomode of
240 ReadMode -> False
241 _ -> True
242
243 #ifdef mingw32_HOST_OS
244 _ <- setmode fd True -- unconditionally set binary mode
245 let _ = (dev,ino,write) -- warning suppression
246 #endif
247
248 case fd_type of
249 Directory ->
250 ioException (IOError Nothing InappropriateType "openFile"
251 "is a directory" Nothing Nothing)
252
253 #ifndef mingw32_HOST_OS
254 -- regular files need to be locked
255 RegularFile -> do
256 -- On Windows we use explicit exclusion via sopen() to implement
257 -- this locking (see __hscore_open()); on Unix we have to
258 -- implment it in the RTS.
259 r <- lockFile fd dev ino (fromBool write)
260 when (r == -1) $
261 ioException (IOError Nothing ResourceBusy "openFile"
262 "file is locked" Nothing Nothing)
263 #endif
264
265 _other_type -> return ()
266
267 return (FD{ fdFD = fd,
268 #ifndef mingw32_HOST_OS
269 fdIsNonBlocking = fromEnum is_nonblock
270 #else
271 fdIsSocket_ = fromEnum is_socket
272 #endif
273 },
274 fd_type)
275
276 #ifdef mingw32_HOST_OS
277 foreign import ccall unsafe "__hscore_setmode"
278 setmode :: CInt -> Bool -> IO CInt
279 #endif
280
281 -- -----------------------------------------------------------------------------
282 -- Standard file descriptors
283
284 stdFD :: CInt -> FD
285 stdFD fd = FD { fdFD = fd,
286 #ifdef mingw32_HOST_OS
287 fdIsSocket_ = 0
288 #else
289 fdIsNonBlocking = 0
290 -- We don't set non-blocking mode on standard handles, because it may
291 -- confuse other applications attached to the same TTY/pipe
292 -- see Note [nonblock]
293 #endif
294 }
295
296 stdin, stdout, stderr :: FD
297 stdin = stdFD 0
298 stdout = stdFD 1
299 stderr = stdFD 2
300
301 -- -----------------------------------------------------------------------------
302 -- Operations on file descriptors
303
304 close :: FD -> IO ()
305 close fd =
306 #ifndef mingw32_HOST_OS
307 (flip finally) (release fd) $
308 #endif
309 do let closer realFd =
310 throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
311 #ifdef mingw32_HOST_OS
312 if fdIsSocket fd then
313 c_closesocket (fromIntegral realFd)
314 else
315 #endif
316 c_close (fromIntegral realFd)
317 closeFdWith closer (fromIntegral (fdFD fd))
318
319 release :: FD -> IO ()
320 #ifdef mingw32_HOST_OS
321 release _ = return ()
322 #else
323 release fd = do _ <- unlockFile (fdFD fd)
324 return ()
325 #endif
326
327 #ifdef mingw32_HOST_OS
328 foreign import stdcall unsafe "HsBase.h closesocket"
329 c_closesocket :: CInt -> IO CInt
330 #endif
331
332 isSeekable :: FD -> IO Bool
333 isSeekable fd = do
334 t <- devType fd
335 return (t == RegularFile || t == RawDevice)
336
337 seek :: FD -> SeekMode -> Integer -> IO ()
338 seek fd mode off = do
339 throwErrnoIfMinus1Retry_ "seek" $
340 c_lseek (fdFD fd) (fromIntegral off) seektype
341 where
342 seektype :: CInt
343 seektype = case mode of
344 AbsoluteSeek -> sEEK_SET
345 RelativeSeek -> sEEK_CUR
346 SeekFromEnd -> sEEK_END
347
348 tell :: FD -> IO Integer
349 tell fd =
350 fromIntegral `fmap`
351 (throwErrnoIfMinus1Retry "hGetPosn" $
352 c_lseek (fdFD fd) 0 sEEK_CUR)
353
354 getSize :: FD -> IO Integer
355 getSize fd = fdFileSize (fdFD fd)
356
357 setSize :: FD -> Integer -> IO ()
358 setSize fd size = do
359 throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
360 c_ftruncate (fdFD fd) (fromIntegral size)
361
362 devType :: FD -> IO IODeviceType
363 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
364
365 dup :: FD -> IO FD
366 dup fd = do
367 newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
368 return fd{ fdFD = newfd }
369
370 dup2 :: FD -> FD -> IO FD
371 dup2 fd fdto = do
372 -- Windows' dup2 does not return the new descriptor, unlike Unix
373 throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
374 c_dup2 (fdFD fd) (fdFD fdto)
375 return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
376
377 setNonBlockingMode :: FD -> Bool -> IO FD
378 setNonBlockingMode fd set = do
379 setNonBlockingFD (fdFD fd) set
380 #if defined(mingw32_HOST_OS)
381 return fd
382 #else
383 return fd{ fdIsNonBlocking = fromEnum set }
384 #endif
385
386 ready :: FD -> Bool -> Int -> IO Bool
387 ready fd write msecs = do
388 r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
389 fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
390 (fromIntegral msecs)
391 #if defined(mingw32_HOST_OS)
392 (fromIntegral $ fromEnum $ fdIsSocket fd)
393 #else
394 0
395 #endif
396 return (toEnum (fromIntegral r))
397
398 foreign import ccall safe "fdReady"
399 fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
400
401 -- ---------------------------------------------------------------------------
402 -- Terminal-related stuff
403
404 isTerminal :: FD -> IO Bool
405 isTerminal fd =
406 #if defined(mingw32_HOST_OS)
407 is_console (fdFD fd) >>= return.toBool
408 #else
409 c_isatty (fdFD fd) >>= return.toBool
410 #endif
411
412 setEcho :: FD -> Bool -> IO ()
413 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
414
415 getEcho :: FD -> IO Bool
416 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
417
418 setRaw :: FD -> Bool -> IO ()
419 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
420
421 -- -----------------------------------------------------------------------------
422 -- Reading and Writing
423
424 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
425 fdRead fd ptr bytes
426 = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
427 ; return (fromIntegral r) }
428
429 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
430 fdReadNonBlocking fd ptr bytes = do
431 r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
432 0 (fromIntegral bytes)
433 case fromIntegral r of
434 (-1) -> return (Nothing)
435 n -> return (Just n)
436
437
438 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
439 fdWrite fd ptr bytes = do
440 res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
441 let res' = fromIntegral res
442 if res' < bytes
443 then fdWrite fd (ptr `plusPtr` res') (bytes - res')
444 else return ()
445
446 -- XXX ToDo: this isn't non-blocking
447 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
448 fdWriteNonBlocking fd ptr bytes = do
449 res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
450 (fromIntegral bytes)
451 return (fromIntegral res)
452
453 -- -----------------------------------------------------------------------------
454 -- FD operations
455
456 -- Low level routines for reading/writing to (raw)buffers:
457
458 #ifndef mingw32_HOST_OS
459
460 {-
461 NOTE [nonblock]:
462
463 Unix has broken semantics when it comes to non-blocking I/O: you can
464 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
465 attached to the same underlying file, pipe or TTY; there's no way to
466 have private non-blocking behaviour for an FD. See bug #724.
467
468 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
469 come from external sources or are exposed externally are left in
470 blocking mode. This solution has some problems though. We can't
471 completely simulate a non-blocking read without O_NONBLOCK: several
472 cases are wrong here. The cases that are wrong:
473
474 * reading/writing to a blocking FD in non-threaded mode.
475 In threaded mode, we just make a safe call to read().
476 In non-threaded mode we call select() before attempting to read,
477 but that leaves a small race window where the data can be read
478 from the file descriptor before we issue our blocking read().
479 * readRawBufferNoBlock for a blocking FD
480
481 NOTE [2363]:
482
483 In the threaded RTS we could just make safe calls to read()/write()
484 for file descriptors in blocking mode without worrying about blocking
485 other threads, but the problem with this is that the thread will be
486 uninterruptible while it is blocked in the foreign call. See #2363.
487 So now we always call fdReady() before reading, and if fdReady
488 indicates that there's no data, we call threadWaitRead.
489
490 -}
491
492 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
493 readRawBufferPtr loc !fd buf off len
494 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
495 | otherwise = do r <- throwErrnoIfMinus1 loc
496 (unsafe_fdReady (fdFD fd) 0 0 0)
497 if r /= 0
498 then read
499 else do threadWaitRead (fromIntegral (fdFD fd)); read
500 where
501 do_read call = fromIntegral `fmap`
502 throwErrnoIfMinus1RetryMayBlock loc call
503 (threadWaitRead (fromIntegral (fdFD fd)))
504 read = if threaded then safe_read else unsafe_read
505 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
506 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
507
508 -- return: -1 indicates EOF, >=0 is bytes read
509 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
510 readRawBufferPtrNoBlock loc !fd buf off len
511 | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
512 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
513 if r /= 0 then safe_read
514 else return 0
515 -- XXX see note [nonblock]
516 where
517 do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
518 case r of
519 (-1) -> return 0
520 0 -> return (-1)
521 n -> return (fromIntegral n)
522 unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
523 safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
524
525 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
526 writeRawBufferPtr loc !fd buf off len
527 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
528 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
529 if r /= 0
530 then write
531 else do threadWaitWrite (fromIntegral (fdFD fd)); write
532 where
533 do_write call = fromIntegral `fmap`
534 throwErrnoIfMinus1RetryMayBlock loc call
535 (threadWaitWrite (fromIntegral (fdFD fd)))
536 write = if threaded then safe_write else unsafe_write
537 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
538 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
539
540 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
541 writeRawBufferPtrNoBlock loc !fd buf off len
542 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
543 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
544 if r /= 0 then write
545 else return 0
546 where
547 do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
548 case r of
549 (-1) -> return 0
550 n -> return (fromIntegral n)
551 write = if threaded then safe_write else unsafe_write
552 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
553 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
554
555 isNonBlocking :: FD -> Bool
556 isNonBlocking fd = fdIsNonBlocking fd /= 0
557
558 foreign import ccall unsafe "fdReady"
559 unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
560
561 #else /* mingw32_HOST_OS.... */
562
563 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
564 readRawBufferPtr loc !fd buf off len
565 | threaded = blockingReadRawBufferPtr loc fd buf off len
566 | otherwise = asyncReadRawBufferPtr loc fd buf off len
567
568 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
569 writeRawBufferPtr loc !fd buf off len
570 | threaded = blockingWriteRawBufferPtr loc fd buf off len
571 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
572
573 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
574 readRawBufferPtrNoBlock = readRawBufferPtr
575
576 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
577 writeRawBufferPtrNoBlock = writeRawBufferPtr
578
579 -- Async versions of the read/write primitives, for the non-threaded RTS
580
581 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
582 asyncReadRawBufferPtr loc !fd buf off len = do
583 (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
584 (fromIntegral len) (buf `plusPtr` off)
585 if l == (-1)
586 then
587 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
588 else return (fromIntegral l)
589
590 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
591 asyncWriteRawBufferPtr loc !fd buf off len = do
592 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
593 (fromIntegral len) (buf `plusPtr` off)
594 if l == (-1)
595 then
596 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
597 else return (fromIntegral l)
598
599 -- Blocking versions of the read/write primitives, for the threaded RTS
600
601 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
602 blockingReadRawBufferPtr loc fd buf off len
603 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
604 if fdIsSocket fd
605 then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
606 else c_safe_read (fdFD fd) (buf `plusPtr` off) len
607
608 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
609 blockingWriteRawBufferPtr loc fd buf off len
610 = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
611 if fdIsSocket fd
612 then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0
613 else do
614 r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
615 when (r == -1) c_maperrno
616 return r
617 -- we don't trust write() to give us the correct errno, and
618 -- instead do the errno conversion from GetLastError()
619 -- ourselves. The main reason is that we treat ERROR_NO_DATA
620 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
621 -- for this case. We need to detect EPIPE correctly, because it
622 -- shouldn't be reported as an error when it happens on stdout.
623
624 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
625 -- These calls may block, but that's ok.
626
627 foreign import stdcall safe "recv"
628 c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
629
630 foreign import stdcall safe "send"
631 c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
632
633 #endif
634
635 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
636
637 -- -----------------------------------------------------------------------------
638 -- utils
639
640 #ifndef mingw32_HOST_OS
641 throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize
642 throwErrnoIfMinus1RetryOnBlock loc f on_block =
643 do
644 res <- f
645 if (res :: CSsize) == -1
646 then do
647 err <- getErrno
648 if err == eINTR
649 then throwErrnoIfMinus1RetryOnBlock loc f on_block
650 else if err == eWOULDBLOCK || err == eAGAIN
651 then do on_block
652 else throwErrno loc
653 else return res
654 #endif
655
656 -- -----------------------------------------------------------------------------
657 -- Locking/unlocking
658
659 #ifndef mingw32_HOST_OS
660 foreign import ccall unsafe "lockFile"
661 lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
662
663 foreign import ccall unsafe "unlockFile"
664 unlockFile :: CInt -> IO CInt
665 #endif