Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • changelog.d/clc-447
    1 
    +section: base
    2 
    +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``,
    3 
    +  ``hGetContents``, ``hGetContents'``, ``hClose``, ``executablePath``, and on
    4 
    +  Windows in ``openFile``, ``openFileBlocking`` and ``openBinaryFile``.
    5 
    +issues: #27875
    6 
    +mrs: !16747
    7 
    +description:
    8 
    +  See `CLC proposal 447 <https://github.com/haskell/core-libraries-committee/issues/447>`_.

  • libraries/base/changelog.md
    ... ... @@ -14,6 +14,7 @@
    14 14 
       * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394))
    15 15 
       * Add strict variants to mutable types (IORef, Chan, MVar). ([CLC Proposal #341](https://github.com/haskell/core-libraries-committee/issues/341))
    16 16 
       * Preserve exception context when rethrowing exceptions in `modifyIOError` and `mapException`. ([CLC proposal #446](https://github.com/haskell/core-libraries-committee/issues/446))
    17 
    +  * Preserve exception context when rethrowing exceptions in `hGetLine`, `hGetContents`, `hGetContents'`, `hClose`, `executablePath`, and on Windows in `openFile`, `openFileBlocking` and `openBinaryFile`. ([CLC proposal #447](https://github.com/haskell/core-libraries-committee/issues/447))
    17 18
    18 19 
     ## 4.23.0.0 *TBA*
    19 20 
       * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370))

  • libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs
    ... ... @@ -193,7 +193,7 @@ do_operation fun h act m = do
    193 193 
                 throwTo t e
    194 194 
                 do_operation fun h act m
    195 195 
             _otherwise ->
    196 
    -            throwIO e
    196 
    +            rethrowIO (ExceptionWithContext c e)
    197 197
    198 198 
     -- Note [async]
    199 199 
     -- ~~~~~~~~~~~~
    ... ... @@ -451,7 +451,7 @@ handleFinalizer fp m = do
    451 451 
       (handle_', mb_exc) <- hClose_help handle_
    452 452 
       putMVar m handle_'
    453 453 
       case mb_exc of
    454 
    -    Just exc -> throwIO exc
    454 
    +    Just exc -> throwIO (NoBacktrace exc)
    455 455 
         Nothing -> return ()
    456 456
    457 457 
     {-
    ... ... @@ -885,8 +885,9 @@ hClose_maybethrow (Just e) h = hClose_rethrow e h
    885 885 
     hClose_rethrow :: SomeException -> Handle -> IO ()
    886 886 
     hClose_rethrow e h =
    887 887 
       case fromException e of
    888 
    -    Just ioe -> ioError (augmentIOError ioe "hClose" h)
    889 
    -    Nothing  -> throwIO e
    888 
    +    Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $
    889 
    +                  augmentIOError ioe "hClose" h
    890 
    +    Nothing  -> throwIO (NoBacktrace e)
    890 891
    891 892 
     hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
    892 893 
     hClose' h m = withHandle' "hClose" h m $ hClose_help

  • libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs
    ... ... @@ -28,6 +28,7 @@ import GHC.Internal.Base (String, fmap, otherwise, return, ($))
    28 28 
     import qualified GHC.Internal.Base as Rebindable
    29 29 
     import qualified GHC.Internal.Data.Typeable.Internal as Rebindable
    30 30 
     import GHC.Internal.MVar
    31 
    +import GHC.Internal.Exception.Type (ExceptionWithContext(..))
    31 32 
     import GHC.Internal.IO
    32 33 
     import GHC.Internal.IO.BufferedIO hiding (flushWriteBuffer)
    33 34 
     import GHC.Internal.IO.Encoding
    ... ... @@ -114,6 +115,11 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException
    114 115 
     addFilePathToIOError fun fp ioe
    115 116 
       = ioe{ ioe_location = fun, ioe_filename = Just fp }
    116 117
    118 
    +catchAndAnnotate :: FilePath -> String -> IO a -> IO a
    119 
    +catchAndAnnotate fp s a =
    120 
    +  catchExceptionNoPropagate a $ \(ExceptionWithContext c e) ->
    121 
    +    rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e))
    122 
    +
    117 123 
     -- | Computation 'openFile' @file mode@ allocates and returns a new, open
    118 124 
     -- handle to manage the file @file@.  It manages input if @mode@
    119 125 
     -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
    ... ... @@ -142,9 +148,8 @@ addFilePathToIOError fun fp ioe
    142 148 
     -- be using 'openBinaryFile'.
    143 149 
     openFile :: FilePath -> IOMode -> IO Handle
    144 150 
     openFile fp im =
    145 
    -  catchException
    146 
    -    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)
    147 
    -    (\e -> ioError (addFilePathToIOError "openFile" fp e))
    151 
    +  catchAndAnnotate fp "openFile" $
    152 
    +    openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True
    148 153
    149 154 
     -- | Like 'openFile', but opens the file in ordinary blocking mode.
    150 155 
     -- This can be useful for opening a FIFO for writing: if we open in
    ... ... @@ -154,9 +159,8 @@ openFile fp im =
    154 159 
     -- @since base-4.4.0.0
    155 160 
     openFileBlocking :: FilePath -> IOMode -> IO Handle
    156 161 
     openFileBlocking fp im =
    157 
    -  catchException
    158 
    -    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)
    159 
    -    (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e))
    162 
    +  catchAndAnnotate fp "openFileBlocking" $
    163 
    +    openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False
    160 164
    161 165 
     -- | Like 'openFile', but open the file in binary mode.
    162 166 
     -- On Windows, reading a file in text mode (which is the default)
    ... ... @@ -169,9 +173,8 @@ openFileBlocking fp im =
    169 173
    170 174 
     openBinaryFile :: FilePath -> IOMode -> IO Handle
    171 175 
     openBinaryFile fp m =
    172 
    -  catchException
    173 
    -    (openFile' fp m True True)
    174 
    -    (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
    176 
    +  catchAndAnnotate fp "openBinaryFile" $
    177 
    +    openFile' fp m True True
    175 178
    176 179 
     openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle
    177 180 
     openFile' filepath iomode binary non_blocking = do

  • libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc
    ... ... @@ -44,7 +44,7 @@ executablePath = Nothing
    44 44 
     import GHC.Internal.Maybe (Maybe(..))
    45 45 
     import GHC.Internal.IO (FilePath)
    46 46 
     #if defined(darwin_HOST_OS)
    47 
    -import GHC.Internal.Control.Exception (catch, throw)
    47 
    +import GHC.Internal.Control.Exception (catchJust)
    48 48 
     import GHC.Internal.Err (errorWithoutStackTrace)
    49 49 
     import GHC.Internal.Real
    50 50 
     import GHC.Internal.Word
    ... ... @@ -66,7 +66,7 @@ import GHC.Internal.Foreign.Marshal.Array
    66 66 
     import GHC.Internal.Real
    67 67 
     import GHC.Internal.System.Posix.Internals
    68 68 
     #elif defined(solaris2_HOST_OS)
    69 
    -import GHC.Internal.Control.Exception (catch, throw)
    69 
    +import GHC.Internal.Control.Exception (catchJust)
    70 70 
     import GHC.Internal.Data.Functor
    71 71 
     import GHC.Internal.Foreign.C.Types
    72 72 
     import GHC.Internal.Foreign.C.Error
    ... ... @@ -75,7 +75,7 @@ import GHC.Internal.Foreign.Marshal.Array
    75 75 
     import GHC.Internal.System.IO.Error (isDoesNotExistError)
    76 76 
     import GHC.Internal.System.Posix.Internals
    77 77 
     #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS)
    78 
    -import GHC.Internal.Control.Exception (catch, throw)
    78 
    +import GHC.Internal.Control.Exception (catchJust)
    79 79 
     import GHC.Internal.Data.Functor
    80 80 
     import GHC.Internal.Foreign.C.Types
    81 81 
     import GHC.Internal.Foreign.C.Error
    ... ... @@ -203,10 +203,10 @@ realpath path =
    203 203 
     getExecutablePath = _NSGetExecutablePath >>= realpath
    204 204
    205 205 
     -- realpath(3) fails with ENOENT file does not exist (e.g. was deleted)
    206 
    -executablePath = Just (fmap Just getExecutablePath `catch` f)
    206 
    +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing))
    207 207 
       where
    208 
    -  f e | isDoesNotExistError e = pure Nothing
    209 
    -      | otherwise             = throw e
    208 
    +  f e | isDoesNotExistError e = Just ()
    209 
    +      | otherwise             = Nothing
    210 210
    211 211 
     --------------------------------------------------------------------------------
    212 212 
     -- Linux / Solaris / Hurd
    ... ... @@ -242,12 +242,12 @@ executablePath = Just (check <$> getExecutablePath) where
    242 242 
     #  elif defined(solaris2_HOST_OS)
    243 243 
     getExecutablePath = readSymbolicLink "/proc/self/path/a.out"
    244 244
    245 
    -executablePath = Just ((Just <$> getExecutablePath) `catch` f)
    245 
    +executablePath = Just (catchJust f (Just <$> getExecutablePath) (\_ -> pure Nothing))
    246 246 
       where
    247 247 
         -- readlink(2) fails with ENOENT when the executable has been deleted,
    248 248 
         -- even though the symlink itself still exists according to readdir(3).
    249 
    -    f e | isDoesNotExistError e = pure Nothing
    250 
    -        | otherwise             = throw e
    249 
    +    f e | isDoesNotExistError e = Just ()
    250 
    +        | otherwise             = Nothing
    251 251
    252 252 
     #endif
    253 253
    ... ... @@ -297,15 +297,15 @@ getExecutablePath = do
    297 297 
           ]
    298 298 
     #  endif
    299 299
    300 
    -executablePath = Just (fmap Just getExecutablePath `catch` f)
    300 
    +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing))
    301 301 
       where
    302 302 
       -- The sysctl fails with errno ENOENT when executable has been deleted;
    303 303 
       -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346.
    304 
    -  f e | isDoesNotExistError e = pure Nothing
    304 
    +  f e | isDoesNotExistError e = Just ()
    305 305
    306 306 
       -- As far as I know, ENOENT is the only kind of failure that should be
    307 307 
       -- expected and handled.  Re-throw other errors.
    308 
    -      | otherwise             = throw e
    308 
    +      | otherwise             = Nothing
    309 309
    310 310
    311 311 
     --------------------------------------------------------------------------------

  • testsuite/tests/exceptions/T27851d.hs
    1 
    +import Control.Exception
    2 
    +import System.IO
    3 
    +
    4 
    +main :: IO ()
    5 
    +main = do
    6 
    +  h <- openFile "/dev/full" WriteMode
    7 
    +  hPutStr h "x"
    8 
    +  r <- try (hClose h)
    9 
    +  case r of
    10 
    +    Left e -> putStrLn (displayExceptionWithInfo e)
    11 
    +    Right () -> putStrLn "no exception"

  • testsuite/tests/exceptions/T27851d.stdout
    1 
    +ghc-internal:GHC.Internal.IO.Exception.IOException:
    2 
    +
    3 
    +/dev/full: hClose: resource exhausted (No space left on device)
    4 
    +
    5 
    +HasCallStack backtrace:
    6 
    +  ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error
    7 
    +

  • testsuite/tests/exceptions/T27851d.stdout-javascript-unknown-ghcjs
    1 
    +ghc-internal:GHC.Internal.IO.Exception.IOException:
    2 
    +
    3 
    +/dev/full: hClose: resource exhausted (unknown error)
    4 
    +
    5 
    +HasCallStack backtrace:
    6 
    +  ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error
    7 
    +

  • testsuite/tests/exceptions/all.T
    ... ... @@ -4,3 +4,4 @@ test('T26759a', exit_code(1), compile_and_run, [''])
    4 4 
     test('T27851', exit_code(1), compile_and_run, [''])
    5 5 
     test('T27851b', exit_code(1), compile_and_run, [''])
    6 6 
     test('T27851c', normal, compile_and_run, [''])
    7 
    +test('T27851d', unless(opsys('linux'), skip), compile_and_run, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/91b2524a70c9ac10eaf3092e82231d63633e6cf6...caba1270760ad4f432138b2e6abd58df92d28b66 at 1793166488