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