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