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