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