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 import GHC.Base
  26 import GHC.Num
  27 import GHC.Real
  28 import GHC.Show
  29 import GHC.Enum
  30 import Data.Maybe
  31 import Control.Monad
  32 import Data.Typeable
  33
  34 import GHC.IO
  35 import GHC.IO.IOMode
  36 import GHC.IO.Buffer
  37 import GHC.IO.BufferedIO
  38 import qualified GHC.IO.Device
  39 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
  40 import GHC.Conc.IO
  41 import GHC.IO.Exception
  42
  43 import Foreign
  44 import Foreign.C
  45 import qualified System.Posix.Internals
  46 import System.Posix.Internals hiding (FD, setEcho, getEcho)
  47 import System.Posix.Types
  48 -- import GHC.Ptr
  49
  50 c_DEBUG_DUMP :: Bool
  51 c_DEBUG_DUMP = False
  52
  53 -- -----------------------------------------------------------------------------
  54 -- The file-descriptor IO device
  55
  56 data FD = FD {
  57   fdFD :: {-# UNPACK #-} !CInt,
  58 #ifdef mingw32_HOST_OS
  59   -- On Windows, a socket file descriptor needs to be read and written
  60   -- using different functions (send/recv).
  61   fdIsSocket_ :: {-# UNPACK #-} !Int
  62 #else
  63   -- On Unix we need to know whether this FD has O_NONBLOCK set.
  64   -- If it has, then we can use more efficient routines to read/write to it.
  65   -- It is always safe for this to be off.
  66   fdIsNonBlocking :: {-# UNPACK #-} !Int
  67 #endif
  68  }
  69  deriving Typeable
  70
  71 #ifdef mingw32_HOST_OS
  72 fdIsSocket :: FD -> Bool
  73 fdIsSocket fd = fdIsSocket_ fd /= 0
  74 #endif
  75
  76 instance Show FD where
  77   show fd = show (fdFD fd)
  78
  79 instance GHC.IO.Device.RawIO FD where
  80   read             = fdRead
  81   readNonBlocking  = fdReadNonBlocking
  82   write            = fdWrite
  83   writeNonBlocking = fdWriteNonBlocking
  84
  85 instance GHC.IO.Device.IODevice FD where
  86   ready         = ready
  87   close         = close
  88   isTerminal    = isTerminal
  89   isSeekable    = isSeekable
  90   seek          = seek
  91   tell          = tell
  92   getSize       = getSize
  93   setSize       = setSize
  94   setEcho       = setEcho
  95   getEcho       = getEcho
  96   setRaw        = setRaw
  97   devType       = devType
  98   dup           = dup
  99   dup2          = dup2
 100
 101 instance BufferedIO FD where
 102   newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
 103   fillReadBuffer    fd buf = readBuf' fd buf
 104   fillReadBuffer0   fd buf = readBufNonBlocking fd buf
 105   flushWriteBuffer  fd buf = writeBuf' fd buf
 106   flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
 107
 108 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
 109 readBuf' fd buf = do
 110   when c_DEBUG_DUMP $
 111       puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
 112   (r,buf') <- readBuf fd buf
 113   when c_DEBUG_DUMP $
 114       puts ("after: " ++ summaryBuffer buf' ++ "\n")
 115   return (r,buf')
 116
 117 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
 118 writeBuf' fd buf = do
 119   when c_DEBUG_DUMP $
 120       puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
 121   writeBuf fd buf
 122
 123 -- -----------------------------------------------------------------------------
 124 -- opening files
 125
 126 -- | Open a file and make an 'FD' for it.  Truncates the file to zero
 127 -- size when the `IOMode` is `WriteMode`.  Puts the file descriptor
 128 -- into non-blocking mode on Unix systems.
 129 openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
 130 openFile filepath iomode =
 131   withFilePath filepath $ \ f ->
 132
 133     let
 134       oflags1 = case iomode of
 135                   ReadMode      -> read_flags
 136 #ifdef mingw32_HOST_OS
 137                   WriteMode     -> write_flags .|. o_TRUNC
 138 #else
 139                   WriteMode     -> write_flags
 140 #endif
 141                   ReadWriteMode -> rw_flags
 142                   AppendMode    -> append_flags
 143
 144 #ifdef mingw32_HOST_OS
 145       binary_flags = o_BINARY
 146 #else
 147       binary_flags = 0
 148 #endif
 149
 150       oflags = oflags1 .|. binary_flags
 151     in do
 152
 153     -- the old implementation had a complicated series of three opens,
 154     -- which is perhaps because we have to be careful not to open
 155     -- directories.  However, the man pages I've read say that open()
 156     -- always returns EISDIR if the file is a directory and was opened
 157     -- for writing, so I think we're ok with a single open() here...
 158     fd <- throwErrnoIfMinus1Retry "openFile"
 159                 (c_open f oflags 0o666)
 160
 161     (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
 162                             False{-not a socket-}
 163                             True{-is non-blocking-}
 164             `catchAny` \e -> do _ <- c_close fd
 165                                 throwIO e
 166
 167 #ifndef mingw32_HOST_OS
 168         -- we want to truncate() if this is an open in WriteMode, but only
 169         -- if the target is a RegularFile.  ftruncate() fails on special files
 170         -- like /dev/null.
 171     if iomode == WriteMode && fd_type == RegularFile
 172       then setSize fD 0
 173       else return ()
 174 #endif
 175
 176     return (fD,fd_type)
 177
 178 std_flags, output_flags, read_flags, write_flags, rw_flags,
 179     append_flags :: CInt
 180 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 181 output_flags = std_flags    .|. o_CREAT
 182 read_flags   = std_flags    .|. o_RDONLY
 183 write_flags  = output_flags .|. o_WRONLY
 184 rw_flags     = output_flags .|. o_RDWR
 185 append_flags = write_flags  .|. o_APPEND
 186
 187
 188 -- | Make a 'FD' from an existing file descriptor.  Fails if the FD
 189 -- refers to a directory.  If the FD refers to a file, `mkFD` locks
 190 -- the file according to the Haskell 98 single writer/multiple reader
 191 -- locking semantics (this is why we need the `IOMode` argument too).
 192 mkFD :: CInt
 193      -> IOMode
 194      -> Maybe (IODeviceType, CDev, CIno)
 195      -- the results of fdStat if we already know them, or we want
 196      -- to prevent fdToHandle_stat from doing its own stat.
 197      -- These are used for:
 198      --   - we fail if the FD refers to a directory
 199      --   - if the FD refers to a file, we lock it using (cdev,cino)
 200      -> Bool   -- ^ is a socket (on Windows)
 201      -> Bool   -- ^ is in non-blocking mode on Unix
 202      -> IO (FD,IODeviceType)
 203
 204 mkFD fd iomode mb_stat is_socket is_nonblock = do
 205
 206     let _ = (is_socket, is_nonblock) -- warning suppression
 207
 208     (fd_type,dev,ino) <-
 209         case mb_stat of
 210           Nothing   -> fdStat fd
 211           Just stat -> return stat
 212
 213     let write = case iomode of
 214                    ReadMode -> False
 215                    _ -> True
 216
 217 #ifdef mingw32_HOST_OS
 218     _ <- setmode fd True -- unconditionally set binary mode
 219     let _ = (dev,ino,write) -- 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 #ifdef mingw32_HOST_OS
 251 foreign import ccall unsafe "__hscore_setmode"
 252   setmode :: CInt -> Bool -> IO CInt
 253 #endif
 254
 255 -- -----------------------------------------------------------------------------
 256 -- Standard file descriptors
 257
 258 stdFD :: CInt -> FD
 259 stdFD fd = FD { fdFD = fd,
 260 #ifdef mingw32_HOST_OS
 261                 fdIsSocket_ = 0
 262 #else
 263                 fdIsNonBlocking = 0
 264    -- We don't set non-blocking mode on standard handles, because it may
 265    -- confuse other applications attached to the same TTY/pipe
 266    -- see Note [nonblock]
 267 #endif
 268                 }
 269
 270 stdin, stdout, stderr :: FD
 271 stdin  = stdFD 0
 272 stdout = stdFD 1
 273 stderr = stdFD 2
 274
 275 -- -----------------------------------------------------------------------------
 276 -- Operations on file descriptors
 277
 278 close :: FD -> IO ()
 279 close fd =
 280 #ifndef mingw32_HOST_OS
 281   (flip finally) (release fd) $ do
 282 #endif
 283   throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 284 #ifdef mingw32_HOST_OS
 285     if fdIsSocket fd then
 286        c_closesocket (fdFD fd)
 287     else
 288 #endif
 289        c_close (fdFD fd)
 290
 291 release :: FD -> IO ()
 292 #ifdef mingw32_HOST_OS
 293 release _ = return ()
 294 #else
 295 release fd = do _ <- unlockFile (fdFD fd)
 296                 return ()
 297 #endif
 298
 299 #ifdef mingw32_HOST_OS
 300 foreign import stdcall unsafe "HsBase.h closesocket"
 301    c_closesocket :: CInt -> IO CInt
 302 #endif
 303
 304 isSeekable :: FD -> IO Bool
 305 isSeekable fd = do
 306   t <- devType fd
 307   return (t == RegularFile || t == RawDevice)
 308
 309 seek :: FD -> SeekMode -> Integer -> IO ()
 310 seek fd mode off = do
 311   throwErrnoIfMinus1Retry_ "seek" $
 312      c_lseek (fdFD fd) (fromIntegral off) seektype
 313  where
 314     seektype :: CInt
 315     seektype = case mode of
 316                    AbsoluteSeek -> sEEK_SET
 317                    RelativeSeek -> sEEK_CUR
 318                    SeekFromEnd  -> sEEK_END
 319
 320 tell :: FD -> IO Integer
 321 tell fd =
 322  fromIntegral `fmap`
 323    (throwErrnoIfMinus1Retry "hGetPosn" $
 324       c_lseek (fdFD fd) 0 sEEK_CUR)
 325
 326 getSize :: FD -> IO Integer
 327 getSize fd = fdFileSize (fdFD fd)
 328
 329 setSize :: FD -> Integer -> IO ()
 330 setSize fd size = do
 331   throwErrnoIf_ (/=0) "GHC.IO.FD.setSize"  $
 332      c_ftruncate (fdFD fd) (fromIntegral size)
 333
 334 devType :: FD -> IO IODeviceType
 335 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
 336
 337 dup :: FD -> IO FD
 338 dup fd = do
 339   newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
 340   return fd{ fdFD = newfd }
 341
 342 dup2 :: FD -> FD -> IO FD
 343 dup2 fd fdto = do
 344   -- Windows' dup2 does not return the new descriptor, unlike Unix
 345   throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
 346     c_dup2 (fdFD fd) (fdFD fdto)
 347   return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
 348
 349 setNonBlockingMode :: FD -> Bool -> IO FD
 350 setNonBlockingMode fd set = do
 351   setNonBlockingFD (fdFD fd) set
 352 #if defined(mingw32_HOST_OS)
 353   return fd
 354 #else
 355   return fd{ fdIsNonBlocking = fromEnum set }
 356 #endif
 357
 358 ready :: FD -> Bool -> Int -> IO Bool
 359 ready fd write msecs = do
 360   r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
 361           fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
 362                             (fromIntegral msecs)
 363 #if defined(mingw32_HOST_OS)
 364                           (fromIntegral $ fromEnum $ fdIsSocket fd)
 365 #else
 366                           0
 367 #endif
 368   return (toEnum (fromIntegral r))
 369
 370 foreign import ccall safe "fdReady"
 371   fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
 372
 373 -- ---------------------------------------------------------------------------
 374 -- Terminal-related stuff
 375
 376 isTerminal :: FD -> IO Bool
 377 isTerminal fd =
 378 #if defined(mingw32_HOST_OS)
 379     is_console (fdFD fd) >>= return.toBool
 380 #else
 381     c_isatty (fdFD fd) >>= return.toBool
 382 #endif
 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
 398   = readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
 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 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 do
 585              r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
 586              when (r == -1) c_maperrno
 587              return r
 588       -- we don't trust write() to give us the correct errno, and
 589       -- instead do the errno conversion from GetLastError()
 590       -- ourselves.  The main reason is that we treat ERROR_NO_DATA
 591       -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
 592       -- for this case.  We need to detect EPIPE correctly, because it
 593       -- shouldn't be reported as an error when it happens on stdout.
 594
 595 foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
 596    c_maperrno :: IO ()
 597
 598 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 599 -- These calls may block, but that's ok.
 600
 601 foreign import stdcall safe "recv"
 602    c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
 603
 604 foreign import stdcall safe "send"
 605    c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
 606
 607 #endif
 608
 609 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
 610
 611 -- -----------------------------------------------------------------------------
 612 -- utils
 613
 614 #ifndef mingw32_HOST_OS
 615 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CSsize -> IO CSsize -> IO CSsize
 616 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
 617   do
 618     res <- f
 619     if (res :: CSsize) == -1
 620       then do
 621         err <- getErrno
 622         if err == eINTR
 623           then throwErrnoIfMinus1RetryOnBlock loc f on_block
 624           else if err == eWOULDBLOCK || err == eAGAIN
 625                  then do on_block
 626                  else throwErrno loc
 627       else return res
 628 #endif
 629
 630 -- -----------------------------------------------------------------------------
 631 -- Locking/unlocking
 632
 633 #ifndef mingw32_HOST_OS
 634 foreign import ccall unsafe "lockFile"
 635   lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
 636
 637 foreign import ccall unsafe "unlockFile"
 638   unlockFile :: CInt -> IO CInt
 639 #endif
 640
 641 puts :: String -> IO ()
 642 puts s = do _ <- withCStringLen s $ \(p,len) ->
 643                      c_write 1 (castPtr p) (fromIntegral len)
 644             return ()