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 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   when c_DEBUG_DUMP $
 112       puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
 113   (r,buf') <- readBuf fd buf
 114   when c_DEBUG_DUMP $
 115       puts ("after: " ++ summaryBuffer buf' ++ "\n")
 116   return (r,buf')
 117
 118 writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
 119 writeBuf' fd buf = do
 120   when c_DEBUG_DUMP $
 121       puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
 122   writeBuf fd buf
 123
 124 -- -----------------------------------------------------------------------------
 125 -- opening files
 126
 127 -- | Open a file and make an 'FD' for it.  Truncates the file to zero
 128 -- size when the `IOMode` is `WriteMode`.  Puts the file descriptor
 129 -- into non-blocking mode on Unix systems.
 130 openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
 131 openFile filepath iomode =
 132   withFilePath filepath $ \ f ->
 133
 134     let
 135       oflags1 = case iomode of
 136                   ReadMode      -> read_flags
 137 #ifdef mingw32_HOST_OS
 138                   WriteMode     -> write_flags .|. o_TRUNC
 139 #else
 140                   WriteMode     -> write_flags
 141 #endif
 142                   ReadWriteMode -> rw_flags
 143                   AppendMode    -> append_flags
 144
 145 #ifdef mingw32_HOST_OS
 146       binary_flags = o_BINARY
 147 #else
 148       binary_flags = 0
 149 #endif
 150
 151       oflags = oflags1 .|. binary_flags
 152     in do
 153
 154     -- the old implementation had a complicated series of three opens,
 155     -- which is perhaps because we have to be careful not to open
 156     -- directories.  However, the man pages I've read say that open()
 157     -- always returns EISDIR if the file is a directory and was opened
 158     -- for writing, so I think we're ok with a single open() here...
 159     fd <- throwErrnoIfMinus1Retry "openFile"
 160                 (c_open f oflags 0o666)
 161
 162     (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
 163                             False{-not a socket-}
 164                             True{-is non-blocking-}
 165             `catchAny` \e -> do _ <- c_close fd
 166                                 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) $
 283 #endif
 284   do let closer realFd =
 285            throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 286 #ifdef mingw32_HOST_OS
 287            if fdIsSocket fd then
 288              c_closesocket (fromIntegral realFd)
 289            else
 290 #endif
 291              c_close (fromIntegral realFd)
 292      closeFdWith closer (fromIntegral (fdFD fd))
 293
 294 release :: FD -> IO ()
 295 #ifdef mingw32_HOST_OS
 296 release _ = return ()
 297 #else
 298 release fd = do _ <- unlockFile (fdFD fd)
 299                 return ()
 300 #endif
 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  where
 317     seektype :: CInt
 318     seektype = case mode of
 319                    AbsoluteSeek -> sEEK_SET
 320                    RelativeSeek -> sEEK_CUR
 321                    SeekFromEnd  -> sEEK_END
 322
 323 tell :: FD -> IO Integer
 324 tell fd =
 325  fromIntegral `fmap`
 326    (throwErrnoIfMinus1Retry "hGetPosn" $
 327       c_lseek (fdFD fd) 0 sEEK_CUR)
 328
 329 getSize :: FD -> IO Integer
 330 getSize fd = fdFileSize (fdFD fd)
 331
 332 setSize :: FD -> Integer -> IO ()
 333 setSize fd size = do
 334   throwErrnoIf_ (/=0) "GHC.IO.FD.setSize"  $
 335      c_ftruncate (fdFD fd) (fromIntegral size)
 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 =
 381 #if defined(mingw32_HOST_OS)
 382     is_console (fdFD fd) >>= return.toBool
 383 #else
 384     c_isatty (fdFD fd) >>= return.toBool
 385 #endif
 386
 387 setEcho :: FD -> Bool -> IO ()
 388 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
 389
 390 getEcho :: FD -> IO Bool
 391 getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
 392
 393 setRaw :: FD -> Bool -> IO ()
 394 setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
 395
 396 -- -----------------------------------------------------------------------------
 397 -- Reading and Writing
 398
 399 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
 400 fdRead fd ptr bytes
 401   = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
 402        ; return (fromIntegral r) }
 403
 404 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
 405 fdReadNonBlocking fd ptr bytes = do
 406   r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
 407            0 (fromIntegral bytes)
 408   case fromIntegral r of
 409     (-1) -> return (Nothing)
 410     n    -> return (Just n)
 411
 412
 413 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
 414 fdWrite fd ptr bytes = do
 415   res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
 416   let res' = fromIntegral res
 417   if res' < bytes
 418      then fdWrite fd (ptr `plusPtr` res') (bytes - res')
 419      else return ()
 420
 421 -- XXX ToDo: this isn't non-blocking
 422 fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
 423 fdWriteNonBlocking fd ptr bytes = do
 424   res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
 425             (fromIntegral bytes)
 426   return (fromIntegral res)
 427
 428 -- -----------------------------------------------------------------------------
 429 -- FD operations
 430
 431 -- Low level routines for reading/writing to (raw)buffers:
 432
 433 #ifndef mingw32_HOST_OS
 434
 435 {-
 436 NOTE [nonblock]:
 437
 438 Unix has broken semantics when it comes to non-blocking I/O: you can
 439 set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
 440 attached to the same underlying file, pipe or TTY; there's no way to
 441 have private non-blocking behaviour for an FD.  See bug #724.
 442
 443 We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
 444 come from external sources or are exposed externally are left in
 445 blocking mode.  This solution has some problems though.  We can't
 446 completely simulate a non-blocking read without O_NONBLOCK: several
 447 cases are wrong here.  The cases that are wrong:
 448
 449   * reading/writing to a blocking FD in non-threaded mode.
 450     In threaded mode, we just make a safe call to read().
 451     In non-threaded mode we call select() before attempting to read,
 452     but that leaves a small race window where the data can be read
 453     from the file descriptor before we issue our blocking read().
 454   * readRawBufferNoBlock for a blocking FD
 455
 456 NOTE [2363]:
 457
 458 In the threaded RTS we could just make safe calls to read()/write()
 459 for file descriptors in blocking mode without worrying about blocking
 460 other threads, but the problem with this is that the thread will be
 461 uninterruptible while it is blocked in the foreign call.  See #2363.
 462 So now we always call fdReady() before reading, and if fdReady
 463 indicates that there's no data, we call threadWaitRead.
 464
 465 -}
 466
 467 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
 468 readRawBufferPtr loc !fd buf off len
 469   | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
 470   | otherwise    = do r <- throwErrnoIfMinus1 loc
 471                                 (unsafe_fdReady (fdFD fd) 0 0 0)
 472                       if r /= 0
 473                         then read
 474                         else do threadWaitRead (fromIntegral (fdFD fd)); read
 475   where
 476     do_read call = fromIntegral `fmap`
 477                       throwErrnoIfMinus1RetryMayBlock loc call
 478                             (threadWaitRead (fromIntegral (fdFD fd)))
 479     read        = if threaded then safe_read else unsafe_read
 480     unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
 481     safe_read   = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
 482
 483 -- return: -1 indicates EOF, >=0 is bytes read
 484 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
 485 readRawBufferPtrNoBlock loc !fd buf off len
 486   | isNonBlocking fd  = unsafe_read -- unsafe is ok, it can't block
 487   | otherwise    = do r <- unsafe_fdReady (fdFD fd) 0 0 0
 488                       if r /= 0 then safe_read
 489                                 else return 0
 490        -- XXX see note [nonblock]
 491  where
 492    do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
 493                      case r of
 494                        (-1) -> return 0
 495                        0    -> return (-1)
 496                        n    -> return (fromIntegral n)
 497    unsafe_read  = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
 498    safe_read    = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
 499
 500 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 501 writeRawBufferPtr loc !fd buf off len
 502   | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
 503   | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
 504                      if r /= 0
 505                         then write
 506                         else do threadWaitWrite (fromIntegral (fdFD fd)); write
 507   where
 508     do_write call = fromIntegral `fmap`
 509                       throwErrnoIfMinus1RetryMayBlock loc call
 510                         (threadWaitWrite (fromIntegral (fdFD fd)))
 511     write         = if threaded then safe_write else unsafe_write
 512     unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
 513     safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
 514
 515 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 516 writeRawBufferPtrNoBlock loc !fd buf off len
 517   | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
 518   | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
 519                      if r /= 0 then write
 520                                else return 0
 521   where
 522     do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
 523                        case r of
 524                          (-1) -> return 0
 525                          n    -> return (fromIntegral n)
 526     write         = if threaded then safe_write else unsafe_write
 527     unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
 528     safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
 529
 530 isNonBlocking :: FD -> Bool
 531 isNonBlocking fd = fdIsNonBlocking fd /= 0
 532
 533 foreign import ccall unsafe "fdReady"
 534   unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
 535
 536 #else /* mingw32_HOST_OS.... */
 537
 538 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 539 readRawBufferPtr loc !fd buf off len
 540   | threaded  = blockingReadRawBufferPtr loc fd buf off len
 541   | otherwise = asyncReadRawBufferPtr    loc fd buf off len
 542
 543 writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 544 writeRawBufferPtr loc !fd buf off len
 545   | threaded  = blockingWriteRawBufferPtr loc fd buf off len
 546   | otherwise = asyncWriteRawBufferPtr    loc fd buf off len
 547
 548 readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 549 readRawBufferPtrNoBlock = readRawBufferPtr
 550
 551 writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 552 writeRawBufferPtrNoBlock = writeRawBufferPtr
 553
 554 -- Async versions of the read/write primitives, for the non-threaded RTS
 555
 556 asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 557 asyncReadRawBufferPtr loc !fd buf off len = do
 558     (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
 559                         (fromIntegral len) (buf `plusPtr` off)
 560     if l == (-1)
 561       then
 562         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 563       else return (fromIntegral l)
 564
 565 asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 566 asyncWriteRawBufferPtr loc !fd buf off len = do
 567     (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
 568                   (fromIntegral len) (buf `plusPtr` off)
 569     if l == (-1)
 570       then
 571         ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
 572       else return (fromIntegral l)
 573
 574 -- Blocking versions of the read/write primitives, for the threaded RTS
 575
 576 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 577 blockingReadRawBufferPtr loc fd buf off len
 578   = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
 579         if fdIsSocket fd
 580            then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
 581            else c_safe_read (fdFD fd) (buf `plusPtr` off) len
 582
 583 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
 584 blockingWriteRawBufferPtr loc fd buf off len
 585   = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
 586         if fdIsSocket fd
 587            then c_safe_send  (fdFD fd) (buf `plusPtr` off) len 0
 588            else do
 589              r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
 590              when (r == -1) c_maperrno
 591              return r
 592       -- we don't trust write() to give us the correct errno, and
 593       -- instead do the errno conversion from GetLastError()
 594       -- ourselves.  The main reason is that we treat ERROR_NO_DATA
 595       -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
 596       -- for this case.  We need to detect EPIPE correctly, because it
 597       -- shouldn't be reported as an error when it happens on stdout.
 598
 599 foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
 600    c_maperrno :: IO ()
 601
 602 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 603 -- These calls may block, but that's ok.
 604
 605 foreign import stdcall safe "recv"
 606    c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
 607
 608 foreign import stdcall safe "send"
 609    c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
 610
 611 #endif
 612
 613 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
 614
 615 -- -----------------------------------------------------------------------------
 616 -- utils
 617
 618 #ifndef mingw32_HOST_OS
 619 throwErrnoIfMinus1RetryOnBlock  :: String -> IO CSsize -> IO CSsize -> IO CSsize
 620 throwErrnoIfMinus1RetryOnBlock loc f on_block  =
 621   do
 622     res <- f
 623     if (res :: CSsize) == -1
 624       then do
 625         err <- getErrno
 626         if err == eINTR
 627           then throwErrnoIfMinus1RetryOnBlock loc f on_block
 628           else if err == eWOULDBLOCK || err == eAGAIN
 629                  then do on_block
 630                  else throwErrno loc
 631       else return res
 632 #endif
 633
 634 -- -----------------------------------------------------------------------------
 635 -- Locking/unlocking
 636
 637 #ifndef mingw32_HOST_OS
 638 foreign import ccall unsafe "lockFile"
 639   lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
 640
 641 foreign import ccall unsafe "unlockFile"
 642   unlockFile :: CInt -> IO CInt
 643 #endif
 644
 645 puts :: String -> IO ()
 646 puts s = do _ <- withCStringLen s $ \(p,len) ->
 647                      c_write 1 (castPtr p) (fromIntegral len)
 648             return ()