diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 5d3af3ff34e0371a51e2effa9c8716b730d72e40..2f77e41d730210822e00b6fed865cd160036c0be 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -28,6 +28,7 @@ and [CLC proposal #258](https://github.com/haskell/core-libraries-committee/issues/258)) * Add `System.Mem.performMajorGC` ([CLC proposal #230](https://github.com/haskell/core-libraries-committee/issues/230)) * Fix exponent overflow/underflow bugs in the `Read` instances for `Float` and `Double` ([CLC proposal #192](https://github.com/haskell/core-libraries-committee/issues/192)) + * `Foreign.C.Error.errnoToIOError` now uses the reentrant `strerror_r` to render system errors when possible ([CLC proposal #249](https://github.com/haskell/core-libraries-committee/issues/249)) * Implement `many` and `some` methods of `instance Alternative (Compose f g)` explicitly. ([CLC proposal #181](https://github.com/haskell/core-libraries-committee/issues/181)) * Change the types of the `GHC.Stack.StackEntry.closureType` and `GHC.InfoProv.InfoProv.ipDesc` record fields to use `GHC.Exts.Heap.ClosureType` rather than an `Int`. To recover the old value use `fromEnum`. ([CLC proposal #210](https://github.com/haskell/core-libraries-committee/issues/210)) diff --git a/libraries/ghc-internal/cbits/strerror.c b/libraries/ghc-internal/cbits/strerror.c new file mode 100644 index 0000000000000000000000000000000000000000..1640a4957e795d7431d8f8f2e13f157ad04c1066 --- /dev/null +++ b/libraries/ghc-internal/cbits/strerror.c @@ -0,0 +1,29 @@ +// glibc will only expose the POSIX strerror_r if this is defined. +#define _POSIX_C_SOURCE 200112L + +#include <string.h> +#include <errno.h> + +// This must be included after <string.h> lest _GNU_SOURCE may be defined. +#include "HsBaseConfig.h" + +// returns zero on success +int base_strerror_r(int errnum, char *ptr, size_t buflen) +{ +#if defined(HAVE_STRERROR_R) + int ret = strerror_r(errnum, ptr, buflen); + if (ret == ERANGE) { + // Ellipsize the error + ptr[buflen-4] = '.'; + ptr[buflen-3] = '.'; + ptr[buflen-2] = '.'; + ret = 0; + } + return ret; +#elif defined(HAVE_STRERROR_S) + strerror_s(ptr, buflen, errnum); + return 0; +#else +#error neither strerror_r nor strerror_s are supported +#endif +} diff --git a/libraries/ghc-internal/configure.ac b/libraries/ghc-internal/configure.ac index f5befee878eda43f9041cc988ddcf603005a5fd1..4eda0cd9d7b0692939dac4fbe6ca17636d9731a8 100644 --- a/libraries/ghc-internal/configure.ac +++ b/libraries/ghc-internal/configure.ac @@ -41,6 +41,12 @@ AC_CHECK_DECLS([CLOCK_PROCESS_CPUTIME_ID], [], [], [[#include <time.h>]]) AC_CHECK_FUNCS([getclock getrusage times]) AC_CHECK_FUNCS([_chsize_s ftruncate]) +AC_CHECK_FUNCS([strerror_r strerror_s]) + +if test "$ac_cv_func_strerror_r" = no && test "$ac_cv_func_strerror_s" = no; then + AC_MSG_ERROR([Either strerror_r or strerror_s must be available]) +fi + # event-related fun # The line below already defines HAVE_KQUEUE and HAVE_POLL, so technically some of the # subsequent portions that redefine them could be skipped. However, we keep those portions diff --git a/libraries/ghc-internal/ghc-internal.cabal b/libraries/ghc-internal/ghc-internal.cabal index 66933abdb6a57c6109c1d4197b295403d065866f..8113659953c22ef2027759e12b5d055f1c90834c 100644 --- a/libraries/ghc-internal/ghc-internal.cabal +++ b/libraries/ghc-internal/ghc-internal.cabal @@ -330,6 +330,7 @@ Library cbits/primFloat.c cbits/sysconf.c cbits/fs.c + cbits/strerror.c cmm-sources: cbits/StackCloningDecoding.cmm diff --git a/libraries/ghc-internal/jsbits/errno.js b/libraries/ghc-internal/jsbits/errno.js index b7ea1fb9ae01610d8f862908e28d6feaae3e2b2a..ff31029baaa5f15e84c28776eba6685fa6d9279f 100644 --- a/libraries/ghc-internal/jsbits/errno.js +++ b/libraries/ghc-internal/jsbits/errno.js @@ -22,7 +22,7 @@ function h$unsupported(status, c) { return status; } -function h$strerror(err) { +function h$base_strerror(err) { if(err === 12456) { RETURN_UBX_TUP2(h$encodeUtf8("operation unsupported on this platform"), 0); } diff --git a/libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs b/libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs index 169841758b9c3d7c1b61cc9e30e4fe81dbc88b7e..103531d824674f4f285a9c579e310c9af1d8807f 100644 --- a/libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs +++ b/libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs @@ -91,6 +91,9 @@ module GHC.Internal.Foreign.C.Error ( #include "HsBaseConfig.h" import GHC.Internal.Foreign.Ptr +#if !defined(javascript_HOST_ARCH) +import GHC.Internal.Foreign.Marshal.Alloc +#endif import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.String import GHC.Internal.Data.Functor ( void ) @@ -460,6 +463,29 @@ throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1) -- conversion of an "errno" value into IO error -- -------------------------------------------- +errnoToString :: Errno -> IO String + +#if defined(javascript_HOST_ARCH) +foreign import ccall unsafe "base_strerror" + c_strerror :: Errno -> IO (Ptr CChar) + +errnoToString errno = c_strerror errno >>= peekCString + +#else +foreign import ccall "base_strerror_r" + c_strerror_r :: Errno -> Ptr CChar -> CSize -> IO CInt + +errnoToString errno = + allocaBytes len $ \ptr -> do + ret <- c_strerror_r errno ptr len + if ret /= 0 + then return "errnoToString failed" + else peekCString ptr + where + len :: Num a => a + len = 512 +#endif + -- | Construct an 'IOError' based on the given 'Errno' value. -- The optional information can be used to improve the accuracy of -- error messages. @@ -470,7 +496,7 @@ errnoToIOError :: String -- ^ the location where the error occurred -> Maybe String -- ^ optional filename associated with the error -> IOError errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do - str <- strerror errno >>= peekCString + str <- errnoToString errno return (IOError maybeHdl errType loc str (Just errno') maybeName) where Errno errno' = errno @@ -576,5 +602,3 @@ errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do | errno == eXDEV = UnsupportedOperation | otherwise = OtherError -foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar) -