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 ()
 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; throwIO e
 169
 170 #ifndef mingw32_HOST_OS
 171         -- we want to truncate() if this is an open in WriteMode, but only
 172         -- if the target is a RegularFile.  ftruncate() fails on special files
 173         -- like /dev/null.
 174     if iomode == WriteMode && fd_type == RegularFile
 175       then setSize fD 0
 176       else return ()
 177 #endif
 178
 179     return (fD,fd_type)
 180
 181 std_flags, output_flags, read_flags, write_flags, rw_flags,
 182     append_flags :: CInt
 183 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 184 output_flags = std_flags    .|. o_CREAT
 185 read_flags   = std_flags    .|. o_RDONLY
 186 write_flags  = output_flags .|. o_WRONLY
 187 rw_flags     = output_flags .|. o_RDWR
 188 append_flags = write_flags  .|. o_APPEND
 189
 190
 191 -- | Make a 'FD' from an existing file descriptor.  Fails if the FD
 192 -- refers to a directory.  If the FD refers to a file, `mkFD` locks
 193 -- the file according to the Haskell 98 single writer/multiple reader
 194 -- locking semantics (this is why we need the `IOMode` argument too).
 195 mkFD :: CInt
 196      -> IOMode
 197      -> Maybe (IODeviceType, CDev, CIno)
 198      -- the results of fdStat if we already know them, or we want
 199      -- to prevent fdToHandle_stat from doing its own stat.
 200      -- These are used for:
 201      --   - we fail if the FD refers to a directory
 202      --   - if the FD refers to a file, we lock it using (cdev,cino)
 203      -> Bool   -- ^ is a socket (on Windows)
 204      -> Bool   -- ^ is in non-blocking mode on Unix
 205      -> IO (FD,IODeviceType)
 206
 207 mkFD fd iomode mb_stat is_socket is_nonblock = do
 208
 209     let _ = (is_socket, is_nonblock) -- warning suppression
 210
 211     (fd_type,dev,ino) <-
 212         case mb_stat of
 213           Nothing   -> fdStat fd
 214           Just stat -> return stat
 215
 216     let write = case iomode of
 217                    ReadMode -> False
 218                    _ -> True
 219
 220 #ifdef mingw32_HOST_OS
 221     setmode fd True -- unconditionally set binary mode
 222     let _ = (dev,ino,write) -- warning suppression
 223 #endif
 224
 225     case fd_type of
 226         Directory ->
 227            ioException (IOError Nothing InappropriateType "openFile"
 228                            "is a directory" Nothing Nothing)
 229
 230 #ifndef mingw32_HOST_OS
 231         -- regular files need to be locked
 232         RegularFile -> do
 233            -- On Windows we use explicit exclusion via sopen() to implement
 234            -- this locking (see __hscore_open()); on Unix we have to
 235            -- implment it in the RTS.
 236            r <- lockFile fd dev ino (fromBool write)
 237            when (r == -1)  $
 238                 ioException (IOError Nothing ResourceBusy "openFile"
 239                                    "file is locked" Nothing Nothing)
 240 #endif
 241
 242         _other_type -> return ()
 243
 244     return (FD{ fdFD = fd,
 245 #ifndef mingw32_HOST_OS
 246                 fdIsNonBlocking = fromEnum is_nonblock
 247 #else
 248                 fdIsSocket_ = fromEnum is_socket
 249 #endif
 250               },
 251             fd_type)
 252
 253 #ifdef mingw32_HOST_OS
 254 foreign import ccall unsafe "__hscore_setmode"
 255   setmode :: CInt -> Bool -> IO CInt
 256 #endif
 257
 258 -- -----------------------------------------------------------------------------
 259 -- Standard file descriptors
 260
 261 stdFD :: CInt -> FD
 262 stdFD fd = FD { fdFD = fd,
 263 #ifdef mingw32_HOST_OS
 264                 fdIsSocket_ = 0
 265 #else
 266                 fdIsNonBlocking = 0
 267    -- We don't set non-blocking mode on standard handles, because it may
 268    -- confuse other applications attached to the same TTY/pipe
 269    -- see Note [nonblock]
 270 #endif
 271                 }
 272
 273 stdin, stdout, stderr :: FD
 274 stdin  = stdFD 0
 275 stdout = stdFD 1
 276 stderr = stdFD 2
 277
 278 -- -----------------------------------------------------------------------------
 279 -- Operations on file descriptors
 280
 281 close :: FD -> IO ()
 282 close fd =
 283 #ifndef mingw32_HOST_OS
 284   (flip finally) (release fd) $ do
 285 #endif
 286   throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 287 #ifdef mingw32_HOST_OS
 288     if fdIsSocket fd then
 289        c_closesocket (fdFD fd)
 290     else
 291 #endif
 292        c_close (fdFD fd)
 293
 294 release :: FD -> IO ()
 295 release fd = do
 296 #ifndef mingw32_HOST_OS
 297    unlockFile (fdFD fd)
 298 #endif
 299    let _ = fd -- warning suppression
 300    return ()
 301
 302 #ifdef mingw32_HOST_OS
 303 foreign import stdcall unsafe "HsBase.h closesocket"
 304    c_closesocket :: CInt -> IO CInt
 305 #endif
 306
 307 isSeekable :: FD -> IO Bool
 308 isSeekable fd = do
 309   t <- devType fd
 310   return (t == RegularFile || t == RawDevice)
 311
 312 seek :: FD -> SeekMode -> Integer -> IO ()
 313 seek fd mode off = do
 314   throwErrnoIfMinus1Retry "seek" $
 315      c_lseek (fdFD fd) (fromIntegral off) seektype
 316   return ()
 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   return ()
 338
 339 devType :: FD -> IO IODeviceType
 340 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
 341
 342 dup :: FD -> IO FD
 343 dup fd = do
 344   newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
 345   return fd{ fdFD = newfd }
 346
 347 dup2 :: FD -> FD -> IO FD
 348 dup2 fd fdto = do
 349   -- Windows' dup2 does not return the new descriptor, unlike Unix
 350   throwErrnoIfMinus1 "GHC.IO.FD.dup2" $
 351     c_dup2 (fdFD fd) (fdFD fdto)
 352   return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
 353
 354 setNonBlockingMode :: FD -> Bool -> IO FD
 355 setNonBlockingMode fd set = do
 356   setNonBlockingFD (fdFD fd) set
 357 #if defined(mingw32_HOST_OS)
 358   return fd
 359 #else
 360   return fd{ fdIsNonBlocking = fromEnum set }
 361 #endif
 362
 363 ready :: FD -> Bool -> Int -> IO Bool
 364 ready fd write msecs = do
 365   r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
 366           fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
 367                             (fromIntegral msecs)
 368 #if defined(mingw32_HOST_OS)
 369                           (fromIntegral $ fromEnum $ fdIsSocket fd)
 370 #else
 371                           0
 372 #endif
 373   return (toEnum (fromIntegral r))
 374
 375 foreign import ccall safe "fdReady"
 376   fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
 377
 378 -- ---------------------------------------------------------------------------
 379 -- Terminal-related stuff
 380
 381 isTerminal :: FD -> IO Bool
 382 isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
 383
 384 setEcho :: FD -> Bool -> IO ()
 385 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
 386
 387 getEcho :: FD -> IO Bool
 388 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
 389
 390 setRaw :: FD -> Bool -> IO ()
 391 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
 392
 393 -- -----------------------------------------------------------------------------
 394 -- Reading and Writing
 395
 396 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
 397 fdRead fd ptr bytes = do
 398   r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
 399   return (fromIntegral r)
 400
 401 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
 402 fdReadNonBlocking fd ptr bytes = do
 403   r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
 404            0 (fromIntegral bytes)
 405   case r of
 406     (-1) -> return (Nothing)
 407     n    -> return (Just (fromIntegral n))
 408
 409
 410 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
 411 fdWrite fd ptr bytes = do
 412   res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
 413   let res' = fromIntegral res
 414   if res' < bytes
 415      then fdWrite fd (ptr `plusPtr` res') (bytes - res')
 416      else return ()
 417
 418 -- XXX ToDo: this isn't non-blocking
 419 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
 420 fdWriteNonBlocking fd ptr bytes = do
 421   res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
 422             (fromIntegral bytes)
 423   return (fromIntegral res)
 424
 425 -- -----------------------------------------------------------------------------
 426 -- FD operations
 427
 428 -- Low level routines for reading/writing to (raw)buffers:
 429
 430 #ifndef mingw32_HOST_OS
 431
 432 {-
 433 NOTE [nonblock]:
 434
 435 Unix has broken semantics when it comes to non-blocking I/O: you can
 436 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
 437 attached to the same underlying file, pipe or TTY; there's no way to
 438 have private non-blocking behaviour for an FD.  See bug #724.
 439
 440 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
 441 come from external sources or are exposed externally are left in
 442 blocking mode.  This solution has some problems though.  We can't
 443 completely simulate a non-blocking read without O_NONBLOCK: several
 444 cases are wrong here.  The cases that are wrong:
 445
 446   * reading/writing to a blocking FD in non-threaded mode.
 447     In threaded mode, we just make a safe call to read().
 448     In non-threaded mode we call select() before attempting to read,
 449     but that leaves a small race window where the data can be read
 450     from the file descriptor before we issue our blocking read().
 451   * readRawBufferNoBlock for a blocking FD
 452
 453 NOTE [2363]:
 454
 455 In the threaded RTS we could just make safe calls to read()/write()
 456 for file descriptors in blocking mode without worrying about blocking
 457 other threads, but the problem with this is that the thread will be
 458 uninterruptible while it is blocked in the foreign call.  See #2363.
 459 So now we always call fdReady() before reading, and if fdReady
 460 indicates that there's no data, we call threadWaitRead.
 461
 462 -}
 463
 464 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
 465 readRawBufferPtr loc !fd buf off len
 466   | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
 467   | otherwise    = do r <- throwErrnoIfMinus1 loc
 468                                 (unsafe_fdReady (fdFD fd) 0 0 0)
 469                       if r /= 0
 470                         then read
 471                         else do threadWaitRead (fromIntegral (fdFD fd)); read
 472   where
 473     do_read call = fromIntegral `fmap`
 474                       throwErrnoIfMinus1RetryMayBlock loc call
 475                             (threadWaitRead (fromIntegral (fdFD fd)))
 476     read        = if threaded then safe_read else unsafe_read
 477     unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
 478     safe_read   = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
 479
 480 -- return: -1 indicates EOF, >=0 is bytes read
 481 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
 482 readRawBufferPtrNoBlock loc !fd buf off len
 483   | isNonBlocking fd  = unsafe_read -- unsafe is ok, it can't block
 484   | otherwise    = do r <- unsafe_fdReady (fdFD fd) 0 0 0
 485                       if r /= 0 then safe_read
 486                                 else return 0
 487        -- XXX see note [nonblock]
 488  where
 489    do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
 490                      case r of
 491                        (-1) -> return 0
 492                        0    -> return (-1)
 493                        n    -> return (fromIntegral n)
 494    unsafe_read  = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
 495    safe_read    = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
 496
 497 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 498 writeRawBufferPtr loc !fd buf off len
 499   | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
 500   | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
 501                      if r /= 0
 502                         then write
 503                         else do threadWaitWrite (fromIntegral (fdFD fd)); write
 504   where
 505     do_write call = fromIntegral `fmap`
 506                       throwErrnoIfMinus1RetryMayBlock loc call
 507                         (threadWaitWrite (fromIntegral (fdFD fd)))
 508     write         = if threaded then safe_write else unsafe_write
 509     unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
 510     safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
 511
 512 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 513 writeRawBufferPtrNoBlock loc !fd buf off len
 514   | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
 515   | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
 516                      if r /= 0 then write
 517                                else return 0
 518   where
 519     do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
 520                        case r of
 521                          (-1) -> return 0
 522                          n    -> return (fromIntegral n)
 523     write         = if threaded then safe_write else unsafe_write
 524     unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
 525     safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
 526
 527 isNonBlocking :: FD -> Bool
 528 isNonBlocking fd = fdIsNonBlocking fd /= 0
 529
 530 foreign import ccall unsafe "fdReady"
 531   unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
 532
 533 #else /* mingw32_HOST_OS.... */
 534
 535 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 536 readRawBufferPtr loc !fd buf off len
 537   | threaded  = blockingReadRawBufferPtr loc fd buf off len
 538   | otherwise = asyncReadRawBufferPtr    loc fd buf off len
 539
 540 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 541 writeRawBufferPtr loc !fd buf off len
 542   | threaded  = blockingWriteRawBufferPtr loc fd buf off len
 543   | otherwise = asyncWriteRawBufferPtr    loc fd buf off len
 544
 545 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 546 readRawBufferPtrNoBlock = readRawBufferPtr
 547
 548 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 549 writeRawBufferPtrNoBlock = writeRawBufferPtr
 550
 551 -- Async versions of the read/write primitives, for the non-threaded RTS
 552
 553 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 554 asyncReadRawBufferPtr loc !fd buf off len = do
 555     (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
 556                         (fromIntegral len) (buf `plusPtr` off)
 557     if l == (-1)
 558       then
 559         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 560       else return (fromIntegral l)
 561
 562 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 563 asyncWriteRawBufferPtr loc !fd buf off len = do
 564     (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
 565                   (fromIntegral len) (buf `plusPtr` off)
 566     if l == (-1)
 567       then
 568         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 569       else return (fromIntegral l)
 570
 571 -- Blocking versions of the read/write primitives, for the threaded RTS
 572
 573 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 574 blockingReadRawBufferPtr loc fd buf off len
 575   = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
 576         if fdIsSocket fd
 577            then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
 578            else c_safe_read (fdFD fd) (buf `plusPtr` off) len
 579
 580 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
 581 blockingWriteRawBufferPtr loc fd buf off len
 582   = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
 583         if fdIsSocket fd
 584            then c_safe_send  (fdFD fd) (buf `plusPtr` off) len 0
 585            else c_safe_write (fdFD fd) (buf `plusPtr` off) len
 586
 587 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 588 -- These calls may block, but that's ok.
 589
 590 foreign import stdcall safe "recv"
 591    c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
 592
 593 foreign import stdcall safe "send"
 594    c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
 595
 596 #endif
 597
 598 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
 599
 600 -- -----------------------------------------------------------------------------
 601 -- utils
 602
 603 #ifndef mingw32_HOST_OS
 604 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CSsize -> IO CSsize -> IO CSsize
 605 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
 606   do
 607     res <- f
 608     if (res :: CSsize) == -1
 609       then do
 610         err <- getErrno
 611         if err == eINTR
 612           then throwErrnoIfMinus1RetryOnBlock loc f on_block
 613           else if err == eWOULDBLOCK || err == eAGAIN
 614                  then do on_block
 615                  else throwErrno loc
 616       else return res
 617 #endif
 618
 619 -- -----------------------------------------------------------------------------
 620 -- Locking/unlocking
 621
 622 #ifndef mingw32_HOST_OS
 623 foreign import ccall unsafe "lockFile"
 624   lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
 625
 626 foreign import ccall unsafe "unlockFile"
 627   unlockFile :: CInt -> IO CInt
 628 #endif
 629
 630 #if defined(DEBUG_DUMP)
 631 puts :: String -> IO ()
 632 puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)
 633             return ()
 634 #endif