FD.hs 22.7 KB
Newer Older
dterei's avatar
dterei committed
1
{-# LANGUAGE Trustworthy #-}
2 3 4 5
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , BangPatterns
  #-}
6
{-# OPTIONS_GHC -Wno-identities #-}
7
-- Whether there are identities depends on the platform
8
{-# OPTIONS_HADDOCK hide #-}
9

10 11 12 13 14
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO.FD
-- Copyright   :  (c) The University of Glasgow, 1994-2008
-- License     :  see libraries/base/LICENSE
15
--
16 17 18 19 20 21 22 23 24
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Raw read/write operations on file descriptors
--
-----------------------------------------------------------------------------

module GHC.IO.FD (
25 26 27 28 29 30
        FD(..),
        openFile, mkFD, release,
        setNonBlockingMode,
        readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
        stdin, stdout, stderr
    ) where
31 32 33 34 35 36 37 38 39 40 41 42 43

import GHC.Base
import GHC.Num
import GHC.Real
import GHC.Show
import GHC.Enum

import GHC.IO
import GHC.IO.IOMode
import GHC.IO.Buffer
import GHC.IO.BufferedIO
import qualified GHC.IO.Device
import GHC.IO.Device (SeekMode(..), IODeviceType(..))
Simon Marlow's avatar
Simon Marlow committed
44
import GHC.Conc.IO
45
import GHC.IO.Exception
46 47 48
#ifdef mingw32_HOST_OS
import GHC.Windows
#endif
49 50 51 52 53 54 55

import Foreign
import Foreign.C
import qualified System.Posix.Internals
import System.Posix.Internals hiding (FD, setEcho, getEcho)
import System.Posix.Types

56 57 58 59 60 61 62 63 64 65
#ifdef mingw32_HOST_OS
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif

Ian Lynagh's avatar
Ian Lynagh committed
66 67 68
c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = False

69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
-- -----------------------------------------------------------------------------
-- The file-descriptor IO device

data FD = FD {
  fdFD :: {-# UNPACK #-} !CInt,
#ifdef mingw32_HOST_OS
  -- On Windows, a socket file descriptor needs to be read and written
  -- using different functions (send/recv).
  fdIsSocket_ :: {-# UNPACK #-} !Int
#else
  -- On Unix we need to know whether this FD has O_NONBLOCK set.
  -- If it has, then we can use more efficient routines to read/write to it.
  -- It is always safe for this to be off.
  fdIsNonBlocking :: {-# UNPACK #-} !Int
#endif
 }

#ifdef mingw32_HOST_OS
fdIsSocket :: FD -> Bool
fdIsSocket fd = fdIsSocket_ fd /= 0
#endif

91
-- | @since 4.1.0.0
92 93 94
instance Show FD where
  show fd = show (fdFD fd)

95
-- | @since 4.1.0.0
96 97 98 99 100 101
instance GHC.IO.Device.RawIO FD where
  read             = fdRead
  readNonBlocking  = fdReadNonBlocking
  write            = fdWrite
  writeNonBlocking = fdWriteNonBlocking

102
-- | @since 4.1.0.0
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
instance GHC.IO.Device.IODevice FD where
  ready         = ready
  close         = close
  isTerminal    = isTerminal
  isSeekable    = isSeekable
  seek          = seek
  tell          = tell
  getSize       = getSize
  setSize       = setSize
  setEcho       = setEcho
  getEcho       = getEcho
  setRaw        = setRaw
  devType       = devType
  dup           = dup
  dup2          = dup2

119 120 121 122 123 124 125
-- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
-- taken from the value of BUFSIZ on the current platform.  This value
-- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
-- on Linux.  So let's just use a decent size on every platform:
dEFAULT_FD_BUFFER_SIZE :: Int
dEFAULT_FD_BUFFER_SIZE = 8096

126
-- | @since 4.1.0.0
127
instance BufferedIO FD where
128
  newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
129 130 131 132 133 134 135
  fillReadBuffer    fd buf = readBuf' fd buf
  fillReadBuffer0   fd buf = readBufNonBlocking fd buf
  flushWriteBuffer  fd buf = writeBuf' fd buf
  flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf

readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' fd buf = do
Ian Lynagh's avatar
Ian Lynagh committed
136 137
  when c_DEBUG_DUMP $
      puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
138
  (r,buf') <- readBuf fd buf
Ian Lynagh's avatar
Ian Lynagh committed
139 140
  when c_DEBUG_DUMP $
      puts ("after: " ++ summaryBuffer buf' ++ "\n")
141 142
  return (r,buf')

143
writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
144
writeBuf' fd buf = do
Ian Lynagh's avatar
Ian Lynagh committed
145 146
  when c_DEBUG_DUMP $
      puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
147 148 149 150 151 152
  writeBuf fd buf

-- -----------------------------------------------------------------------------
-- opening files

-- | Open a file and make an 'FD' for it.  Truncates the file to zero
153 154 155 156 157 158 159
-- size when the `IOMode` is `WriteMode`.
openFile
  :: FilePath -- ^ file to open
  -> IOMode   -- ^ mode in which to open the file
  -> Bool     -- ^ open the file in non-blocking mode?
  -> IO (FD,IODeviceType)

160
openFile filepath iomode non_blocking =
161
  withFilePath filepath $ \ f ->
162

163
    let
164 165 166 167 168 169 170 171 172 173
      oflags1 = case iomode of
                  ReadMode      -> read_flags
                  WriteMode     -> write_flags
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

#ifdef mingw32_HOST_OS
      binary_flags = o_BINARY
#else
      binary_flags = 0
174
#endif
175

176 177 178 179
      oflags2 = oflags1 .|. binary_flags

      oflags | non_blocking = oflags2 .|. nonblock_flags
             | otherwise    = oflags2
180 181 182 183 184 185 186 187
    in do

    -- the old implementation had a complicated series of three opens,
    -- which is perhaps because we have to be careful not to open
    -- directories.  However, the man pages I've read say that open()
    -- always returns EISDIR if the file is a directory and was opened
    -- for writing, so I think we're ok with a single open() here...
    fd <- throwErrnoIfMinus1Retry "openFile"
188 189
                (if non_blocking then c_open      f oflags 0o666
                                 else c_safe_open f oflags 0o666)
190 191

    (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
192
                            False{-not a socket-}
193
                            non_blocking
194 195
            `catchAny` \e -> do _ <- c_close fd
                                throwIO e
196

197 198 199 200 201
    -- we want to truncate() if this is an open in WriteMode, but only
    -- if the target is a RegularFile.  ftruncate() fails on special files
    -- like /dev/null.
    when (iomode == WriteMode && fd_type == RegularFile) $
      setSize fD 0
202 203 204 205

    return (fD,fd_type)

std_flags, output_flags, read_flags, write_flags, rw_flags,
206 207
    append_flags, nonblock_flags :: CInt
std_flags    = o_NOCTTY
208
output_flags = std_flags    .|. o_CREAT
209
read_flags   = std_flags    .|. o_RDONLY
210 211 212
write_flags  = output_flags .|. o_WRONLY
rw_flags     = output_flags .|. o_RDWR
append_flags = write_flags  .|. o_APPEND
213
nonblock_flags = o_NONBLOCK
214 215 216 217


-- | Make a 'FD' from an existing file descriptor.  Fails if the FD
-- refers to a directory.  If the FD refers to a file, `mkFD` locks
218
-- the file according to the Haskell 2010 single writer/multiple reader
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
-- locking semantics (this is why we need the `IOMode` argument too).
mkFD :: CInt
     -> IOMode
     -> Maybe (IODeviceType, CDev, CIno)
     -- the results of fdStat if we already know them, or we want
     -- to prevent fdToHandle_stat from doing its own stat.
     -- These are used for:
     --   - we fail if the FD refers to a directory
     --   - if the FD refers to a file, we lock it using (cdev,cino)
     -> Bool   -- ^ is a socket (on Windows)
     -> Bool   -- ^ is in non-blocking mode on Unix
     -> IO (FD,IODeviceType)

mkFD fd iomode mb_stat is_socket is_nonblock = do

    let _ = (is_socket, is_nonblock) -- warning suppression

236
    (fd_type,dev,ino) <-
237 238 239 240 241 242 243 244 245
        case mb_stat of
          Nothing   -> fdStat fd
          Just stat -> return stat

    let write = case iomode of
                   ReadMode -> False
                   _ -> True

    case fd_type of
246
        Directory ->
247 248 249 250 251
           ioException (IOError Nothing InappropriateType "openFile"
                           "is a directory" Nothing Nothing)

        -- regular files need to be locked
        RegularFile -> do
252 253 254 255
           -- On Windows we need an additional call to get a unique device id
           -- and inode, since fstat just returns 0 for both.
           (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino
           r <- lockFile fd unique_dev unique_ino (fromBool write)
256 257 258 259 260 261
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing Nothing)

        _other_type -> return ()

262
#ifdef mingw32_HOST_OS
263
    when (not is_socket) $ setmode fd True >> return ()
264 265
#endif

266 267 268 269 270 271 272 273 274
    return (FD{ fdFD = fd,
#ifndef mingw32_HOST_OS
                fdIsNonBlocking = fromEnum is_nonblock
#else
                fdIsSocket_ = fromEnum is_socket
#endif
              },
            fd_type)

275 276
getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)
#ifndef mingw32_HOST_OS
pcapriotti's avatar
pcapriotti committed
277
getUniqueFileInfo _ dev ino = return (fromIntegral dev, fromIntegral ino)
278 279 280
#else
getUniqueFileInfo fd _ _ = do
  with 0 $ \devptr -> do
Austin Seipp's avatar
Austin Seipp committed
281 282 283
    with 0 $ \inoptr -> do
      c_getUniqueFileInfo fd devptr inoptr
      liftM2 (,) (peek devptr) (peek inoptr)
284 285
#endif

286 287 288 289 290
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "__hscore_setmode"
  setmode :: CInt -> Bool -> IO CInt
#endif

291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315
-- -----------------------------------------------------------------------------
-- Standard file descriptors

stdFD :: CInt -> FD
stdFD fd = FD { fdFD = fd,
#ifdef mingw32_HOST_OS
                fdIsSocket_ = 0
#else
                fdIsNonBlocking = 0
   -- We don't set non-blocking mode on standard handles, because it may
   -- confuse other applications attached to the same TTY/pipe
   -- see Note [nonblock]
#endif
                }

stdin, stdout, stderr :: FD
stdin  = stdFD 0
stdout = stdFD 1
stderr = stdFD 2

-- -----------------------------------------------------------------------------
-- Operations on file descriptors

close :: FD -> IO ()
close fd =
Ian Lynagh's avatar
Ian Lynagh committed
316 317
  do let closer realFd =
           throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
318
#ifdef mingw32_HOST_OS
Ian Lynagh's avatar
Ian Lynagh committed
319 320 321
           if fdIsSocket fd then
             c_closesocket (fromIntegral realFd)
           else
322
#endif
Ian Lynagh's avatar
Ian Lynagh committed
323
             c_close (fromIntegral realFd)
324 325 326 327 328 329

     -- release the lock *first*, because otherwise if we're preempted
     -- after closing but before releasing, the FD may have been reused.
     -- (#7646)
     release fd

Ian Lynagh's avatar
Ian Lynagh committed
330
     closeFdWith closer (fromIntegral (fdFD fd))
331 332

release :: FD -> IO ()
333 334
release fd = do _ <- unlockFile (fdFD fd)
                return ()
335 336

#ifdef mingw32_HOST_OS
337
foreign import WINDOWS_CCONV unsafe "HsBase.h closesocket"
338 339 340 341 342 343 344 345 346 347
   c_closesocket :: CInt -> IO CInt
#endif

isSeekable :: FD -> IO Bool
isSeekable fd = do
  t <- devType fd
  return (t == RegularFile || t == RawDevice)

seek :: FD -> SeekMode -> Integer -> IO ()
seek fd mode off = do
348
  throwErrnoIfMinus1Retry_ "seek" $
349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365
     c_lseek (fdFD fd) (fromIntegral off) seektype
 where
    seektype :: CInt
    seektype = case mode of
                   AbsoluteSeek -> sEEK_SET
                   RelativeSeek -> sEEK_CUR
                   SeekFromEnd  -> sEEK_END

tell :: FD -> IO Integer
tell fd =
 fromIntegral `fmap`
   (throwErrnoIfMinus1Retry "hGetPosn" $
      c_lseek (fdFD fd) 0 sEEK_CUR)

getSize :: FD -> IO Integer
getSize fd = fdFileSize (fdFD fd)

366
setSize :: FD -> Integer -> IO ()
367
setSize fd size = do
368
  throwErrnoIf_ (/=0) "GHC.IO.FD.setSize"  $
369 370 371 372 373 374 375 376 377 378 379 380 381
     c_ftruncate (fdFD fd) (fromIntegral size)

devType :: FD -> IO IODeviceType
devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty

dup :: FD -> IO FD
dup fd = do
  newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
  return fd{ fdFD = newfd }

dup2 :: FD -> FD -> IO FD
dup2 fd fdto = do
  -- Windows' dup2 does not return the new descriptor, unlike Unix
382
  throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
383 384 385
    c_dup2 (fdFD fd) (fdFD fdto)
  return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD

386
setNonBlockingMode :: FD -> Bool -> IO FD
387
setNonBlockingMode fd set = do
388
  setNonBlockingFD (fdFD fd) set
Simon Marlow's avatar
Simon Marlow committed
389 390 391
#if defined(mingw32_HOST_OS)
  return fd
#else
392
  return fd{ fdIsNonBlocking = fromEnum set }
Simon Marlow's avatar
Simon Marlow committed
393
#endif
394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413

ready :: FD -> Bool -> Int -> IO Bool
ready fd write msecs = do
  r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
          fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
                            (fromIntegral msecs)
#if defined(mingw32_HOST_OS)
                          (fromIntegral $ fromEnum $ fdIsSocket fd)
#else
                          0
#endif
  return (toEnum (fromIntegral r))

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt

-- ---------------------------------------------------------------------------
-- Terminal-related stuff

isTerminal :: FD -> IO Bool
414 415
isTerminal fd =
#if defined(mingw32_HOST_OS)
416 417
    if fdIsSocket fd then return False
                     else is_console (fdFD fd) >>= return.toBool
418 419 420
#else
    c_isatty (fdFD fd) >>= return.toBool
#endif
421

422
setEcho :: FD -> Bool -> IO ()
423 424 425 426 427 428 429 430 431 432 433 434
setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on

getEcho :: FD -> IO Bool
getEcho fd = System.Posix.Internals.getEcho (fdFD fd)

setRaw :: FD -> Bool -> IO ()
setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)

-- -----------------------------------------------------------------------------
-- Reading and Writing

fdRead :: FD -> Ptr Word8 -> Int -> IO Int
435
fdRead fd ptr bytes
436 437
  = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
       ; return (fromIntegral r) }
438 439 440

fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
fdReadNonBlocking fd ptr bytes = do
441
  r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
442
           0 (fromIntegral bytes)
443
  case fromIntegral r of
444
    (-1) -> return (Nothing)
445
    n    -> return (Just n)
446 447 448 449 450 451


fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
fdWrite fd ptr bytes = do
  res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
  let res' = fromIntegral res
452
  if res' < bytes
Simon Marlow's avatar
Simon Marlow committed
453
     then fdWrite fd (ptr `plusPtr` res') (bytes - res')
454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484
     else return ()

-- XXX ToDo: this isn't non-blocking
fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
fdWriteNonBlocking fd ptr bytes = do
  res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
            (fromIntegral bytes)
  return (fromIntegral res)

-- -----------------------------------------------------------------------------
-- FD operations

-- Low level routines for reading/writing to (raw)buffers:

#ifndef mingw32_HOST_OS

{-
NOTE [nonblock]:

Unix has broken semantics when it comes to non-blocking I/O: you can
set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
attached to the same underlying file, pipe or TTY; there's no way to
have private non-blocking behaviour for an FD.  See bug #724.

We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
come from external sources or are exposed externally are left in
blocking mode.  This solution has some problems though.  We can't
completely simulate a non-blocking read without O_NONBLOCK: several
cases are wrong here.  The cases that are wrong:

  * reading/writing to a blocking FD in non-threaded mode.
485
    In threaded mode, we just make a safe call to read().
486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501
    In non-threaded mode we call select() before attempting to read,
    but that leaves a small race window where the data can be read
    from the file descriptor before we issue our blocking read().
  * readRawBufferNoBlock for a blocking FD

NOTE [2363]:

In the threaded RTS we could just make safe calls to read()/write()
for file descriptors in blocking mode without worrying about blocking
other threads, but the problem with this is that the thread will be
uninterruptible while it is blocked in the foreign call.  See #2363.
So now we always call fdReady() before reading, and if fdReady
indicates that there's no data, we call threadWaitRead.

-}

502
readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
503
readRawBufferPtr loc !fd !buf !off !len
504
  | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
505
  | otherwise    = do r <- throwErrnoIfMinus1 loc
506
                                (unsafe_fdReady (fdFD fd) 0 0 0)
507
                      if r /= 0
508 509 510
                        then read
                        else do threadWaitRead (fromIntegral (fdFD fd)); read
  where
511 512
    do_read call = fromIntegral `fmap`
                      throwErrnoIfMinus1RetryMayBlock loc call
513 514
                            (threadWaitRead (fromIntegral (fdFD fd)))
    read        = if threaded then safe_read else unsafe_read
515 516
    unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
    safe_read   = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
517 518

-- return: -1 indicates EOF, >=0 is bytes read
519
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
520
readRawBufferPtrNoBlock loc !fd !buf !off !len
521 522 523 524 525 526 527 528 529 530
  | isNonBlocking fd  = unsafe_read -- unsafe is ok, it can't block
  | otherwise    = do r <- unsafe_fdReady (fdFD fd) 0 0 0
                      if r /= 0 then safe_read
                                else return 0
       -- XXX see note [nonblock]
 where
   do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
                     case r of
                       (-1) -> return 0
                       0    -> return (-1)
531 532 533
                       n    -> return (fromIntegral n)
   unsafe_read  = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
   safe_read    = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
534

535
writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
536
writeRawBufferPtr loc !fd !buf !off !len
537 538
  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
539
                     if r /= 0
540 541 542
                        then write
                        else do threadWaitWrite (fromIntegral (fdFD fd)); write
  where
543 544
    do_write call = fromIntegral `fmap`
                      throwErrnoIfMinus1RetryMayBlock loc call
545 546
                        (threadWaitWrite (fromIntegral (fdFD fd)))
    write         = if threaded then safe_write else unsafe_write
547 548
    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
549

550
writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
551
writeRawBufferPtrNoBlock loc !fd !buf !off !len
552 553 554 555 556 557 558 559
  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0
                     if r /= 0 then write
                               else return 0
  where
    do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
                       case r of
                         (-1) -> return 0
560
                         n    -> return (fromIntegral n)
561
    write         = if threaded then safe_write else unsafe_write
562 563
    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
564 565 566 567 568 569 570 571 572

isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0

foreign import ccall unsafe "fdReady"
  unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt

#else /* mingw32_HOST_OS.... */

573
readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
574
readRawBufferPtr loc !fd !buf !off !len
575 576 577
  | threaded  = blockingReadRawBufferPtr loc fd buf off len
  | otherwise = asyncReadRawBufferPtr    loc fd buf off len

578
writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
579
writeRawBufferPtr loc !fd !buf !off !len
580 581 582
  | threaded  = blockingWriteRawBufferPtr loc fd buf off len
  | otherwise = asyncWriteRawBufferPtr    loc fd buf off len

583
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
584 585
readRawBufferPtrNoBlock = readRawBufferPtr

586
writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
587 588 589 590
writeRawBufferPtrNoBlock = writeRawBufferPtr

-- Async versions of the read/write primitives, for the non-threaded RTS

591
asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
592
asyncReadRawBufferPtr loc !fd !buf !off !len = do
593
    (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
594 595
                        (fromIntegral len) (buf `plusPtr` off)
    if l == (-1)
596
      then
597 598 599
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

600
asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
601
asyncWriteRawBufferPtr loc !fd !buf !off !len = do
602 603 604
    (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
                  (fromIntegral len) (buf `plusPtr` off)
    if l == (-1)
605
      then
606 607 608 609 610
        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
      else return (fromIntegral l)

-- Blocking versions of the read/write primitives, for the threaded RTS

611
blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
612
blockingReadRawBufferPtr loc !fd !buf !off !len
613
  = throwErrnoIfMinus1Retry loc $
614
        if fdIsSocket fd
615 616
           then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
           else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
617

618
blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
619
blockingWriteRawBufferPtr loc !fd !buf !off !len
620
  = throwErrnoIfMinus1Retry loc $
621
        if fdIsSocket fd
622
           then c_safe_send  (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
623
           else do
624
             r <- c_safe_write (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
625 626 627 628 629 630 631 632 633
             when (r == -1) c_maperrno
             return r
      -- we don't trust write() to give us the correct errno, and
      -- instead do the errno conversion from GetLastError()
      -- ourselves.  The main reason is that we treat ERROR_NO_DATA
      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
      -- for this case.  We need to detect EPIPE correctly, because it
      -- shouldn't be reported as an error when it happens on stdout.

634 635 636
-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.

637
foreign import WINDOWS_CCONV safe "recv"
638
   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt
639

640
foreign import WINDOWS_CCONV safe "send"
641
   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt
642 643 644

#endif

645
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
646 647 648 649 650

-- -----------------------------------------------------------------------------
-- utils

#ifndef mingw32_HOST_OS
651
throwErrnoIfMinus1RetryOnBlock  :: String -> IO CSsize -> IO CSsize -> IO CSsize
652
throwErrnoIfMinus1RetryOnBlock loc f on_block  =
653 654
  do
    res <- f
655
    if (res :: CSsize) == -1
656 657 658 659 660 661 662 663 664 665 666 667 668 669
      then do
        err <- getErrno
        if err == eINTR
          then throwErrnoIfMinus1RetryOnBlock loc f on_block
          else if err == eWOULDBLOCK || err == eAGAIN
                 then do on_block
                 else throwErrno loc
      else return res
#endif

-- -----------------------------------------------------------------------------
-- Locking/unlocking

foreign import ccall unsafe "lockFile"
670
  lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt
671 672 673

foreign import ccall unsafe "unlockFile"
  unlockFile :: CInt -> IO CInt
dterei's avatar
dterei committed
674

pcapriotti's avatar
pcapriotti committed
675
#ifdef mingw32_HOST_OS
676 677
foreign import ccall unsafe "get_unique_file_info"
  c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()
pcapriotti's avatar
pcapriotti committed
678
#endif