GHC/IO/FD.hs

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