diff --git a/Data/Traversable.hs b/Data/Traversable.hs --- a/Data/Traversable.hs +++ b/Data/Traversable.hs @@ -144,10 +144,9 @@ class (Functor t, Foldable t) => Traversable t where {-# MINIMAL traverse | sequenceA #-} - -- | Map each element of a structure to an action, evaluate these - -- these actions from left to right, and collect the results. - -- actions from left to right, and collect the results. For a - -- version that ignores the results see 'Data.Foldable.traverse_'. + -- | Map each element of a structure to an action, evaluate these actions + -- from left to right, and collect the results. For a version that ignores + -- the results see 'Data.Foldable.traverse_'. traverse :: Applicative f => (a -> f b) -> t a -> f (t b) traverse f = sequenceA . fmap f diff --git a/GHC/Event.hs b/GHC/Event.hs --- a/GHC/Event.hs +++ b/GHC/Event.hs @@ -25,6 +25,7 @@ , evtWrite , IOCallback , FdKey(keyFd) + , Lifetime(..) , registerFd , unregisterFd , unregisterFd_ diff --git a/GHC/Event/Internal.hs b/GHC/Event/Internal.hs --- a/GHC/Event/Internal.hs +++ b/GHC/Event/Internal.hs @@ -83,8 +83,12 @@ evtConcat = foldl' evtCombine evtNothing {-# INLINE evtConcat #-} --- | The lifetime of a registration. -data Lifetime = OneShot | MultiShot +-- | The lifetime of an event registration. +-- +-- @since 4.8.1.0 +data Lifetime = OneShot -- ^ the registration will be active for only one + -- event + | MultiShot -- ^ the registration will trigger multiple times deriving (Show, Eq) -- | The longer of two lifetimes. @@ -93,6 +97,7 @@ elSupremum _ _ = MultiShot {-# INLINE elSupremum #-} +-- | @mappend@ == @elSupremum@ instance Monoid Lifetime where mempty = OneShot mappend = elSupremum diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs --- a/GHC/Event/Manager.hs +++ b/GHC/Event/Manager.hs @@ -456,20 +456,35 @@ | otherwise = do fdds <- withMVar (callbackTableVar mgr fd) $ \tbl -> - IT.delete (fromIntegral fd) tbl >>= maybe (return []) selectCallbacks + IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl) forM_ fdds $ \(FdData reg _ cb) -> cb reg evs where -- | Here we look through the list of registrations for the fd of interest - -- and sort out which match the events that were triggered. We re-arm - -- the fd as appropriate and return this subset. - selectCallbacks :: [FdData] -> IO [FdData] - selectCallbacks fdds = do - let matches :: FdData -> Bool + -- and sort out which match the events that were triggered. We, + -- + -- 1. re-arm the fd as appropriate + -- 2. reinsert registrations that weren't triggered and multishot + -- registrations + -- 3. return a list containing the callbacks that should be invoked. + selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData] + selectCallbacks tbl fdds = do + let -- figure out which registrations have been triggered + matches :: FdData -> Bool matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd') - (triggered, saved) = partition matches fdds + (triggered, notTriggered) = partition matches fdds + + -- sort out which registrations we need to retain + isMultishot :: FdData -> Bool + isMultishot fd' = I.elLifetime (fdEvents fd') == MultiShot + saved = notTriggered ++ filter isMultishot triggered + savedEls = eventsOf saved allEls = eventsOf fdds + -- Reinsert multishot registrations. + -- We deleted the table entry for this fd above so we there isn't a preexisting entry + _ <- IT.insertWith (\_ _ -> saved) (fromIntegral fd) saved tbl + case I.elLifetime allEls of -- we previously armed the fd for multiple shots, no need to rearm MultiShot | allEls == savedEls -> @@ -477,17 +492,18 @@ -- either we previously registered for one shot or the -- events of interest have changed, we must re-arm - _ -> do + _ -> case I.elLifetime savedEls of OneShot | haveOneShot -> - -- if there are no saved events there is no need to re-arm - unless (OneShot == I.elLifetime (eventsOf triggered) - && mempty == savedEls) $ + -- if there are no saved events and we registered with one-shot + -- semantics then there is no need to re-arm + unless (OneShot == I.elLifetime allEls + && mempty == I.elEvent savedEls) $ do void $ I.modifyFdOnce (emBackend mgr) fd (I.elEvent savedEls) _ -> + -- we need to re-arm with multi-shot semantics void $ I.modifyFd (emBackend mgr) fd (I.elEvent allEls) (I.elEvent savedEls) - return () return triggered diff --git a/GHC/IO/Encoding.hs b/GHC/IO/Encoding.hs --- a/GHC/IO/Encoding.hs +++ b/GHC/IO/Encoding.hs @@ -235,7 +235,9 @@ _ -> Nothing mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding -mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of +mkTextEncoding' cfm enc = + case [toUpper c | c <- enc, c /= '-'] of + -- UTF-8 and friends we can handle ourselves "UTF8" -> return $ UTF8.mkUTF8 cfm "UTF16" -> return $ UTF16.mkUTF16 cfm "UTF16LE" -> return $ UTF16.mkUTF16le cfm @@ -247,8 +249,31 @@ 'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp _ -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm) #else - _ -> Iconv.mkIconvEncoding cfm enc + -- Otherwise, handle other encoding needs via iconv. + + -- Unfortunately there is no good way to determine whether iconv is actually + -- functional without telling it to do something. + _ -> do res <- Iconv.mkIconvEncoding cfm enc + let isAscii = any (== enc) ansiEncNames + case res of + Just e -> return e + -- At this point we know that we can't count on iconv to work + -- (see, for instance, Trac #10298). However, we still want to do + -- what we can to work with what we have. For instance, ASCII is + -- easy. We match on ASCII encodings directly using several + -- possible aliases (specified by RFC 1345 & Co) and for this use + -- the 'ascii' encoding + Nothing + | isAscii -> return (Latin1.mkAscii cfm) + | otherwise -> + unknownEncodingErr (enc ++ codingFailureModeSuffix cfm) + where + ansiEncNames = -- ASCII aliases + [ "ANSI_X3.4-1968", "iso-ir-6", "ANSI_X3.4-1986", "ISO_646.irv:1991" + , "US-ASCII", "us", "IBM367", "cp367", "csASCII", "ASCII", "ISO646-US" + ] #endif + latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8) latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_encode input output -- unchecked, used for char8 diff --git a/GHC/IO/Encoding/Iconv.hs b/GHC/IO/Encoding/Iconv.hs --- a/GHC/IO/Encoding/Iconv.hs +++ b/GHC/IO/Encoding/Iconv.hs @@ -34,9 +34,10 @@ #else import Foreign -import Foreign.C +import Foreign.C hiding (charIsRepresentable) import Data.Maybe import GHC.Base +import GHC.Foreign (charIsRepresentable) import GHC.IO.Buffer import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types @@ -96,15 +97,27 @@ char_shift | charSize == 2 = 1 | otherwise = 2 -iconvEncoding :: String -> IO TextEncoding +iconvEncoding :: String -> IO (Maybe TextEncoding) iconvEncoding = mkIconvEncoding ErrorOnCodingFailure -mkIconvEncoding :: CodingFailureMode -> String -> IO TextEncoding +-- | Construct an iconv-based 'TextEncoding' for the given character set and +-- 'CodingFailureMode'. +-- +-- As iconv is missing in some minimal environments (e.g. #10298), this +-- checks to ensure that iconv is working properly before returning the +-- encoding, returning 'Nothing' if not. +mkIconvEncoding :: CodingFailureMode -> String -> IO (Maybe TextEncoding) mkIconvEncoding cfm charset = do - return (TextEncoding { - textEncodingName = charset, - mkTextDecoder = newIConv raw_charset (haskellChar ++ suffix) (recoverDecode cfm) iconvDecode, - mkTextEncoder = newIConv haskellChar charset (recoverEncode cfm) iconvEncode}) + let enc = TextEncoding { + textEncodingName = charset, + mkTextDecoder = newIConv raw_charset (haskellChar ++ suffix) + (recoverDecode cfm) iconvDecode, + mkTextEncoder = newIConv haskellChar charset + (recoverEncode cfm) iconvEncode} + good <- charIsRepresentable enc 'a' + return $ if good + then Just enc + else Nothing where -- An annoying feature of GNU iconv is that the //PREFIXES only take -- effect when they appear on the tocode parameter to iconv_open: diff --git a/GHC/IO/Encoding/Latin1.hs b/GHC/IO/Encoding/Latin1.hs --- a/GHC/IO/Encoding/Latin1.hs +++ b/GHC/IO/Encoding/Latin1.hs @@ -15,7 +15,7 @@ -- Stability : internal -- Portability : non-portable -- --- UTF-32 Codecs for the IO library +-- Single-byte encodings that map directly to Unicode code points. -- -- Portions Copyright : (c) Tom Harper 2008-2009, -- (c) Bryan O'Sullivan 2009, @@ -26,9 +26,12 @@ module GHC.IO.Encoding.Latin1 ( latin1, mkLatin1, latin1_checked, mkLatin1_checked, + ascii, mkAscii, latin1_decode, + ascii_decode, latin1_encode, latin1_checked_encode, + ascii_encode, ) where import GHC.Base @@ -90,7 +93,47 @@ setState = const $ return () }) +-- ----------------------------------------------------------------------------- +-- ASCII +-- | @since 4.8.2.0 +ascii :: TextEncoding +ascii = mkAscii ErrorOnCodingFailure + +-- | @since 4.8.2.0 +mkAscii :: CodingFailureMode -> TextEncoding +mkAscii cfm = TextEncoding { textEncodingName = "ASCII", + mkTextDecoder = ascii_DF cfm, + mkTextEncoder = ascii_EF cfm } + +ascii_DF :: CodingFailureMode -> IO (TextDecoder ()) +ascii_DF cfm = + return (BufferCodec { + encode = ascii_decode, + recover = recoverDecode cfm, + close = return (), + getState = return (), + setState = const $ return () + }) + +ascii_EF :: CodingFailureMode -> IO (TextEncoder ()) +ascii_EF cfm = + return (BufferCodec { + encode = ascii_encode, + recover = recoverEncode cfm, + close = return (), + getState = return (), + setState = const $ return () + }) + + + +-- ----------------------------------------------------------------------------- +-- The actual decoders and encoders + +-- TODO: Eliminate code duplication between the checked and unchecked +-- versions of the decoder or encoder (but don't change the Core!) + latin1_decode :: DecodeBuffer latin1_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } @@ -112,6 +155,30 @@ in loop ir0 ow0 +ascii_decode :: DecodeBuffer +ascii_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + if c0 > 0x7f then invalid else do + ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) + loop (ir+1) ow' + where + invalid = done InvalidSequence ir ow + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + latin1_encode :: EncodeBuffer latin1_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } @@ -132,7 +199,15 @@ loop ir0 ow0 latin1_checked_encode :: EncodeBuffer -latin1_checked_encode +latin1_checked_encode input output + = single_byte_checked_encode 0xff input output + +ascii_encode :: EncodeBuffer +ascii_encode input output + = single_byte_checked_encode 0x7f input output + +single_byte_checked_encode :: Int -> EncodeBuffer +single_byte_checked_encode max_legal_char input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let @@ -145,11 +220,11 @@ | ir >= iw = done InputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir - if ord c > 0xff then invalid else do + if ord c > max_legal_char then invalid else do writeWord8Buf oraw ow (fromIntegral (ord c)) loop ir' (ow+1) where invalid = done InvalidSequence ir ow in loop ir0 ow0 - +{-# INLINE single_byte_checked_encode #-} diff --git a/GHC/IO/Exception.hs b/GHC/IO/Exception.hs --- a/GHC/IO/Exception.hs +++ b/GHC/IO/Exception.hs @@ -323,7 +323,7 @@ ResourceVanished -> "resource vanished" SystemError -> "system error" TimeExpired -> "timeout" - UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! + UnsatisfiedConstraints -> "unsatisfied constraints" -- ultra-precise! UnsupportedOperation -> "unsupported operation" -- | Construct an 'IOError' value with a string describing the error. diff --git a/GHC/List.hs b/GHC/List.hs --- a/GHC/List.hs +++ b/GHC/List.hs @@ -84,8 +84,15 @@ last (_:xs) = last xs last [] = errorEmptyList "last" #else --- use foldl to allow fusion -last = foldl (\_ x -> x) (errorEmptyList "last") +-- Use foldl to make last a good consumer. +-- This will compile to good code for the actual GHC.List.last. +-- (At least as long it is eta-expaned, otherwise it does not, #10260.) +last xs = foldl (\_ x -> x) lastError xs +{-# INLINE last #-} +-- The inline pragma is required to make GHC remember the implementation via +-- foldl. +lastError :: a +lastError = errorEmptyList "last" #endif -- | Return all the elements of a list except the last one. diff --git a/GHC/SrcLoc.hs b/GHC/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/GHC/SrcLoc.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RecordWildCards #-} +module GHC.SrcLoc + ( SrcLoc + , srcLocPackage + , srcLocModule + , srcLocFile + , srcLocStartLine + , srcLocStartCol + , srcLocEndLine + , srcLocEndCol + + -- * Pretty printing + , showSrcLoc + ) where + +-- | A single location in the source code. +data SrcLoc = SrcLoc + { srcLocPackage :: String + , srcLocModule :: String + , srcLocFile :: String + , srcLocStartLine :: Int + , srcLocStartCol :: Int + , srcLocEndLine :: Int + , srcLocEndCol :: Int + } deriving (Show, Eq) + +showSrcLoc :: SrcLoc -> String +showSrcLoc SrcLoc {..} + = concat [ srcLocFile, ":" + , show srcLocStartLine, ":" + , show srcLocStartCol, " in " + , srcLocPackage, ":", srcLocModule + ] diff --git a/GHC/Stack.hsc b/GHC/Stack.hsc --- a/GHC/Stack.hsc +++ b/GHC/Stack.hsc @@ -17,11 +17,17 @@ {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-} module GHC.Stack ( - -- * Call stack + -- * Call stacks + -- ** Simulated by the RTS currentCallStack, whoCreated, errorWithStackTrace, + -- ** Explicitly created via implicit-parameters + CallStack, + getCallStack, + showCallStack, + -- * Internals CostCentreStack, CostCentre, @@ -36,6 +42,8 @@ renderStack ) where +import Data.List ( unlines ) + import Foreign import Foreign.C @@ -46,6 +54,8 @@ import GHC.IO.Encoding import GHC.Exception import GHC.List ( concatMap, null, reverse ) +import GHC.Show +import GHC.SrcLoc #define PROFILING #include "Rts.h" @@ -128,3 +138,48 @@ if null stack then throwIO (ErrorCall x) else throwIO (ErrorCall (x ++ '\n' : renderStack stack)) + + +---------------------------------------------------------------------- +-- Explicit call-stacks built via ImplicitParams +---------------------------------------------------------------------- + +-- | @CallStack@s are an alternate method of obtaining the call stack at a given +-- point in the program. +-- +-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will +-- solve it with the current location. If another @CallStack@ implicit-parameter +-- is in-scope (e.g. as a function argument), the new location will be appended +-- to the one in-scope, creating an explicit call-stack. For example, +-- +-- @ +-- myerror :: (?loc :: CallStack) => String -> a +-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) +-- @ +-- ghci> myerror "die" +-- *** Exception: die +-- ?loc, called at MyError.hs:7:51 in main:MyError +-- myerror, called at :2:1 in interactive:Ghci1 +-- +-- @CallStack@s do not interact with the RTS and do not require compilation with +-- @-prof@. On the other hand, as they are built up explicitly using +-- implicit-parameters, they will generally not contain as much information as +-- the simulated call-stacks maintained by the RTS. +-- +-- The @CallStack@ type is abstract, but it can be converted into a +-- @[(String, SrcLoc)]@ via 'getCallStack'. The @String@ is the name of function +-- that was called, the 'SrcLoc' is the call-site. The list is ordered with the +-- most recently called function at the head. +-- +-- @since 4.9.0.0 +data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] } + -- See Note [Overview of implicit CallStacks] + deriving (Show, Eq) + +showCallStack :: CallStack -> String +showCallStack (CallStack (root:rest)) + = unlines (showCallSite root : map (indent . showCallSite) rest) + where + indent l = " " ++ l + showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc +showCallStack _ = error "CallStack cannot be empty!" diff --git a/GHC/TopHandler.hs b/GHC/TopHandler.hs --- a/GHC/TopHandler.hs +++ b/GHC/TopHandler.hs @@ -157,13 +157,45 @@ Just (ExitFailure n) -> exit n -- EPIPE errors received for stdout are ignored (#2699) - _ -> case fromException se of + _ -> catch (case fromException se of Just IOError{ ioe_type = ResourceVanished, ioe_errno = Just ioe, ioe_handle = Just hdl } | Errno ioe == ePIPE, hdl == stdout -> exit 0 _ -> do reportError se exit 1 + ) (disasterHandler exit) -- See Note [Disaster with iconv] + +-- don't use errorBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h errorBelch2" + errorBelch :: CString -> CString -> IO () + +disasterHandler :: (Int -> IO a) -> IOError -> IO a +disasterHandler exit _ = + withCAString "%s" $ \fmt -> + withCAString msgStr $ \msg -> + errorBelch fmt msg >> exit 1 + where + msgStr = + "encountered an exception while trying to report an exception." ++ + "One possible reason for this is that we failed while trying to " ++ + "encode an error message. Check that your locale is configured " ++ + "properly." + +{- Note [Disaster with iconv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When using iconv, it's possible for things like iconv_open to fail in +restricted environments (like an initram or restricted container), but +when this happens the error raised inevitably calls `peekCString`, +which depends on the users locale, which depends on using +`iconv_open`... which causes an infinite loop. + +This occurrence is also known as tickets #10298 and #7695. So to work +around it we just set _another_ error handler and bail directly by +calling the RTS, without iconv at all. +-} -- try to flush stdout/stderr, but don't worry if we fail diff --git a/System/IO.hs b/System/IO.hs --- a/System/IO.hs +++ b/System/IO.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-} ----------------------------------------------------------------------------- -- | @@ -453,13 +453,13 @@ openTempFileWithDefaultPermissions :: FilePath -> String -> IO (FilePath, Handle) openTempFileWithDefaultPermissions tmp_dir template - = openTempFile' "openBinaryTempFile" tmp_dir template False 0o666 + = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666 -- | Like 'openBinaryTempFile', but uses the default file permissions openBinaryTempFileWithDefaultPermissions :: FilePath -> String -> IO (FilePath, Handle) openBinaryTempFileWithDefaultPermissions tmp_dir template - = openTempFile' "openBinaryTempFile" tmp_dir template True 0o666 + = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666 openTempFile' :: String -> FilePath -> String -> Bool -> CMode -> IO (FilePath, Handle) @@ -509,7 +509,7 @@ | otherwise = a ++ [pathSeparator] ++ b -- int rand(void) from , limited by RAND_MAX (small value, 32768) -foreign import ccall "rand" c_rand :: IO CInt +foreign import capi "stdlib.h rand" c_rand :: IO CInt -- build large digit-alike number rand_string :: IO String diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,5 +1,5 @@ name: base -version: 4.8.0.0 +version: 4.8.1.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -259,6 +259,7 @@ GHC.StaticPtr GHC.STRef GHC.Show + GHC.SrcLoc GHC.Stable GHC.Stack GHC.Stats diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,14 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.8.1.0 *Jul 2015* + + * Bundled with GHC 7.10.2 + + * `Lifetime` is now exported from `GHC.Event` + + * Implicit-parameter based source location support exposed in `GHC.SrcLoc`. + See GHC User's Manual for more information. + ## 4.8.0.0 *Mar 2015* * Bundled with GHC 7.10.1