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