GHC/IO/FD.hs

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