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