diff options
Diffstat (limited to 'libraries/base/System')
-rw-r--r-- | libraries/base/System/IO.hs | 19 | ||||
-rw-r--r-- | libraries/base/System/Posix/Internals.hs | 68 |
2 files changed, 69 insertions, 18 deletions
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index c5dfe057ba..59390c7ab4 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -347,7 +347,9 @@ readFile name = openFile name ReadMode >>= hGetContents -- @since 4.15.0.0 readFile' :: FilePath -> IO String -readFile' name = openFile name ReadMode >>= hGetContents' +-- There's a bit of overkill here—both withFile and +-- hGetContents' will close the file in the end. +readFile' name = withFile name ReadMode hGetContents' -- | The computation 'writeFile' @file str@ function writes the string @str@, -- to the file @file@. @@ -413,21 +415,6 @@ hReady h = hWaitForInput h 0 hPrint :: Show a => Handle -> a -> IO () hPrint hdl = hPutStrLn hdl . show --- | @'withFile' name mode act@ opens a file using 'openFile' and passes --- the resulting handle to the computation @act@. The handle will be --- closed on exit from 'withFile', whether by normal termination or by --- raising an exception. If closing the handle raises an exception, then --- this exception will be raised by 'withFile' rather than any exception --- raised by @act@. -withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r -withFile name mode = bracket (openFile name mode) hClose - --- | @'withBinaryFile' name mode act@ opens a file using 'openBinaryFile' --- and passes the resulting handle to the computation @act@. The handle --- will be closed on exit from 'withBinaryFile', whether by normal --- termination or by raising an exception. -withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r -withBinaryFile name mode = bracket (openBinaryFile name mode) hClose -- --------------------------------------------------------------------------- -- fixIO diff --git a/libraries/base/System/Posix/Internals.hs b/libraries/base/System/Posix/Internals.hs index 4bdeabe1bd..2772a66c75 100644 --- a/libraries/base/System/Posix/Internals.hs +++ b/libraries/base/System/Posix/Internals.hs @@ -1,6 +1,9 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE InterruptibleFFI #-} {-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -356,9 +359,70 @@ type CFilePath = CWString foreign import ccall unsafe "HsBase.h __hscore_open" c_open :: CFilePath -> CInt -> CMode -> IO CInt --- e.g. use `interruptible` rather than `safe` due to #17912. +-- | The same as 'c_safe_open', but an /interruptible operation/ +-- as described in "Control.Exception"—it respects `uninterruptibleMask` +-- but not `mask`. +-- +-- We want to be able to interrupt an openFile call if +-- it's expensive (NFS, FUSE, etc.), and we especially +-- need to be able to interrupt a blocking open call. +-- See #17912. +c_interruptible_open :: CFilePath -> CInt -> CMode -> IO CInt +c_interruptible_open filepath oflags mode = + getMaskingState >>= \case + -- If we're in an uninterruptible mask, there's basically + -- no point in using an interruptible FFI call. The open system call + -- will be interrupted, but the exception won't be delivered + -- unless the caller manually futzes with the masking state. So + -- then the caller (assuming they're following the usual conventions) + -- will retry the call (in response to EINTR), and we've just + -- wasted everyone's time. + MaskedUninterruptible -> c_safe_open_ filepath oflags mode + _ -> do + open_res <- c_interruptible_open_ filepath oflags mode + -- c_interruptible_open_ is an interruptible foreign call. + -- If the call is interrupted by an exception handler + -- before the system call has returned (so the file is + -- not yet open), we want to deliver the exception. + -- In point of fact, we deliver any pending exception + -- here regardless of the *reason* the system call + -- fails. + when (open_res == -1) $ + if hostIsThreaded + then + -- Control.Exception.allowInterrupt, inlined to avoid + -- messing with any Haddock links. + interruptible (pure ()) + else + -- Try to make this work somewhat better on the non-threaded + -- RTS. See #8684. This inlines the definition of `yield`; module + -- dependencies look pretty hairy here and I don't want to make + -- things worse for one little wrapper. + interruptible (IO $ \s -> (# yield# s, () #)) + pure open_res + foreign import ccall interruptible "HsBase.h __hscore_open" - c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt + c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt + +-- | Consult the RTS to find whether it is threaded. +hostIsThreaded :: Bool +hostIsThreaded = rtsIsThreaded_ /= 0 + +foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int + +c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt +c_safe_open filepath oflags mode = + getMaskingState >>= \case + -- When exceptions are unmasked, we use an interruptible + -- open call. If the system call is successfully + -- interrupted, the situation will be the same as if + -- the exception had arrived before this function was + -- called. + Unmasked -> c_interruptible_open_ filepath oflags mode + _ -> c_safe_open_ filepath oflags mode + +foreign import ccall safe "HsBase.h __hscore_open" + c_safe_open_ :: CFilePath -> CInt -> CMode -> IO CInt foreign import ccall unsafe "HsBase.h __hscore_fstat" c_fstat :: CInt -> Ptr CStat -> IO CInt |