GHC/IO/FD.hs

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