base 4.4.1.0 → 4.5.0.0

raw patch · 175 files changed

+1782/−1400 lines, 175 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Arrow.hs +90/−19
• Control/Concurrent.hs +3/−2
• Control/Exception/Base.hs +2/−2
• Control/Monad/Group.hs +0/−34
• Control/Monad/Instances.hs +2/−0
• Control/Monad/ST.hs +14/−14
• Control/Monad/ST/Imp.hs +1/−0
• Control/Monad/ST/Lazy.hs +16/−12
• Control/Monad/ST/Lazy/Imp.hs +1/−1
• Control/Monad/ST/Lazy/Unsafe.hs +2/−0
• Control/Monad/ST/Strict.hs +0/−8
• Control/Monad/ST/Unsafe.hs +2/−0
• Control/Monad/Zip.hs +2/−0
• Data/Bits.hs +46/−5
• Data/Bool.hs +1/−0
• Data/Char.hs +1/−2
• Data/Complex.hs +1/−2
• Data/Data.hs +2/−3
• Data/Dynamic.hs +1/−0
• Data/Eq.hs +1/−0
• Data/Fixed.hs +2/−1
• Data/Foldable.hs +3/−0
• Data/Function.hs +4/−0
• Data/Functor.hs +1/−0
• Data/HashTable.hs +1/−0
• Data/IORef.hs +1/−0
• Data/Int.hs +1/−0
• Data/Ix.hs +1/−2
• Data/List.hs +12/−0
• Data/Maybe.hs +1/−0
• Data/Monoid.hs +10/−0
• Data/Ord.hs +1/−0
• Data/Ratio.hs +1/−0
• Data/STRef.hs +1/−0
• Data/STRef/Lazy.hs +6/−3
• Data/STRef/Strict.hs +2/−0
• Data/String.hs +1/−0
• Data/Traversable.hs +3/−0
• Data/Tuple.hs +2/−5
• Data/Typeable.hs +3/−0
• Data/Typeable.hs-boot +1/−0
• Data/Typeable/Internal.hs +3/−0
• Data/Typeable/Internal.hs-boot +2/−0
• Data/Word.hs +1/−0
• Debug/Trace.hs +127/−18
• Foreign.hs +3/−9
• Foreign/C.hs +1/−0
• Foreign/C/Error.hs +11/−8
• Foreign/C/String.hs +11/−11
• Foreign/C/Types.hs +12/−23
• Foreign/ForeignPtr.hs +32/−10
• Foreign/ForeignPtr/Imp.hs +2/−0
• Foreign/ForeignPtr/Unsafe.hs +1/−1
• Foreign/Marshal.hs +1/−0
• Foreign/Marshal/Alloc.hs +2/−1
• Foreign/Marshal/Array.hs +1/−0
• Foreign/Marshal/Error.hs +1/−0
• Foreign/Marshal/Pool.hs +1/−0
• Foreign/Marshal/Unsafe.hs +1/−1
• Foreign/Marshal/Utils.hs +3/−2
• Foreign/Ptr.hs +1/−0
• Foreign/StablePtr.hs +1/−0
• Foreign/Storable.hs +1/−0
• GHC/Arr.lhs +1/−0
• GHC/Base.lhs +8/−6
• GHC/Classes.hs +0/−297
• GHC/Conc.lhs +3/−0
• GHC/Conc/IO.hs +1/−0
• GHC/Conc/Sync.lhs +28/−4
• GHC/Conc/Windows.hs +3/−1
• GHC/ConsoleHandler.hs +7/−5
• GHC/Constants.hs +1/−0
• GHC/Desugar.hs +1/−0
• GHC/Enum.lhs +112/−0
• GHC/Environment.hs +2/−1
• GHC/Event.hs +6/−0
• GHC/Event/Array.hs +3/−1
• GHC/Event/Clock.hsc +5/−3
• GHC/Event/Control.hs +3/−1
• GHC/Event/EPoll.hsc +8/−3
• GHC/Event/IntMap.hs +3/−0
• GHC/Event/Internal.hs +2/−1
• GHC/Event/KQueue.hsc +3/−4
• GHC/Event/Manager.hs +1/−0
• GHC/Event/PSQ.hs +2/−0
• GHC/Event/Poll.hsc +2/−1
• GHC/Event/Thread.hs +1/−0
• GHC/Event/Unique.hs +2/−0
• GHC/Exception.lhs +1/−0
• GHC/Exts.hs +11/−6
• GHC/Fingerprint.hs +3/−0
• GHC/Fingerprint.hs-boot +1/−0
• GHC/Fingerprint/Type.hs +2/−0
• GHC/Float.lhs +72/−37
• GHC/Float/ConversionUtils.hs +2/−0
• GHC/Float/RealFracMethods.hs +2/−0
• GHC/Foreign.hs +5/−5
• GHC/ForeignPtr.hs +1/−0
• GHC/Handle.hs +1/−1
• GHC/IO.hs +4/−1
• GHC/IO.hs-boot +2/−0
• GHC/IO/Buffer.hs +1/−0
• GHC/IO/BufferedIO.hs +1/−0
• GHC/IO/Device.hs +1/−0
• GHC/IO/Encoding.hs +61/−30
• GHC/IO/Encoding.hs-boot +4/−1
• GHC/IO/Encoding/CodePage.hs +2/−0
• GHC/IO/Encoding/Failure.hs +90/−60
• GHC/IO/Encoding/Iconv.hs +2/−7
• GHC/IO/Encoding/Latin1.hs +1/−0
• GHC/IO/Encoding/Types.hs +1/−0
• GHC/IO/Encoding/UTF16.hs +1/−0
• GHC/IO/Encoding/UTF32.hs +1/−0
• GHC/IO/Encoding/UTF8.hs +1/−0
• GHC/IO/Exception.hs +6/−1
• GHC/IO/Exception.hs-boot +2/−0
• GHC/IO/FD.hs +2/−0
• GHC/IO/Handle.hs +4/−3
• GHC/IO/Handle.hs-boot +1/−0
• GHC/IO/Handle/FD.hs +9/−6
• GHC/IO/Handle/FD.hs-boot +2/−0
• GHC/IO/Handle/Internals.hs +1/−0
• GHC/IO/Handle/Text.hs +27/−5
• GHC/IO/Handle/Types.hs +1/−0
• GHC/IO/IOMode.hs +2/−0
• GHC/IOArray.hs +2/−0
• GHC/IOBase.hs +10/−10
• GHC/IORef.hs +2/−0
• GHC/Int.hs +37/−156
• GHC/MVar.hs +1/−0
• GHC/Num.lhs +2/−193
• GHC/PArr.hs +8/−0
• GHC/Pack.lhs +1/−0
• GHC/Ptr.lhs +1/−0
• GHC/Real.lhs +46/−8
• GHC/ST.lhs +1/−0
• GHC/STRef.lhs +1/−0
• GHC/Show.lhs +141/−27
• GHC/Stable.lhs +1/−0
• GHC/Stack.hsc +108/−0
• GHC/Stats.hsc +130/−0
• GHC/TopHandler.lhs +6/−7
• GHC/Unicode.hs +1/−1
• GHC/Unicode.hs-boot +1/−0
• GHC/Weak.lhs +1/−0
• GHC/Word.hs +43/−137
• Numeric.hs +6/−6
• System/CPUTime.hsc +8/−8
• System/Console/GetOpt.hs +2/−0
• System/Environment.hs +11/−6
• System/Exit.hs +1/−0
• System/IO.hs +25/−6
• System/IO/Error.hs +1/−0
• System/IO/Unsafe.hs +25/−1
• System/Info.hs +1/−0
• System/Mem.hs +1/−1
• System/Mem/StableName.hs +1/−0
• System/Mem/Weak.hs +1/−0
• System/Posix/Internals.hs +10/−9
• System/Posix/Internals.hs-boot +1/−0
• System/Posix/Types.hs +13/−13
• System/Timeout.hs +1/−0
• Text/ParserCombinators/ReadP.hs +1/−0
• Text/ParserCombinators/ReadPrec.hs +1/−0
• Text/Printf.hs +3/−2
• Text/Read/Lex.hs +53/−46
• Text/Show.hs +1/−0
• Text/Show/Functions.hs +1/−0
• Unsafe/Coerce.hs +4/−0
• base.cabal +3/−3
• cbits/primFloat.c +29/−9
• configure +10/−4
• configure.ac +10/−4
• include/CTypes.h +4/−1
• include/HsBase.h +6/−52

@@ -6,17 +6,16 @@ -- License     :  BSD-style (see the LICENSE file in the distribution) -- -- Maintainer  :  libraries@haskell.org--- Stability   :  experimental+-- Stability   :  provisional -- Portability :  portable -- -- Basic arrow definitions, based on---      /Generalising Monads to Arrows/, by John Hughes,---      /Science of Computer Programming/ 37, pp67-111, May 2000.+--  * /Generalising Monads to Arrows/, by John Hughes,+--    /Science of Computer Programming/ 37, pp67-111, May 2000. -- plus a couple of definitions ('returnA' and 'loop') from---      /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,---      Firenze, Italy, pp229-240.--- See these papers for the equations these combinators are expected to--- satisfy.  These papers and more information on arrows can be found at+--  * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,+--    Firenze, Italy, pp229-240.+-- These papers and more information on arrows can be found at -- <http://www.haskell.org/arrows/>.  module Control.Arrow (@@ -54,10 +53,28 @@  -- | The basic arrow class. -----   Minimal complete definition: 'arr' and 'first'.+-- Minimal complete definition: 'arr' and 'first', satisfying the laws -----   The other combinators have sensible default definitions,---   which may be overridden for efficiency.+--  * @'arr' id = 'id'@+--+--  * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@+--+--  * @'first' ('arr' f) = 'arr' ('first' f)@+--+--  * @'first' (f >>> g) = 'first' f >>> 'first' g@+--+--  * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@+--+--  * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@+--+--  * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@+--+-- where+--+-- > assoc ((a,b),c) = (a,(b,c))+--+-- The other combinators have sensible default definitions,+-- which may be overridden for efficiency.  class Category a => Arrow a where @@ -122,7 +139,6 @@     (***) f g ~(x,y) = (f x, g y)  -- | Kleisli arrows of a monad.- newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }  instance Monad m => Category (Kleisli m) where@@ -135,7 +151,6 @@     second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))  -- | The identity arrow, which plays the role of 'return' in arrow notation.- returnA :: Arrow a => a b b returnA = arr id @@ -161,16 +176,36 @@ instance MonadPlus m => ArrowZero (Kleisli m) where     zeroArrow = Kleisli (\_ -> mzero) +-- | A monoid on arrows. class ArrowZero a => ArrowPlus a where+    -- | An associative operation with identity 'zeroArrow'.     (<+>) :: a b c -> a b c -> a b c  instance MonadPlus m => ArrowPlus (Kleisli m) where     Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)  -- | Choice, for arrows that support it.  This class underlies the---   @if@ and @case@ constructs in arrow notation.---   Any instance must define 'left'.  The other combinators have sensible---   default definitions, which may be overridden for efficiency.+-- @if@ and @case@ constructs in arrow notation.+-- Minimal complete definition: 'left', satisfying the laws+--+--  * @'left' ('arr' f) = 'arr' ('left' f)@+--+--  * @'left' (f >>> g) = 'left' f >>> 'left' g@+--+--  * @'left' f >>> 'arr' 'Left' = 'arr' 'Left' >>> f@+--+--  * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@+--+--  * @'left' ('left' f) >>> 'arr' 'assocsum' = 'arr' 'assocsum' >>> 'left' f@+--+-- where+--+-- > assocsum (Left (Left x)) = Left x+-- > assocsum (Left (Right y)) = Right (Left y)+-- > assocsum (Right z) = Right (Right z)+--+-- The other combinators have sensible default definitions, which may+-- be overridden for efficiency.  class Arrow a => ArrowChoice a where @@ -237,6 +272,15 @@     Kleisli f ||| Kleisli g = Kleisli (either f g)  -- | Some arrows allow application of arrow inputs to other inputs.+-- Instances should satisfy the following laws:+--+--  * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@+--+--  * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@+--+--  * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@+--+-- Such arrows are equivalent to monads (see 'ArrowMonad').  class Arrow a => ArrowApply a where     app :: a (a b c, b) c@@ -264,16 +308,43 @@ leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||              (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app --- | The 'loop' operator expresses computations in which an output value is---   fed back as input, even though the computation occurs only once.---   It underlies the @rec@ value recursion construct in arrow notation.-+-- | The 'loop' operator expresses computations in which an output value+-- is fed back as input, although the computation occurs only once.+-- It underlies the @rec@ value recursion construct in arrow notation.+-- 'loop' should satisfy the following laws:+--+-- [/extension/]+--      @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@+--+-- [/left tightening/]+--      @'loop' ('first' h >>> f) = h >>> 'loop' f@+--+-- [/right tightening/]+--      @'loop' (f >>> 'first' h) = 'loop' f >>> h@+--+-- [/sliding/]+--      @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@+--+-- [/vanishing/]+--      @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@+--+-- [/superposing/]+--      @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@+--+-- where+--+-- > assoc ((a,b),c) = (a,(b,c))+-- > unassoc (a,(b,c)) = ((a,b),c)+-- class Arrow a => ArrowLoop a where     loop :: a (b,d) (c,d) -> a b c  instance ArrowLoop (->) where     loop f b = let (c,d) = f (b,d) in c +-- | Beware that for many monads (those for which the '>>=' operation+-- is strict) this instance will /not/ satisfy the right-tightening law+-- required by the 'ArrowLoop' class. instance MonadFix m => ArrowLoop (Kleisli m) where     loop (Kleisli f) = Kleisli (liftM fst . mfix . f')       where f' x y = f (x, snd y)

@@ -124,7 +124,7 @@  import System.Posix.Types ( Fd ) import Foreign.StablePtr-import Foreign.C.Types  ( CInt )+import Foreign.C.Types import Control.Monad    ( when )  #ifdef mingw32_HOST_OS@@ -559,7 +559,8 @@       threads doing I\/O operations don't block the whole runtime,       whereas on Unix systems all the currently blocked I\/O requests       are managed by a single thread (the /IO manager thread/) using-      @select@.+      a mechanism such as @epoll@ or @kqueue@, depending on what is+      provided by the host operating system.        The runtime will run a Haskell thread using any of the available       worker OS threads.  If you need control over which particular OS

@@ -358,8 +358,8 @@ -- -- Note that we have to give a type signature to @e@, or the program -- will not typecheck as the type is ambiguous. While it is possible--- to catch exceptions of any type, see the previous section \"Catching all--- exceptions\" for an explanation of the problems with doing so.+-- to catch exceptions of any type, see the section \"Catching all+-- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so. -- -- For catching exceptions in pure (non-'IO') expressions, see the -- function 'evaluate'.

@@ -1,34 +0,0 @@-{-# LANGUAGE Trustworthy #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Group--- Copyright   :  (c) Nils Schweinsberg 2011,---                (c) University Tuebingen 2011--- License     :  BSD-style (see the file libraries/base/LICENSE)--- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Monadic grouping (used for monad comprehensions)-----------------------------------------------------------------------------------{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances #-}--module Control.Monad.Group where--import Prelude-#if defined(__GLASGOW_HASKELL__)-import GHC.Exts (groupWith)-#endif---- | `MonadGroup` type class without restrictions on the type `t`-class Monad m => MonadGroup m t where-    mgroupWith :: (a -> t) -> m a -> m (m a)--#if defined(__GLASGOW_HASKELL__)--- | Grouping instance for lists using the `groupWith` function from the--- "GHC.Exts" library-instance Ord t => MonadGroup [] t where-    mgroupWith = groupWith-#endif

@@ -2,6 +2,7 @@ {-# OPTIONS_NHC98 --prelude #-} -- This module deliberately declares orphan instances: {-# OPTIONS_GHC -fno-warn-orphans #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Instances@@ -37,3 +38,4 @@         return = Right         Left  l >>= _ = Left l         Right r >>= k = k r+

@@ -1,7 +1,4 @@-{-# LANGUAGE CPP, SafeImports #-}-#if sh_SAFE_DEFAULT-{-# LANGUAGE Safe #-}-#endif+{-# LANGUAGE Unsafe #-}  ----------------------------------------------------------------------------- -- |@@ -20,18 +17,22 @@ -----------------------------------------------------------------------------  module Control.Monad.ST (-          module Control.Monad.ST.Safe-#if !sh_SAFE_DEFAULT+        -- * The 'ST' Monad+        ST,             -- abstract, instance of Functor, Monad, Typeable.+        runST,          -- :: (forall s. ST s a) -> a+        fixST,          -- :: (a -> ST s a) -> ST s a++        -- * Converting 'ST' to 'IO'+        RealWorld,              -- abstract+        stToIO,                 -- :: ST RealWorld a -> IO a+         -- * Unsafe Functions-        , unsafeInterleaveST-        , unsafeIOToST-        , unsafeSTToIO-#endif+        unsafeInterleaveST,+        unsafeIOToST,+        unsafeSTToIO     ) where -import safe Control.Monad.ST.Safe--#if !sh_SAFE_DEFAULT+import Control.Monad.ST.Safe import qualified Control.Monad.ST.Unsafe as U  {-# DEPRECATED unsafeInterleaveST, unsafeIOToST, unsafeSTToIO@@ -49,5 +50,4 @@ {-# INLINE unsafeSTToIO #-} unsafeSTToIO :: ST s a -> IO a unsafeSTToIO = U.unsafeSTToIO-#endif 

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} 

@@ -1,7 +1,4 @@-{-# LANGUAGE CPP, SafeImports #-}-#if sh_SAFE_DEFAULT-{-# LANGUAGE Safe #-}-#endif+{-# LANGUAGE Unsafe #-}  ----------------------------------------------------------------------------- -- |@@ -20,16 +17,24 @@ -----------------------------------------------------------------------------  module Control.Monad.ST.Lazy (-          module Control.Monad.ST.Lazy.Safe-#if !sh_SAFE_DEFAULT+        -- * The 'ST' monad+        ST,+        runST,+        fixST,++        -- * Converting between strict and lazy 'ST'+        strictToLazyST, lazyToStrictST,++        -- * Converting 'ST' To 'IO'+        RealWorld,+        stToIO,+         -- * Unsafe Functions-        , unsafeInterleaveST-        , unsafeIOToST-#endif+        unsafeInterleaveST,+        unsafeIOToST     ) where -import safe Control.Monad.ST.Lazy.Safe-#if !sh_SAFE_DEFAULT+import Control.Monad.ST.Lazy.Safe import qualified Control.Monad.ST.Lazy.Unsafe as U  {-# DEPRECATED unsafeInterleaveST, unsafeIOToST@@ -43,5 +48,4 @@ {-# INLINE unsafeIOToST #-} unsafeIOToST :: IO a -> ST s a unsafeIOToST = U.unsafeIOToST-#endif 

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, MagicHash, UnboxedTuples, Rank2Types #-} {-# OPTIONS_HADDOCK hide #-} @@ -158,5 +159,4 @@  unsafeIOToST :: IO a -> ST s a unsafeIOToST = strictToLazyST . ST.unsafeIOToST- 

@@ -1,3 +1,5 @@+{-# LANGUAGE Unsafe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.ST.Lazy.Unsafe

@@ -1,7 +1,3 @@-{-# LANGUAGE CPP #-}-#if sh_SAFE_DEFAULT-{-# LANGUAGE Safe #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.ST.Strict@@ -20,9 +16,5 @@         module Control.Monad.ST   ) where -#if sh_SAFE_DEFAULT-import safe Control.Monad.ST-#else import Control.Monad.ST-#endif 

@@ -1,3 +1,5 @@+{-# LANGUAGE Unsafe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.ST.Unsafe

@@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Zip@@ -51,3 +52,4 @@     mzip     = zip     mzipWith = zipWith     munzip   = unzip+

@@ -33,7 +33,9 @@     bitSize,           -- :: a -> Int     isSigned,          -- :: a -> Bool     shiftL, shiftR,    -- :: a -> Int -> a-    rotateL, rotateR   -- :: a -> Int -> a+    unsafeShiftL, unsafeShiftR,  -- :: a -> Int -> a+    rotateL, rotateR,  -- :: a -> Int -> a+    popCount           -- :: a -> Int   )    -- instance Bits Int@@ -72,7 +74,7 @@ ('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')), 'bitSize' and 'isSigned'. -}-class Num a => Bits a where+class (Eq a, Num a) => Bits a where     -- | Bitwise \"and\"     (.&.) :: a -> a -> a @@ -174,8 +176,19 @@     {-# INLINE shiftL #-}     x `shiftL`  i = x `shift`  i -    {-| Shift the first argument right by the specified number of bits-        (which must be non-negative).+    {-| Shift the argument left by the specified number of bits.  The+        result is undefined for negative shift amounts and shift amounts+        greater or equal to the 'bitSize'.++        Defaults to 'shiftL' unless defined explicitly by an instance. -}+    unsafeShiftL            :: a -> Int -> a+    {-# INLINE unsafeShiftL #-}+    x `unsafeShiftL` i = x `shiftL` i++    {-| Shift the first argument right by the specified number of bits. The+        result is undefined for negative shift amounts and shift amounts+        greater or equal to the 'bitSize'.+         Right shifts perform sign extension on signed number types;         i.e. they fill the top bits with 1 if the @x@ is negative         and with 0 otherwise.@@ -187,6 +200,18 @@     {-# INLINE shiftR #-}     x `shiftR`  i = x `shift`  (-i) +    {-| Shift the first argument right by the specified number of bits, which+        must be non-negative an smaller than the number of bits in the type.++        Right shifts perform sign extension on signed number types;+        i.e. they fill the top bits with 1 if the @x@ is negative+        and with 0 otherwise.++        Defaults to 'shiftR' unless defined explicitly by an instance. -}+    unsafeShiftR            :: a -> Int -> a+    {-# INLINE unsafeShiftR #-}+    x `unsafeShiftR` i = x `shiftR` i+     {-| Rotate the argument left by the specified number of bits         (which must be non-negative). @@ -207,6 +232,17 @@     {-# INLINE rotateR #-}     x `rotateR` i = x `rotate` (-i) +    {-| Return the number of set bits in the argument.  This number is+        known as the population count or the Hamming weight. -}+    popCount          :: a -> Int+    popCount = go 0+      where+        go !c 0 = c+        go c w = go (c+1) (w .&. w - 1)  -- clear the least significant bit set+    {- This implementation is intentionally naive.  Instances are+       expected to override it with something optimized for their+       size. -}+ instance Bits Int where     {-# INLINE shift #-} @@ -222,6 +258,10 @@     (I# x#) `shift` (I# i#)         | i# >=# 0#        = I# (x# `iShiftL#` i#)         | otherwise        = I# (x# `iShiftRA#` negateInt# i#)+    (I# x#) `shiftL` (I# i#) = I# (x# `iShiftL#` i#)+    (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#)+    (I# x#) `shiftR` (I# i#) = I# (x# `iShiftRA#` i#)+    (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#)      {-# INLINE rotate #-} 	-- See Note [Constant folding for rotate]     (I# x#) `rotate` (I# i#) =@@ -233,6 +273,8 @@         !wsib = WORD_SIZE_IN_BITS#   {- work around preprocessor problem (??) -}     bitSize  _             = WORD_SIZE_IN_BITS +    popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#)))+ #else /* !__GLASGOW_HASKELL__ */  #ifdef __HUGS__@@ -364,5 +406,4 @@            10000000 -> ww_sOb          } -} -      

@@ -39,3 +39,4 @@   , otherwise   ) #endif+

@@ -50,8 +50,6 @@     , showLitChar       -- :: Char -> ShowS     , lexLitChar        -- :: ReadS String     , readLitChar       -- :: ReadS Char --     -- Implementation checked wrt. Haskell 98 lib report, 1/99.     ) where  #ifdef __GLASGOW_HASKELL__@@ -209,3 +207,4 @@ toTitle :: Char -> Char toTitle = toUpper #endif+

@@ -42,8 +42,6 @@         --  (RealFloat a) => Num        (Complex a)         --  (RealFloat a) => Fractional (Complex a)         --  (RealFloat a) => Floating   (Complex a)-        -- -        -- Implementation checked wrt. Haskell 98 lib report, 1/99.          )  where @@ -205,3 +203,4 @@     asinh z        =  log (z + sqrt (1+z*z))     acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))     atanh z        =  0.5 * log ((1.0+z) / (1.0-z))+

@@ -23,7 +23,6 @@ -- For more information, please visit the new -- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>. ----- -----------------------------------------------------------------------------  module Data.Data (@@ -767,7 +766,7 @@ mkIntConstr :: DataType -> Integer -> Constr mkIntConstr = mkIntegralConstr -mkIntegralConstr :: (Integral a) => DataType -> a -> Constr+mkIntegralConstr :: (Integral a, Show a) => DataType -> a -> Constr mkIntegralConstr dt i = case datarep dt of                   IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger  i))                   _ -> error "Data.Data.mkIntegralConstr"@@ -777,7 +776,7 @@ mkFloatConstr :: DataType -> Double -> Constr mkFloatConstr dt = mkRealConstr dt . toRational -mkRealConstr :: (Real a) => DataType -> a -> Constr+mkRealConstr :: (Real a, Show a) => DataType -> a -> Constr mkRealConstr dt f = case datarep dt of                     FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f))                     _ -> error "Data.Data.mkRealConstr"

@@ -168,3 +168,4 @@  dynTypeRep :: Dynamic -> TypeRep dynTypeRep (Dynamic tr _) = tr +

@@ -22,3 +22,4 @@ #if __GLASGOW_HASKELL__ import GHC.Base #endif+

@@ -1,10 +1,10 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} {-# OPTIONS -Wall -fno-warn-unused-binds #-}- #ifndef __NHC__ {-# LANGUAGE DeriveDataTypeable #-} #endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Fixed@@ -246,3 +246,4 @@     resolution _ = 1000000000000 -- | resolution of 10^-12 = .000000000001 type Pico = Fixed E12+

@@ -18,6 +18,8 @@ -- functor.  To avoid ambiguity, either import those modules hiding -- these names or qualify uses of these function names with an alias -- for this module.+--+-----------------------------------------------------------------------------  module Data.Foldable (     -- * Folds@@ -320,3 +322,4 @@ -- 'Nothing' if there is no such element. find :: Foldable t => (a -> Bool) -> t a -> Maybe a find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])+

@@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Function@@ -10,6 +11,8 @@ -- Portability :  portable -- -- Simple combinators working solely on and with functions.+--+-----------------------------------------------------------------------------  module Data.Function   ( -- * "Prelude" re-exports@@ -82,3 +85,4 @@  on :: (b -> b -> c) -> (a -> b) -> a -> a -> c (.*.) `on` f = \x y -> f x .*. f y+

@@ -33,3 +33,4 @@ -- | An infix synonym for 'fmap'. (<$>) :: Functor f => (a -> b) -> f a -> f b (<$>) = fmap+

@@ -531,3 +531,4 @@         lengthCmp []   []    = EQ         lengthCmp []   _     = LT         lengthCmp _    []    = GT+

@@ -138,3 +138,4 @@   'IORef' operations.  -}+

@@ -65,3 +65,4 @@   count to the width of the type, for example @1 \<\< 32   == 1@ in some C implementations. -}+

@@ -16,6 +16,7 @@ -- (see the array package). --  -----------------------------------------------------------------------------+ module Data.Ix     (     -- * The 'Ix' class@@ -35,8 +36,6 @@     --  Ix ()     --  (Ix a, Ix b) => Ix (a, b)     --  ...--    -- Implementation checked wrt. Haskell 98 lib report, 1/99.      -- * Deriving Instances of 'Ix'     -- | Derived instance declarations for the class 'Ix' are only possible

@@ -95,6 +95,7 @@     , takeWhile         -- :: (a -> Bool) -> [a] -> [a]    , dropWhile         -- :: (a -> Bool) -> [a] -> [a]+   , dropWhileEnd      -- :: (a -> Bool) -> [a] -> [a]    , span              -- :: (a -> Bool) -> [a] -> ([a], [a])    , break             -- :: (a -> Bool) -> [a] -> ([a], [a]) @@ -228,6 +229,16 @@ -- ----------------------------------------------------------------------------- -- List functions +-- | The 'dropWhileEnd' function drops the largest suffix of a list+-- in which the given predicate holds for all elements.  For example:+--+-- > dropWhileEnd isSpace "foo\n" == "foo"+-- > dropWhileEnd isSpace "foo bar" == "foo bar"+-- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined++dropWhileEnd :: (a -> Bool) -> [a] -> [a]+dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []+ -- | The 'stripPrefix' function drops the given prefix from a list. -- It returns 'Nothing' if the list did not start with the prefix -- given, or 'Just' the list after the prefix, if it does.@@ -1105,3 +1116,4 @@   error ("Prelude." ++ fun ++ ": empty list")  #endif /* !__GLASGOW_HASKELL__ */+

@@ -149,3 +149,4 @@   Just r  -> r:rs  #endif /* else not __NHC__ */+

@@ -14,11 +14,13 @@ -- -- A class for monoids (types with an associative binary operation that -- has an identity) with various general-purpose instances.+-- -----------------------------------------------------------------------------  module Data.Monoid (         -- * Monoid typeclass         Monoid(..),+        (<>),         Dual(..),         Endo(..),         -- * Bool wrappers@@ -87,6 +89,13 @@          mconcat = foldr mappend mempty +infixr 6 <>++-- | An infix synonym for 'mappend'.+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}+ -- Monoid instances.  instance Monoid [a] where@@ -276,3 +285,4 @@         where listLastToMaybe [] = Nothing               listLastToMaybe lst = Just (last lst) -- -}+

@@ -34,3 +34,4 @@ -- >   ... sortBy (comparing fst) ... comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering comparing p x y = compare (p x) (p y)+

@@ -95,3 +95,4 @@                                            n''        =  numerator nd''                                            d''        =  denominator nd'' #endif+

@@ -42,3 +42,4 @@ -- |Mutate the contents of an 'STRef' modifySTRef :: STRef s a -> (a -> a) -> ST s () modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref+

@@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.STRef.Lazy@@ -12,6 +13,7 @@ -- Mutable references in the lazy ST monad. -- -----------------------------------------------------------------------------+ module Data.STRef.Lazy (         -- * STRefs         ST.STRef,       -- abstract, instance Eq@@ -30,7 +32,8 @@ writeSTRef  :: ST.STRef s a -> a -> ST s () modifySTRef :: ST.STRef s a -> (a -> a) -> ST s () -newSTRef   = strictToLazyST . ST.newSTRef-readSTRef  = strictToLazyST . ST.readSTRef-writeSTRef r a = strictToLazyST (ST.writeSTRef r a)+newSTRef        = strictToLazyST . ST.newSTRef+readSTRef       = strictToLazyST . ST.readSTRef+writeSTRef  r a = strictToLazyST (ST.writeSTRef r a) modifySTRef r f = strictToLazyST (ST.modifySTRef r f)+

@@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.STRef.Strict@@ -18,3 +19,4 @@   ) where  import Data.STRef+

@@ -41,3 +41,4 @@ instance IsString [Char] where     fromString xs = xs #endif+

@@ -29,6 +29,8 @@ -- functions of the same names from lists to any 'Traversable' functor. -- To avoid ambiguity, either import the "Prelude" hiding these names -- or qualify uses of these function names with an alias for this module.+--+-----------------------------------------------------------------------------  module Data.Traversable (     Traversable(..),@@ -194,3 +196,4 @@ instance Applicative Id where     pure = Id     Id f <*> Id x = Id (f x)+

@@ -2,6 +2,7 @@ {-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh.+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Tuple@@ -45,7 +46,7 @@  import GHC.Base -- We need to depend on GHC.Base so that--- a) so that we get GHC.Classes, GHC.Ordering, GHC.Types+-- a) so that we get GHC.Classes, GHC.Types  -- b) so that GHC.Base.inline is available, which is used --    when expanding instance declarations@@ -78,10 +79,6 @@   , fst, snd   , curry, uncurry   )-#endif--#ifdef __GLASGOW_HASKELL__-import GHC.Unit () #endif  default ()              -- Double isn't available yet

@@ -51,6 +51,9 @@          TyCon,          -- abstract, instance of: Eq, Show, Typeable         tyConString,    -- :: TyCon   -> String+        tyConPackage,   -- :: TyCon   -> String+        tyConModule,    -- :: TyCon   -> String+        tyConName,      -- :: TyCon   -> String          -- * Construction of type representations         mkTyCon,        -- :: String  -> TyCon

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Typeable (Typeable, mkTyConApp, cast) where

@@ -1,3 +1,5 @@+{-# LANGUAGE Unsafe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Typeable.Internal@@ -184,6 +186,7 @@ typeRepArgs (TypeRep _ _ args) = args  -- | Observe string encoding of a type representation+{-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-} tyConString :: TyCon   -> String tyConString = tyConName 

@@ -1,4 +1,6 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}+ module Data.Typeable.Internal (     Typeable(typeOf),     TypeRep,

@@ -68,3 +68,4 @@   truncate the shift count to the width of the type, for example @1 \<\<   32 == 1@ in some C implementations.  -}+

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, MagicHash, UnboxedTuples #-}  ----------------------------------------------------------------------------- -- |@@ -10,32 +11,59 @@ -- Stability   :  provisional -- Portability :  portable ----- The 'trace' function.+-- Functions for tracing and monitoring execution. --+-- These can be useful for investigating bugs or performance problems.+-- They should /not/ be used in production code.+-- -----------------------------------------------------------------------------  module Debug.Trace (         -- * Tracing-        putTraceMsg,      -- :: String -> IO ()+        -- $tracing         trace,            -- :: String -> a -> a-        traceShow+        traceShow,+        traceStack,+        traceIO,          -- :: String -> IO ()+        putTraceMsg,++        -- * Eventlog tracing+        -- $eventlog_tracing+        traceEvent,+        traceEventIO,   ) where  import Prelude import System.IO.Unsafe+import Control.Monad  #ifdef __GLASGOW_HASKELL__ import Foreign.C.String+import GHC.Base+import qualified GHC.Foreign+import GHC.IO.Encoding+import GHC.Ptr+import GHC.Stack #else import System.IO (hPutStrLn,stderr) #endif --- | 'putTraceMsg' function outputs the trace message from IO monad.--- Usually the output stream is 'System.IO.stderr' but if the function is called--- from Windows GUI application then the output will be directed to the Windows--- debug console.-putTraceMsg :: String -> IO ()-putTraceMsg msg = do+-- $tracing+--+-- The 'trace', 'traceShow' and 'traceIO' functions print messages to an output+-- stream. They are intended for \"printf debugging\", that is: tracing the flow+-- of execution and printing interesting values.++-- The usual output stream is 'System.IO.stderr'. For Windows GUI applications+-- (that have no stderr) the output is directed to the Windows debug console.+-- Some implementations of these functions may decorate the string that\'s+-- output to indicate that you\'re tracing.++-- | The 'traceIO' function outputs the trace message from the IO monad.+-- This sequences the output with respect to other IO actions.+--+traceIO :: String -> IO ()+traceIO msg = do #ifndef __GLASGOW_HASKELL__     hPutStrLn stderr msg #else@@ -49,24 +77,105 @@    debugBelch :: CString -> CString -> IO () #endif ++-- | Deprecated. Use 'traceIO'.+putTraceMsg :: String -> IO ()+putTraceMsg = traceIO+{-# DEPRECATED putTraceMsg "Use Debug.Trace.traceIO" #-}++ {-# NOINLINE trace #-} {-|-When called, 'trace' outputs the string in its first argument, before -returning the second argument as its result. The 'trace' function is not -referentially transparent, and should only be used for debugging, or for -monitoring execution. Some implementations of 'trace' may decorate the string -that\'s output to indicate that you\'re tracing. The function is implemented on-top of 'putTraceMsg'.+The 'trace' function outputs the trace message given as its first argument,+before returning the second argument as its result.++For example, this returns the value of @f x@ but first outputs the message.++> trace ("calling f with x = " ++ show x) (f x)++The 'trace' function should /only/ be used for debugging, or for monitoring+execution. The function is not referentially transparent: its type indicates+that it is a pure function but it has the side effect of outputting the+trace message. -} trace :: String -> a -> a trace string expr = unsafePerformIO $ do-    putTraceMsg string+    traceIO string     return expr  {-| Like 'trace', but uses 'show' on the argument to convert it to a 'String'. -> traceShow = trace . show+This makes it convenient for printing the values of interesting variables or+expressions inside a function. For example here we print the value of the+variables @x@ and @z@:++> f x y =+>     traceShow (x, z) $ result+>   where+>     z = ...+>     ... -} traceShow :: (Show a) => a -> b -> b traceShow = trace . show+++-- $eventlog_tracing+--+-- Eventlog tracing is a performance profiling system. These functions emit+-- extra events into the eventlog. In combination with eventlog profiling+-- tools these functions can be used for monitoring execution and+-- investigating performance problems.+--+-- Currently only GHC provides eventlog profiling, see the GHC user guide for+-- details on how to use it. These function exists for other Haskell+-- implementations but no events are emitted. Note that the string message is+-- always evaluated, whether or not profiling is available or enabled.++{-# NOINLINE traceEvent #-}+-- | The 'traceEvent' function behaves like 'trace' with the difference that+-- the message is emitted to the eventlog, if eventlog profiling is available+-- and enabled at runtime.+--+-- It is suitable for use in pure code. In an IO context use 'traceEventIO'+-- instead.+--+-- Note that when using GHC's SMP runtime, it is possible (but rare) to get+-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk+-- that uses 'traceEvent'.+--+traceEvent :: String -> a -> a+traceEvent msg expr = unsafeDupablePerformIO $ do+    traceEventIO msg+    return expr++-- | The 'traceEventIO' function emits a message to the eventlog, if eventlog+-- profiling is available and enabled at runtime.+--+-- Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to+-- other IO actions.+--+traceEventIO :: String -> IO ()+#ifdef __GLASGOW_HASKELL__+traceEventIO msg =+  GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->+    case traceEvent# p s of s' -> (# s', () #)+#else+traceEventIO msg = (return $! length msg) >> return ()+#endif++-- | like 'trace', but additionally prints a call stack if one is+-- available.+--+-- In the current GHC implementation, the call stack is only+-- availble if the program was compiled with @-prof@; otherwise+-- 'traceStack' behaves exactly like 'trace'.  Entries in the call+-- stack correspond to @SCC@ annotations, so it is a good idea to use+-- @-fprof-auto@ or @-fprof-auto-calls@ to add SCC annotations automatically.+--+traceStack :: String -> a -> a+traceStack str expr = unsafePerformIO $ do+   traceIO str+   stack <- currentCallStack+   when (not (null stack)) $ traceIO (renderStack stack)+   return expr

@@ -1,6 +1,4 @@-#if sh_SAFE_DEFAULT-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude #-}  -----------------------------------------------------------------------------@@ -28,7 +26,6 @@         , module Foreign.Storable         , module Foreign.Marshal -#if !sh_SAFE_DEFAULT         -- * Unsafe Functions          -- | 'unsafePerformIO' is exported here for backwards@@ -36,7 +33,6 @@         -- the FFI, use 'unsafeLocalState'.  For other uses, see         -- 'System.IO.Unsafe.unsafePerformIO'.         , unsafePerformIO-#endif         ) where  import Data.Bits@@ -48,14 +44,12 @@ import Foreign.Storable import Foreign.Marshal -#if !sh_SAFE_DEFAULT import GHC.IO (IO)-import qualified System.IO.Unsafe (unsafePerformIO)+import qualified GHC.IO (unsafePerformIO)  {-# DEPRECATED unsafePerformIO "Use System.IO.Unsafe.unsafePerformIO instead; This function will be removed in the next release" #-}  {-# INLINE unsafePerformIO #-} unsafePerformIO :: IO a -> a-unsafePerformIO = System.IO.Unsafe.unsafePerformIO-#endif+unsafePerformIO = GHC.IO.unsafePerformIO 

@@ -24,3 +24,4 @@ import Foreign.C.Types import Foreign.C.String import Foreign.C.Error+

@@ -401,34 +401,36 @@ -- | Throw an 'IOError' corresponding to the current value of 'getErrno' -- if the 'IO' action returns a result of @-1@. ---throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a throwErrnoIfMinus1  = throwErrnoIf (== -1)  -- | as 'throwErrnoIfMinus1', but discards the result. ---throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()+throwErrnoIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO () throwErrnoIfMinus1_  = throwErrnoIf_ (== -1)  -- | Throw an 'IOError' corresponding to the current value of 'getErrno' -- if the 'IO' action returns a result of @-1@, but retries in case of -- an interrupted operation. ---throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)  -- | as 'throwErrnoIfMinus1', but discards the result. ---throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()+throwErrnoIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO () throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)  -- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block. ---throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a+throwErrnoIfMinus1RetryMayBlock :: (Eq a, Num a)+                                => String -> IO a -> IO b -> IO a throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)  -- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result. ---throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()+throwErrnoIfMinus1RetryMayBlock_ :: (Eq a, Num a)+                                 => String -> IO a -> IO b -> IO () throwErrnoIfMinus1RetryMayBlock_  = throwErrnoIfRetryMayBlock_ (== -1)  -- | Throw an 'IOError' corresponding to the current value of 'getErrno'@@ -481,13 +483,13 @@ -- | as 'throwErrnoIfMinus1', but exceptions include the given path when --   appropriate. ---throwErrnoPathIfMinus1 :: Num a => String -> FilePath -> IO a -> IO a+throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> FilePath -> IO a -> IO a throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)  -- | as 'throwErrnoIfMinus1_', but exceptions include the given path when --   appropriate. ---throwErrnoPathIfMinus1_ :: Num a => String -> FilePath -> IO a -> IO ()+throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> FilePath -> IO a -> IO () throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)  -- conversion of an "errno" value into IO error@@ -614,3 +616,4 @@ #endif  foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)+

@@ -147,7 +147,7 @@ #ifndef __GLASGOW_HASKELL__ peekCString = peekCAString #else-peekCString = GHC.peekCString foreignEncoding+peekCString s = getForeignEncoding >>= flip GHC.peekCString s #endif  -- | Marshal a C string with explicit length into a Haskell string.@@ -156,7 +156,7 @@ #ifndef __GLASGOW_HASKELL__ peekCStringLen = peekCAStringLen #else-peekCStringLen = GHC.peekCStringLen foreignEncoding+peekCStringLen s = getForeignEncoding >>= flip GHC.peekCStringLen s #endif  -- | Marshal a Haskell string into a NUL terminated C string.@@ -171,7 +171,7 @@ #ifndef __GLASGOW_HASKELL__ newCString = newCAString #else-newCString = GHC.newCString foreignEncoding+newCString s = getForeignEncoding >>= flip GHC.newCString s #endif  -- | Marshal a Haskell string into a C string (ie, character array) with@@ -185,7 +185,7 @@ #ifndef __GLASGOW_HASKELL__ newCStringLen = newCAStringLen #else-newCStringLen = GHC.newCStringLen foreignEncoding+newCStringLen s = getForeignEncoding >>= flip GHC.newCStringLen s #endif  -- | Marshal a Haskell string into a NUL terminated C string using temporary@@ -201,7 +201,7 @@ #ifndef __GLASGOW_HASKELL__ withCString = withCAString #else-withCString = GHC.withCString foreignEncoding+withCString s f = getForeignEncoding >>= \enc -> GHC.withCString enc s f #endif  -- | Marshal a Haskell string into a C string (ie, character array)@@ -215,7 +215,7 @@ #ifndef __GLASGOW_HASKELL__ withCStringLen = withCAStringLen #else-withCStringLen = GHC.withCStringLen foreignEncoding+withCStringLen s f = getForeignEncoding >>= \enc -> GHC.withCStringLen enc s f #endif  @@ -230,7 +230,7 @@ -- -- | Determines whether a character can be accurately encoded in a 'CString'. -- -- Unrepresentable characters are converted to '?' or their nearest visual equivalent. charIsRepresentable :: Char -> IO Bool-charIsRepresentable = GHC.charIsRepresentable foreignEncoding+charIsRepresentable c = getForeignEncoding >>= flip GHC.charIsRepresentable c #endif  -- single byte characters@@ -484,10 +484,9 @@ withCWString :: String -> (CWString -> IO a) -> IO a withCWString  = withArray0 wNUL . charsToCWchars --- | Marshal a Haskell string into a NUL terminated C wide string using--- temporary storage.------ * the Haskell string may /not/ contain any NUL characters+-- | Marshal a Haskell string into a C wide string (i.e. wide+-- character array) in temporary storage, with explicit length+-- information. -- -- * the memory is freed when the subcomputation terminates (either --   normally or via an exception), so the pointer to the temporary@@ -542,3 +541,4 @@ castCharToCWchar ch = fromIntegral (ord ch)  #endif /* !mingw32_HOST_OS */+

@@ -27,7 +27,6 @@  module Foreign.C.Types         ( -- * Representations of C types-#ifndef __NHC__           -- $ctypes            -- ** Integral types@@ -37,20 +36,19 @@           -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',           -- 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral' and           -- 'Bits'.-          CChar,  CSChar,  CUChar-        , CShort, CUShort, CInt,   CUInt-        , CLong,  CULong-        , CPtrdiff, CSize, CWchar, CSigAtomic-        , CLLong, CULLong-        , CIntPtr, CUIntPtr-        , CIntMax, CUIntMax+          CChar(..),    CSChar(..),   CUChar(..)+        , CShort(..),   CUShort(..),  CInt(..),      CUInt(..)+        , CLong(..),    CULong(..)+        , CPtrdiff(..), CSize(..),    CWchar(..),    CSigAtomic(..)+        , CLLong(..),   CULLong(..)+        , CIntPtr(..),  CUIntPtr(..), CIntMax(..),   CUIntMax(..)            -- ** Numeric types           -- | These types are are represented as @newtype@s of basic           -- foreign types, and are instances of           -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',           -- 'Prelude.Show', 'Prelude.Enum', 'Typeable' and 'Storable'.-        , CClock,   CTime, CUSeconds, CSUSeconds+        , CClock(..),   CTime(..),    CUSeconds(..), CSUSeconds(..)          -- extracted from CTime, because we don't want this comment in         -- the Haskell 2010 report:@@ -67,21 +65,10 @@           -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',           -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating',           -- 'Prelude.RealFrac' and 'Prelude.RealFloat'.-        , CFloat,  CDouble+        , CFloat(..),   CDouble(..) -- GHC doesn't support CLDouble yet #ifndef __GLASGOW_HASKELL__-        , CLDouble-#endif-#else-          -- Exported non-abstractly in nhc98 to fix an interface file problem.-          CChar(..),    CSChar(..),   CUChar(..)-        , CShort(..),   CUShort(..),  CInt(..),      CUInt(..)-        , CLong(..),    CULong(..)-        , CPtrdiff(..), CSize(..),    CWchar(..),    CSigAtomic(..)-        , CLLong(..),   CULLong(..)-        , CClock(..),   CTime(..),    CUSeconds(..), CSUSeconds(..)-        , CFloat(..),   CDouble(..),  CLDouble(..)-        , CIntPtr(..),  CUIntPtr(..), CIntMax(..),   CUIntMax(..)+        , CLDouble(..) #endif           -- ** Other types @@ -320,7 +307,8 @@   complementBit (T x) n = T (complementBit x n) ; \   testBit       (T x) n = testBit x n ; \   bitSize       (T x)   = bitSize x ; \-  isSigned      (T x)   = isSigned x }+  isSigned      (T x)   = isSigned x ; \+  popCount      (T x)   = popCount x }  INSTANCE_BITS(CChar) INSTANCE_BITS(CSChar)@@ -343,3 +331,4 @@ INSTANCE_BITS(CUIntMax)  #endif+

@@ -1,7 +1,5 @@-{-# LANGUAGE SafeImports, CPP, NoImplicitPrelude #-}-#if sh_SAFE_DEFAULT-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------@@ -21,16 +19,41 @@ -----------------------------------------------------------------------------  module Foreign.ForeignPtr ( -          module Foreign.ForeignPtr.Safe-#if !sh_SAFE_DEFAULT+        -- * Finalised data pointers+          ForeignPtr+        , FinalizerPtr+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+        , FinalizerEnvPtr+#endif+        -- ** Basic operations+        , newForeignPtr+        , newForeignPtr_+        , addForeignPtrFinalizer+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+        , newForeignPtrEnv+        , addForeignPtrFinalizerEnv+#endif+        , withForeignPtr++#ifdef __GLASGOW_HASKELL__+        , finalizeForeignPtr+#endif++        -- ** Low-level operations+        , touchForeignPtr+        , castForeignPtr++        -- ** Allocating managed memory+        , mallocForeignPtr+        , mallocForeignPtrBytes+        , mallocForeignPtrArray+        , mallocForeignPtrArray0         -- ** Unsafe low-level operations         , unsafeForeignPtrToPtr-#endif     ) where -import safe Foreign.ForeignPtr.Safe+import Foreign.ForeignPtr.Safe -#if !sh_SAFE_DEFAULT import Foreign.Ptr ( Ptr ) import qualified Foreign.ForeignPtr.Unsafe as U @@ -38,5 +61,4 @@ {-# INLINE unsafeForeignPtrToPtr #-} unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a unsafeForeignPtrToPtr = U.unsafeForeignPtrToPtr-#endif 

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} @@ -178,3 +179,4 @@ -- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'. mallocForeignPtrArray0      :: Storable a => Int -> IO (ForeignPtr a) mallocForeignPtrArray0 size  = mallocForeignPtrArray (size + 1)+

@@ -1,4 +1,4 @@-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude #-}  -----------------------------------------------------------------------------

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude #-}  -----------------------------------------------------------------------------

@@ -62,7 +62,7 @@ ) where  import Data.Maybe-import Foreign.C.Types          ( CSize )+import Foreign.C.Types          ( CSize(..) ) import Foreign.Storable         ( Storable(sizeOf,alignment) )  #ifndef __GLASGOW_HASKELL__@@ -245,3 +245,4 @@ -- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage -- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'. foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a+

@@ -277,3 +277,4 @@   where     doAdvance             :: Storable a' => a' -> Ptr a' -> Int -> Ptr a'     doAdvance dummy ptr i  = ptr `plusPtr` (i * sizeOf dummy)+

@@ -83,3 +83,4 @@ -- void     :: IO a -> IO () void act  = act >> return ()+

@@ -209,3 +209,4 @@    ptr <- pooledMallocArray0 pool (length vals)    pokeArray0 marker ptr vals    return ptr+

@@ -1,4 +1,4 @@-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude #-}  -----------------------------------------------------------------------------

@@ -51,7 +51,7 @@ import Data.Maybe import Foreign.Ptr              ( Ptr, nullPtr ) import Foreign.Storable         ( Storable(poke) )-import Foreign.C.Types          ( CSize )+import Foreign.C.Types          ( CSize(..) ) import Foreign.Marshal.Alloc    ( malloc, alloca )  #ifdef __GLASGOW_HASKELL__@@ -108,7 +108,7 @@  -- |Convert a Boolean in numeric representation to a Haskell value ---toBool :: Num a => a -> Bool+toBool :: (Eq a, Num a) => a -> Bool toBool  = (/= 0)  @@ -178,3 +178,4 @@ -- foreign import ccall unsafe "string.h" memcpy  :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)+

@@ -162,3 +162,4 @@  # endif /* !__GLASGOW_HASKELL__ */ #endif /* !__NHC_ */+

@@ -61,3 +61,4 @@ -- guarantee provided is that if they are passed back to Haskell land, the -- function 'deRefStablePtr' will be able to reconstruct the -- Haskell value referred to by the stable pointer.+

@@ -284,3 +284,4 @@       pokeW64 (castPtr p0) 8 high       pokeW64 (castPtr p0 `plusPtr` 8) 8 low #endif+

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, NoBangPatterns, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-}

@@ -62,6 +62,7 @@ Other Prelude modules are much easier with fewer complex dependencies.  \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP            , NoImplicitPrelude            , BangPatterns@@ -98,7 +99,6 @@         module GHC.Base,         module GHC.Classes,         module GHC.CString,-        module GHC.Ordering,         module GHC.Types,         module GHC.Prim,        -- Re-export GHC.Prim and GHC.Err, to avoid lots         module GHC.Err          -- of people having to import it explicitly@@ -108,17 +108,19 @@ import GHC.Types import GHC.Classes import GHC.CString-import GHC.Ordering import GHC.Prim import {-# SOURCE #-} GHC.Show import {-# SOURCE #-} GHC.Err import {-# SOURCE #-} GHC.IO (failIO) --- These two are not strictly speaking required by this module, but they are--- implicit dependencies whenever () or tuples are mentioned, so adding them--- as imports here helps to get the dependencies right in the new build system.+-- This is not strictly speaking required by this module, but is an+-- implicit dependency whenever () or tuples are mentioned, so adding it+-- as an import here helps to get the dependencies right in the new+-- build system. import GHC.Tuple ()-import GHC.Unit ()+-- Likewise we need Integer when deriving things like Eq instances, and+-- this is a convenient place to force it to be built+import GHC.Integer ()  infixr 9  . infixr 5  ++

@@ -1,297 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh.-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  GHC.Classes--- Copyright   :  (c) The University of Glasgow, 1992-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Basic classes.-----------------------------------------------------------------------------------module GHC.Classes where--import GHC.Integer--- GHC.Magic is used in some derived instances-import GHC.Magic ()-import GHC.Ordering-import GHC.Prim-import GHC.Tuple-import GHC.Types-import GHC.Unit--- For defining instances for the generic deriving mechanism-import GHC.Generics (Arity(..), Associativity(..), Fixity(..))---infix  4  ==, /=, <, <=, >=, >-infixr 3  &&-infixr 2  ||--default ()              -- Double isn't available yet---- | The 'Eq' class defines equality ('==') and inequality ('/=').--- All the basic datatypes exported by the "Prelude" are instances of 'Eq',--- and 'Eq' may be derived for any datatype whose constituents are also--- instances of 'Eq'.------ Minimal complete definition: either '==' or '/='.----class  Eq a  where-    (==), (/=)           :: a -> a -> Bool--    {-# INLINE (/=) #-}-    {-# INLINE (==) #-}-    x /= y               = not (x == y)-    x == y               = not (x /= y)--deriving instance Eq ()-deriving instance (Eq  a, Eq  b) => Eq  (a, b)-deriving instance (Eq  a, Eq  b, Eq  c) => Eq  (a, b, c)-deriving instance (Eq  a, Eq  b, Eq  c, Eq  d) => Eq  (a, b, c, d)-deriving instance (Eq  a, Eq  b, Eq  c, Eq  d, Eq  e) => Eq  (a, b, c, d, e)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)-               => Eq (a, b, c, d, e, f)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g)-               => Eq (a, b, c, d, e, f, g)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h)-               => Eq (a, b, c, d, e, f, g, h)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h, Eq i)-               => Eq (a, b, c, d, e, f, g, h, i)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h, Eq i, Eq j)-               => Eq (a, b, c, d, e, f, g, h, i, j)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h, Eq i, Eq j, Eq k)-               => Eq (a, b, c, d, e, f, g, h, i, j, k)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h, Eq i, Eq j, Eq k, Eq l)-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m)-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n)-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,-                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o)-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)--instance (Eq a) => Eq [a] where-    {-# SPECIALISE instance Eq [Char] #-}-    []     == []     = True-    (x:xs) == (y:ys) = x == y && xs == ys-    _xs    == _ys    = False--deriving instance Eq Bool-deriving instance Eq Ordering--instance Eq Char where-    (C# c1) == (C# c2) = c1 `eqChar#` c2-    (C# c1) /= (C# c2) = c1 `neChar#` c2--instance  Eq Integer  where-    (==) = eqInteger-    (/=) = neqInteger--instance Eq Float where-    (F# x) == (F# y) = x `eqFloat#` y--instance Eq Double where-    (D# x) == (D# y) = x ==## y--instance Eq Int where-    (==) = eqInt-    (/=) = neInt--{-# INLINE eqInt #-}-{-# INLINE neInt #-}-eqInt, neInt :: Int -> Int -> Bool-(I# x) `eqInt` (I# y) = x ==# y-(I# x) `neInt` (I# y) = x /=# y---- | The 'Ord' class is used for totally ordered datatypes.------ Instances of 'Ord' can be derived for any user-defined--- datatype whose constituent types are in 'Ord'.  The declared order--- of the constructors in the data declaration determines the ordering--- in derived 'Ord' instances.  The 'Ordering' datatype allows a single--- comparison to determine the precise ordering of two objects.------ Minimal complete definition: either 'compare' or '<='.--- Using 'compare' can be more efficient for complex types.----class  (Eq a) => Ord a  where-    compare              :: a -> a -> Ordering-    (<), (<=), (>), (>=) :: a -> a -> Bool-    max, min             :: a -> a -> a--    compare x y = if x == y then EQ-                  -- NB: must be '<=' not '<' to validate the-                  -- above claim about the minimal things that-                  -- can be defined for an instance of Ord:-                  else if x <= y then LT-                  else GT--    x <  y = case compare x y of { LT -> True;  _ -> False }-    x <= y = case compare x y of { GT -> False; _ -> True }-    x >  y = case compare x y of { GT -> True;  _ -> False }-    x >= y = case compare x y of { LT -> False; _ -> True }--        -- These two default methods use '<=' rather than 'compare'-        -- because the latter is often more expensive-    max x y = if x <= y then y else x-    min x y = if x <= y then x else y--deriving instance Ord ()-deriving instance (Ord a, Ord b) => Ord (a, b)-deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c)-deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f)-               => Ord (a, b, c, d, e, f)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g)-               => Ord (a, b, c, d, e, f, g)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h)-               => Ord (a, b, c, d, e, f, g, h)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h, Ord i)-               => Ord (a, b, c, d, e, f, g, h, i)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h, Ord i, Ord j)-               => Ord (a, b, c, d, e, f, g, h, i, j)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h, Ord i, Ord j, Ord k)-               => Ord (a, b, c, d, e, f, g, h, i, j, k)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h, Ord i, Ord j, Ord k, Ord l)-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m)-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n)-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,-                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o)-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)--instance (Ord a) => Ord [a] where-    {-# SPECIALISE instance Ord [Char] #-}-    compare []     []     = EQ-    compare []     (_:_)  = LT-    compare (_:_)  []     = GT-    compare (x:xs) (y:ys) = case compare x y of-                                EQ    -> compare xs ys-                                other -> other--deriving instance Ord Bool-deriving instance Ord Ordering---- We don't use deriving for Ord Char, because for Ord the derived--- instance defines only compare, which takes two primops.  Then--- '>' uses compare, and therefore takes two primops instead of one.-instance Ord Char where-    (C# c1) >  (C# c2) = c1 `gtChar#` c2-    (C# c1) >= (C# c2) = c1 `geChar#` c2-    (C# c1) <= (C# c2) = c1 `leChar#` c2-    (C# c1) <  (C# c2) = c1 `ltChar#` c2--instance Ord Integer where-    (<=) = leInteger-    (>)  = gtInteger-    (<)  = ltInteger-    (>=) = geInteger-    compare = compareInteger--instance Ord Float where-    (F# x) `compare` (F# y)-        = if      x `ltFloat#` y then LT-          else if x `eqFloat#` y then EQ-          else                        GT--    (F# x) <  (F# y) = x `ltFloat#`  y-    (F# x) <= (F# y) = x `leFloat#`  y-    (F# x) >= (F# y) = x `geFloat#`  y-    (F# x) >  (F# y) = x `gtFloat#`  y--instance Ord Double where-    (D# x) `compare` (D# y)-        = if      x <##  y then LT-          else if x ==## y then EQ-          else                  GT--    (D# x) <  (D# y) = x <##  y-    (D# x) <= (D# y) = x <=## y-    (D# x) >= (D# y) = x >=## y-    (D# x) >  (D# y) = x >##  y--instance Ord Int where-    compare = compareInt-    (<)     = ltInt-    (<=)    = leInt-    (>=)    = geInt-    (>)     = gtInt--{-# INLINE gtInt #-}-{-# INLINE geInt #-}-{-# INLINE ltInt #-}-{-# INLINE leInt #-}-gtInt, geInt, ltInt, leInt :: Int -> Int -> Bool-(I# x) `gtInt` (I# y) = x >#  y-(I# x) `geInt` (I# y) = x >=# y-(I# x) `ltInt` (I# y) = x <#  y-(I# x) `leInt` (I# y) = x <=# y--compareInt :: Int -> Int -> Ordering-(I# x#) `compareInt` (I# y#) = compareInt# x# y#--compareInt# :: Int# -> Int# -> Ordering-compareInt# x# y#-    | x# <#  y# = LT-    | x# ==# y# = EQ-    | True      = GT---- OK, so they're technically not part of a class...:---- Boolean functions---- | Boolean \"and\"-(&&)                    :: Bool -> Bool -> Bool-True  && x              =  x-False && _              =  False---- | Boolean \"or\"-(||)                    :: Bool -> Bool -> Bool-True  || _              =  True-False || x              =  x---- | Boolean \"not\"-not                     :: Bool -> Bool-not True                =  False-not False               =  True------------------------------------------------------------------------------ Generic deriving----------------------------------------------------------------------------- We need instances for some basic datatypes, but some of those use Int,--- so we have to put the instances here-deriving instance Eq Arity-deriving instance Eq Associativity-deriving instance Eq Fixity--deriving instance Ord Arity-deriving instance Ord Associativity-deriving instance Ord Fixity

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-}@@ -38,6 +39,8 @@         , forkOnWithUnmask         , numCapabilities -- :: Int         , getNumCapabilities -- :: IO Int+        , setNumCapabilities -- :: Int -> IO ()+        , getNumProcessors   -- :: IO Int         , numSparks       -- :: IO Int         , childHandler  -- :: Exception -> IO ()         , myThreadId    -- :: IO ThreadId

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP            , NoImplicitPrelude            , MagicHash

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP            , NoImplicitPrelude            , BangPatterns@@ -48,6 +49,8 @@         , forkOnWithUnmask         , numCapabilities -- :: Int         , getNumCapabilities -- :: IO Int+        , setNumCapabilities -- :: Int -> IO ()+        , getNumProcessors   -- :: IO Int         , numSparks      -- :: IO Int         , childHandler  -- :: Exception -> IO ()         , myThreadId    -- :: IO ThreadId@@ -186,13 +189,13 @@ The new thread will be a lightweight thread; if you want to use a foreign library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead. -GHC note: the new thread inherits the /masked/ state of the parent +GHC note: the new thread inherits the /masked/ state of the parent (see 'Control.Exception.mask').  The newly created thread has an exception handler that discards the exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and 'ThreadKilled', and passes all other exceptions to the uncaught-exception handler (see 'setUncaughtExceptionHandler').+exception handler. -} forkIO :: IO () -> IO ThreadId forkIO action = IO $ \ s ->@@ -269,7 +272,7 @@ -- Haskell threads that can run truly simultaneously at any given -- time, and is typically set to the number of physical processor cores on -- the machine.--- +-- -- Strictly speaking it is better to use 'getNumCapabilities', because -- the number of capabilities might vary at runtime. --@@ -299,6 +302,27 @@    n <- peek n_capabilities    return (fromIntegral n) +{- |+Set the number of Haskell threads that can run truly simultaneously+(on separate physical processors) at any given time.++GHC notes: in the current implementation, the value may only be+/increased/, not decreased, by calling 'setNumCapabilities'.  The+initial value is given by the @+RTS -N@ flag, and the current value+may be obtained using 'getNumCapabilities'.+-}+setNumCapabilities :: Int -> IO ()+setNumCapabilities i = c_setNumCapabilities (fromIntegral i)++foreign import ccall safe "setNumCapabilities"+  c_setNumCapabilities :: CUInt -> IO ()++getNumProcessors :: IO Int+getNumProcessors = fmap fromIntegral c_getNumberOfProcessors++foreign import ccall unsafe "getNumberOfProcessors"+  c_getNumberOfProcessors :: IO CUInt+ -- | Returns the number of sparks currently in the local spark pool numSparks :: IO Int numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)@@ -654,7 +678,7 @@ -- False or raising an exception are both treated as invariant failures. always :: STM Bool -> STM () always i = alwaysSucceeds ( do v <- i-                               if (v) then return () else ( error "Transacional invariant violation" ) )+                               if (v) then return () else ( error "Transactional invariant violation" ) )  -- |Shared memory locations that support atomic memory transactions. data TVar a = TVar (TVar# RealWorld a)

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, ForeignFunctionInterface,              DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}@@ -277,7 +278,7 @@                     return ()      Nothing -> return () -toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent+toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent toWin32ConsoleEvent ev =    case ev of        0 {- CTRL_C_EVENT-}        -> Just ControlC@@ -323,3 +324,4 @@  foreign import stdcall "WaitForSingleObject"    c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD+

@@ -29,6 +29,13 @@  {- #include "rts/Signals.h"++Note: this #include is inside a Haskell comment+      but it brings into scope some #defines+      that are used by CPP below (eg STG_SIG_DFL).+      Having it in a comment means that there's no+      danger that C-like crap will be misunderstood+      by GHC -}  import Foreign@@ -40,11 +47,6 @@ import GHC.Conc import Control.Concurrent.MVar import Data.Typeable--#ifdef mingw32_HOST_OS-import Data.Maybe-import GHC.Base-#endif  data Handler  = Default

@@ -9,3 +9,4 @@ #include "../../../compiler/stage1/ghc_boot_platform.h"  #include "../../../includes/HaskellConstants.hs"+

@@ -41,3 +41,4 @@  toAnnotationWrapper :: (Data a) => a -> AnnotationWrapper toAnnotationWrapper what = AnnotationWrapper what+

@@ -2,6 +2,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, BangPatterns, MagicHash #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.Enum@@ -20,12 +21,16 @@ module GHC.Enum(         Bounded(..), Enum(..),         boundedEnumFrom, boundedEnumFromThen,+        toEnumError, fromEnumError, succError, predError,          -- Instances for Bounded and Enum: (), Char, Int     ) where  import GHC.Base+import GHC.Integer+import GHC.Num+import GHC.Show import Data.Tuple       ()              -- for dependencies default ()              -- Double isn't available yet \end{code}@@ -121,7 +126,39 @@     i_n2 = fromEnum n2 \end{code} +\begin{code}+------------------------------------------------------------------------+-- Helper functions+------------------------------------------------------------------------ +{-# NOINLINE toEnumError #-}+toEnumError :: (Show a) => String -> Int -> (a,a) -> b+toEnumError inst_ty i bnds =+    error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" +++            show i +++            ") is outside of bounds " +++            show bnds++{-# NOINLINE fromEnumError #-}+fromEnumError :: (Show a) => String -> a -> b+fromEnumError inst_ty x =+    error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" +++            show x +++            ") is outside of Int's bounds " +++            show (minBound::Int, maxBound::Int)++{-# NOINLINE succError #-}+succError :: String -> a+succError inst_ty =+    error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"++{-# NOINLINE predError #-}+predError :: String -> a+predError inst_ty =+    error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"+\end{code}++ %********************************************************* %*                                                      * \subsection{Tuples}@@ -583,5 +620,80 @@                    go_dn x | x <# y'   = I# x `c` n                            | otherwise = I# x `c` go_dn (x +# delta)                in I# x1 `c` go_dn x2+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instance for @Enum@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Enum Integer  where+    succ x               = x + 1+    pred x               = x - 1+    toEnum (I# n)        = smallInteger n+    fromEnum n           = I# (integerToInt n)++    {-# INLINE enumFrom #-}+    {-# INLINE enumFromThen #-}+    {-# INLINE enumFromTo #-}+    {-# INLINE enumFromThenTo #-}+    enumFrom x             = enumDeltaInteger  x 1+    enumFromThen x y       = enumDeltaInteger  x (y-x)+    enumFromTo x lim       = enumDeltaToInteger x 1     lim+    enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim++{-# RULES+"enumDeltaInteger"      [~1] forall x y.  enumDeltaInteger x y     = build (\c _ -> enumDeltaIntegerFB c x y)+"efdtInteger"           [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)+"enumDeltaInteger"      [1] enumDeltaIntegerFB   (:)    = enumDeltaInteger+"enumDeltaToInteger"    [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger+ #-}++enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b+enumDeltaIntegerFB c x d = x `seq` (x `c` enumDeltaIntegerFB c (x+d) d)++enumDeltaInteger :: Integer -> Integer -> [Integer]+enumDeltaInteger x d = x `seq` (x : enumDeltaInteger (x+d) d)+-- strict accumulator, so+--     head (drop 1000000 [1 .. ]+-- works++{-# NOINLINE [0] enumDeltaToIntegerFB #-}+-- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire+enumDeltaToIntegerFB :: (Integer -> a -> a) -> a+                     -> Integer -> Integer -> Integer -> a+enumDeltaToIntegerFB c n x delta lim+  | delta >= 0 = up_fb c n x delta lim+  | otherwise  = dn_fb c n x delta lim++enumDeltaToInteger :: Integer -> Integer -> Integer -> [Integer]+enumDeltaToInteger x delta lim+  | delta >= 0 = up_list x delta lim+  | otherwise  = dn_list x delta lim++up_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a+up_fb c n x0 delta lim = go (x0 :: Integer)+                      where+                        go x | x > lim   = n+                             | otherwise = x `c` go (x+delta)+dn_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a+dn_fb c n x0 delta lim = go (x0 :: Integer)+                      where+                        go x | x < lim   = n+                             | otherwise = x `c` go (x+delta)++up_list :: Integer -> Integer -> Integer -> [Integer]+up_list x0 delta lim = go (x0 :: Integer)+                    where+                        go x | x > lim   = []+                             | otherwise = x : go (x+delta)+dn_list :: Integer -> Integer -> Integer -> [Integer]+dn_list x0 delta lim = go (x0 :: Integer)+                    where+                        go x | x < lim   = []+                             | otherwise = x : go (x+delta) \end{code} 

@@ -45,7 +45,8 @@    getFullProgArgv p_argc p_argv    p    <- fromIntegral `liftM` peek p_argc    argv <- peek p_argv-   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding)+   enc <- getFileSystemEncoding+   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)  foreign import ccall unsafe "getFullProgArgv"     getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()

@@ -1,8 +1,13 @@ {-# LANGUAGE Trustworthy #-}++-- ---------------------------------------------------------------------------- -- | This module provides scalable event notification for file -- descriptors and timeouts. -- -- This module should be considered GHC internal.+--+-- ----------------------------------------------------------------------------+ module GHC.Event     ( -- * Types       EventManager@@ -40,3 +45,4 @@  import GHC.Event.Manager import GHC.Event.Thread (getSystemEventManager)+

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, NoImplicitPrelude #-}  module GHC.Event.Array@@ -27,7 +28,7 @@ import Data.Bits ((.|.), shiftR) import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef, writeIORef) import Data.Maybe-import Foreign.C.Types (CSize)+import Foreign.C.Types (CSize(..)) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Foreign.Storable (Storable(..))@@ -311,3 +312,4 @@  foreign import ccall unsafe "string.h memmove"     memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)+

@@ -1,4 +1,5 @@-{-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface, CApiFFI #-}  module GHC.Event.Clock (getCurrentTime) where @@ -6,7 +7,7 @@  import Foreign (Ptr, Storable(..), nullPtr, with) import Foreign.C.Error (throwErrnoIfMinus1_)-import Foreign.C.Types (CInt, CLong, CTime, CSUSeconds)+import Foreign.C.Types import GHC.Base import GHC.Err import GHC.Num@@ -44,5 +45,6 @@         #{poke struct timeval, tv_sec} ptr (sec tv)         #{poke struct timeval, tv_usec} ptr (usec tv) -foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday+foreign import capi unsafe "HsBase.h gettimeofday" gettimeofday     :: Ptr CTimeval -> Ptr () -> IO CInt+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP            , ForeignFunctionInterface            , NoImplicitPrelude@@ -35,7 +36,7 @@ import GHC.Show (Show) import GHC.Word (Word8) import Foreign.C.Error (throwErrnoIfMinus1_)-import Foreign.C.Types (CInt, CSize)+import Foreign.C.Types (CInt(..), CSize(..)) import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) import Foreign.Marshal (alloca, allocaBytes) import Foreign.Marshal.Array (allocaArray)@@ -212,3 +213,4 @@  foreign import ccall "setIOManagerWakeupFd"    c_setIOManagerWakeupFd :: CInt -> IO ()+

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP            , ForeignFunctionInterface            , GeneralizedNewtypeDeriving@@ -5,8 +6,9 @@            , BangPatterns   #-} ------ | A binding to the epoll I/O event notification facility+-----------------------------------------------------------------------------+-- |+-- A binding to the epoll I/O event notification facility -- -- epoll is a variant of poll that can be used either as an edge-triggered or -- a level-triggered interface and scales well to large numbers of watched file@@ -14,6 +16,8 @@ -- -- epoll decouples monitor an fd from the process of registering it. --+-----------------------------------------------------------------------------+ module GHC.Event.EPoll     (       new@@ -41,7 +45,7 @@ import Data.Monoid (Monoid(..)) import Data.Word (Word32) import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_)-import Foreign.C.Types (CInt)+import Foreign.C.Types (CInt(..)) import Foreign.Marshal.Utils (with) import Foreign.Ptr (Ptr) import Foreign.Storable (Storable(..))@@ -204,3 +208,4 @@     c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt  #endif /* defined(HAVE_EPOLL) */+

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-}  -----------------------------------------------------------------------------@@ -38,6 +39,7 @@ -- This means that the operation can become linear in the number of -- elements with a maximum of /W/ -- the number of bits in an 'Int' -- (32 or 64).+-- -----------------------------------------------------------------------------  module GHC.Event.IntMap@@ -373,3 +375,4 @@         x4 -> case (x4 .|. shiftRL x4 16) of          x5 -> case (x5 .|. shiftRL x5 32) of   -- for 64 bit platforms           x6 -> (x6 `xor` (shiftRL x6 1))+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}  module GHC.Event.Internal@@ -129,7 +130,7 @@ -- 'getErrno' is not 'eINTR'.  If the result value is -1 and -- 'getErrno' returns 'eINTR' 0 is returned.  Otherwise the result -- value is returned.-throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a throwErrnoIfMinus1NoRetry loc f = do     res <- f     if res == -1

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP            , ForeignFunctionInterface            , GeneralizedNewtypeDeriving@@ -31,7 +32,7 @@ import Data.Bits (Bits(..)) import Data.Word (Word16, Word32) import Foreign.C.Error (throwErrnoIfMinus1)-import Foreign.C.Types (CInt, CLong, CTime)+import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (Storable(..))@@ -49,9 +50,6 @@ #if defined(HAVE_KEVENT64) import Data.Int (Int64) import Data.Word (Word64)-import Foreign.C.Types (CUInt)-#else-import Foreign.C.Types (CIntPtr, CUIntPtr) #endif  #include <sys/types.h>@@ -301,3 +299,4 @@ #endif  #endif /* defined(HAVE_KQUEUE) */+

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns            , CPP            , ExistentialQuantification

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, NoImplicitPrelude #-}  -- Copyright (c) 2008, Ralf Hinze@@ -481,3 +482,4 @@  instance Show a => Show (Sequ a) where     showsPrec d a = showsPrec d (seqToList a)+

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP            , ForeignFunctionInterface            , GeneralizedNewtypeDeriving@@ -30,7 +31,7 @@ import Data.Bits (Bits, (.|.), (.&.)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..))-import Foreign.C.Types (CInt, CShort, CULong)+import Foreign.C.Types (CInt(..), CShort(..), CULong(..)) import Foreign.Ptr (Ptr) import Foreign.Storable (Storable(..)) import GHC.Base

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}  module GHC.Event.Thread

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, NoImplicitPrelude #-} module GHC.Event.Unique     (@@ -38,3 +39,4 @@   writeTVar ref u'   return $ Unique u' {-# INLINE newUnique #-}+

@@ -6,6 +6,7 @@            , DeriveDataTypeable   #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.Exception

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-}  -----------------------------------------------------------------------------@@ -49,8 +50,13 @@         traceEvent,          -- * SpecConstr annotations-        SpecConstrAnnotation(..)+        SpecConstrAnnotation(..), +        -- * The call stack+        currentCallStack,++        -- * The Constraint kind+        Constraint        ) where  import Prelude@@ -61,10 +67,11 @@ import GHC.Word import GHC.Int import GHC.Ptr+import GHC.Stack import Data.String import Data.List-import Foreign.C import Data.Data+import qualified Debug.Trace  -- XXX This should really be in Data.Tuple, where the definitions are maxTupleSize :: Int@@ -112,10 +119,8 @@ -- tracing  traceEvent :: String -> IO ()-traceEvent msg = do-  withCString msg $ \(Ptr p) -> IO $ \s ->-    case traceEvent# p s of s' -> (# s', () #)-+traceEvent = Debug.Trace.traceEventIO+{-# DEPRECATED traceEvent "Use Debug.Trace.traceEvent or Debug.Trace.traceEventIO" #-}   {- **********************************************************************

@@ -1,8 +1,10 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude            , BangPatterns            , ForeignFunctionInterface            , EmptyDataDecls   #-}+ -- ---------------------------------------------------------------------------- --  --  (c) The University of Glasgow 2006@@ -73,3 +75,4 @@    c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO () foreign import ccall unsafe "MD5Final"    c_MD5Final  :: Ptr Word8 -> Ptr MD5Context -> IO ()+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude #-} module GHC.Fingerprint (         fingerprintString,

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -- ---------------------------------------------------------------------------- -- @@ -17,3 +18,4 @@  data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64   deriving (Eq, Ord)+

@@ -102,15 +102,33 @@     -- appropriately scaled exponent (an 'Int').  If @'decodeFloat' x@     -- yields @(m,n)@, then @x@ is equal in value to @m*b^^n@, where @b@     -- is the floating-point radix, and furthermore, either @m@ and @n@-    -- are both zero or else @b^(d-1) <= m < b^d@, where @d@ is the value-    -- of @'floatDigits' x@.  In particular, @'decodeFloat' 0 = (0,0)@.+    -- are both zero or else @b^(d-1) <= 'abs' m < b^d@, where @d@ is+    -- the value of @'floatDigits' x@.+    -- In particular, @'decodeFloat' 0 = (0,0)@. If the type+    -- contains a negative zero, also @'decodeFloat' (-0.0) = (0,0)@.+    -- /The result of/ @'decodeFloat' x@ /is unspecified if either of/+    -- @'isNaN' x@ /or/ @'isInfinite' x@ /is/ 'True'.     decodeFloat         :: a -> (Integer,Int)-    -- | 'encodeFloat' performs the inverse of 'decodeFloat'+    -- | 'encodeFloat' performs the inverse of 'decodeFloat' in the+    -- sense that for finite @x@ with the exception of @-0.0@,+    -- @'uncurry' 'encodeFloat' ('decodeFloat' x) = x@.+    -- @'encodeFloat' m n@ is one of the two closest representable+    -- floating-point numbers to @m*b^^n@ (or @&#177;Infinity@ if overflow+    -- occurs); usually the closer, but if @m@ contains too many bits,+    -- the result may be rounded in the wrong direction.     encodeFloat         :: Integer -> Int -> a-    -- | the second component of 'decodeFloat'.+    -- | 'exponent' corresponds to the second component of 'decodeFloat'.+    -- @'exponent' 0 = 0@ and for finite nonzero @x@,+    -- @'exponent' x = snd ('decodeFloat' x) + 'floatDigits' x@.+    -- If @x@ is a finite floating-point number, it is equal in value to+    -- @'significand' x * b ^^ 'exponent' x@, where @b@ is the+    -- floating-point radix.+    -- The behaviour is unspecified on infinite or @NaN@ values.     exponent            :: a -> Int-    -- | the first component of 'decodeFloat', scaled to lie in the open-    -- interval (@-1@,@1@)+    -- | The first component of 'decodeFloat', scaled to lie in the open+    -- interval (@-1@,@1@), either @0.0@ or of absolute value @>= 1\/b@,+    -- where @b@ is the floating-point radix.+    -- The behaviour is unspecified on infinite or @NaN@ values.     significand         :: a -> a     -- | multiplies a floating-point number by an integer power of the radix     scaleFloat          :: Int -> a -> a@@ -143,7 +161,10 @@     significand x       =  encodeFloat m (negate (floatDigits x))                            where (m,_) = decodeFloat x -    scaleFloat k x      =  encodeFloat m (n + clamp b k)+    scaleFloat 0 x      =  x+    scaleFloat k x+      | isFix           =  x+      | otherwise       =  encodeFloat m (n + clamp b k)                            where (m,n) = decodeFloat x                                  (l,h) = floatRange x                                  d     = floatDigits x@@ -156,6 +177,7 @@                                  -- for smaller than l - d.                                  -- Add a little extra to keep clear                                  -- from the boundary cases.+                                 isFix = x == 0 || isNaN x || isInfinite x      atan2 y x       | x > 0            =  atan (y/x)@@ -313,9 +335,13 @@     significand x       = case decodeFloat x of                             (m,_) -> encodeFloat m (negate (floatDigits x)) -    scaleFloat k x      = case decodeFloat x of+    scaleFloat 0 x      = x+    scaleFloat k x+      | isFix           = x+      | otherwise       = case decodeFloat x of                             (m,n) -> encodeFloat m (n + clamp bf k)                         where bf = FLT_MAX_EXP - (FLT_MIN_EXP) + 4*FLT_MANT_DIG+                              isFix = x == 0 || isFloatFinite x == 0      isNaN x          = 0 /= isFloatNaN x     isInfinite x     = 0 /= isFloatInfinite x@@ -354,12 +380,12 @@     toRational (D# x#)  =         case decodeDoubleInteger x# of           (# m, e# #)-            | e# >=# 0#                                         ->+            | e# >=# 0#                                     ->                 shiftLInteger m e# :% 1-            | (int2Word# (integerToInt m) `and#` 1##) `eqWord#` 0##   ->+            | (integerToWord m `and#` 1##) `eqWord#` 0##    ->                 case elimZerosInteger m (negateInt# e#) of                     (# n, d# #) ->  n :% shiftLInteger 1 d#-            | otherwise                                         ->+            | otherwise                                     ->                 m :% shiftLInteger 1 (negateInt# e#)  instance  Fractional Double  where@@ -464,9 +490,13 @@     significand x       = case decodeFloat x of                             (m,_) -> encodeFloat m (negate (floatDigits x)) -    scaleFloat k x      = case decodeFloat x of+    scaleFloat 0 x      = x+    scaleFloat k x+      | isFix           = x+      | otherwise       = case decodeFloat x of                             (m,n) -> encodeFloat m (n + clamp bd k)                         where bd = DBL_MAX_EXP - (DBL_MIN_EXP) + 4*DBL_MANT_DIG+                              isFix = x == 0 || isDoubleFinite x == 0      isNaN x             = 0 /= isDoubleNaN x     isInfinite x        = 0 /= isDoubleInfinite x@@ -819,21 +849,17 @@         p = floatDigits r         (minExp0, _) = floatRange r         minExp = minExp0 - p            -- the real minimum exponent-        xMin   = toRational (expt b (p-1))         xMax   = toRational (expt b p)         p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp-        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1-        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)+        -- if x = n/d and ln = integerLogBase b n, ld = integerLogBase b d,+        -- then b^(ln-ld-1) < x < b^(ln-ld+1)+        f = if p0 < 0 then 1 :% expt b (-p0) else expt b p0 :% 1+        x0 = x / f+        -- if ln - ld >= minExp0, then b^(p-1) < x0 < b^(p+1), so there's at most+        -- one scaling step needed, otherwise, x0 < b^p and no scaling is needed+        (x', p') = if x0 >= xMax then (x0 / toRational b, p0+1) else (x0, p0)         r = encodeFloat (round x') p' --- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.-scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)-scaleRat b minExp xMin xMax p x- | p <= minExp = (x, p)- | x >= xMax   = scaleRat b minExp xMin xMax (p+1) (x/b)- | x < xMin    = scaleRat b minExp xMin xMax (p-1) (x*b)- | otherwise   = (x, p)- -- Exponentiation with a cache for the most common numbers. minExpt, maxExpt :: Int minExpt = 0@@ -882,22 +908,24 @@ of division.  The below is an adaption of fromRat' for the conversion to-Float or Double exploiting the know floatRadix and avoiding+Float or Double exploiting the known floatRadix and avoiding divisions as much as possible.  \begin{code} {-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float,                             Int -> Int -> Integer -> Integer -> Double #-} fromRat'' :: RealFloat a => Int -> Int -> Integer -> Integer -> a+-- Invariant: n and d strictly positive fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d =     case integerLog2IsPowerOf2# d of       (# ld#, pw# #)         | pw# ==# 0# ->           case integerLog2# n of-            ln# | ln# ># (ld# +# me#) ->+            ln# | ln# >=# (ld# +# me# -# 1#) ->+                  -- this means n/d >= 2^(minEx-1), i.e. we are guaranteed to get+                  -- a normalised number, round to mantDigs bits                   if ln# <# md#-                    then encodeFloat (n `shiftL` (I# (md# -# 1# -# ln#)))-                                        (I# (ln# +# 1# -# ld# -# md#))+                    then encodeFloat n (I# (negateInt# ld#))                     else let n'  = n `shiftR` (I# (ln# +# 1# -# md#))                              n'' = case roundingMode# n (ln# -# md#) of                                     0# -> n'@@ -907,15 +935,13 @@                                             _ -> n' + 1                          in encodeFloat n'' (I# (ln# -# ld# +# 1# -# md#))                 | otherwise ->+                  -- n/d < 2^(minEx-1), a denorm or rounded to 2^(minEx-1)+                  -- the exponent for encoding is always minEx-mantDigs+                  -- so we must shift right by (minEx-mantDigs) - (-ld)                   case ld# +# (me# -# md#) of-                    ld'# | ld'# ># (ln# +# 1#)  -> encodeFloat 0 0-                         | ld'# ==# (ln# +# 1#) ->-                           case integerLog2IsPowerOf2# n of-                            (# _, 0# #) -> encodeFloat 0 0-                            (# _, _ #)  -> encodeFloat 1 (minEx - mantDigs)-                         | ld'# <=# 0#  ->+                    ld'# | ld'# <=# 0#  -> -- we would shift left, so we don't shift                            encodeFloat n (I# ((me# -# md#) -# ld'#))-                         | otherwise    ->+                         | ld'# <=# ln#  ->                            let n' = n `shiftR` (I# ld'#)                            in case roundingMode# n (ld'# -# 1#) of                                 0# -> encodeFloat n' (minEx - mantDigs)@@ -923,20 +949,28 @@                                         then encodeFloat n' (minEx-mantDigs)                                         else encodeFloat (n' + 1) (minEx-mantDigs)                                 _  -> encodeFloat (n' + 1) (minEx-mantDigs)+                         | ld'# ># (ln# +# 1#)  -> encodeFloat 0 0 -- result of shift < 0.5+                         | otherwise ->  -- first bit of n shifted to 0.5 place+                           case integerLog2IsPowerOf2# n of+                            (# _, 0# #) -> encodeFloat 0 0  -- round to even+                            (# _, _ #)  -> encodeFloat 1 (minEx - mantDigs)         | otherwise ->           let ln = I# (integerLog2# n)               ld = I# ld#+              -- 2^(ln-ld-1) < n/d < 2^(ln-ld+1)               p0 = max minEx (ln - ld)               (n', d')                 | p0 < mantDigs = (n `shiftL` (mantDigs - p0), d)                 | p0 == mantDigs = (n, d)                 | otherwise     = (n, d `shiftL` (p0 - mantDigs))+              -- if ln-ld < minEx, then n'/d' < 2^mantDigs, else+              -- 2^(mantDigs-1) < n'/d' < 2^(mantDigs+1) and we+              -- may need one scaling step               scale p a b-                | p <= minEx-mantDigs = (p,a,b)-                | a < (b `shiftL` (mantDigs-1)) = (p-1, a `shiftL` 1, b)                 | (b `shiftL` mantDigs) <= a = (p+1, a, b `shiftL` 1)                 | otherwise = (p, a, b)               (p', n'', d'') = scale (p0-mantDigs) n' d'+              -- n''/d'' < 2^mantDigs and p' == minEx-mantDigs or n''/d'' >= 2^(mantDigs-1)               rdq = case n'' `quotRem` d'' of                      (q,r) -> case compare (r `shiftL` 1) d'' of                                 LT -> q@@ -1046,12 +1080,13 @@ foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int-+foreign import ccall unsafe "isFloatFinite" isFloatFinite :: Float -> Int  foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int+foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int \end{code}  %*********************************************************

@@ -2,6 +2,7 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-} {-# OPTIONS_GHC -O2 #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.Float.ConversionUtils@@ -95,3 +96,4 @@                                 (# _, ba #) -> ba     in case mkArr realWorld# of         b -> BA b+

@@ -2,6 +2,7 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, ForeignFunctionInterface,     NoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.Float.RealFracMethods@@ -340,3 +341,4 @@  foreign import ccall unsafe "rintFloat"     c_rintFloat :: Float -> Float+

@@ -63,7 +63,6 @@ import GHC.IO import GHC.IO.Exception import GHC.IO.Buffer-import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter) import GHC.IO.Encoding.Types  @@ -173,7 +172,7 @@             if isEmptyBuffer from'              then               -- No input remaining: @why@ will be InputUnderflow, but we don't care-              fmap (map desurrogatifyRoundtripCharacter) $ withBuffer to' $ peekArray (bufferElems to')+              withBuffer to' $ peekArray (bufferElems to')              else do               -- Input remaining: what went wrong?               putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why)@@ -183,7 +182,7 @@               putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'')               putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'')               to_chars <- withBuffer to'' $ peekArray (bufferElems to'')-              fmap (map desurrogatifyRoundtripCharacter to_chars++) $ go (iteration + 1) from''+              fmap (to_chars++) $ go (iteration + 1) from''        go (0 :: Int) from0 @@ -194,7 +193,7 @@                    -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory                    -> IO a withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act-  = bracket mk_encoder close $ \encoder -> withArrayLen (map surrogatifyRoundtripCharacter s) $ \sz p -> do+  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do       from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p        let go iteration to_sz_bytes = do@@ -214,7 +213,7 @@                   -> String        -- ^ String to encode                   -> IO CStringLen newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s-  = bracket mk_encoder close $ \encoder -> withArrayLen (map surrogatifyRoundtripCharacter s) $ \sz p -> do+  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do       from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p        let go iteration to_p to_sz_bytes = do@@ -255,3 +254,4 @@               InputUnderflow  -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad               InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid               OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP            , NoImplicitPrelude            , BangPatterns

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.Handle@@ -15,7 +16,6 @@ -----------------------------------------------------------------------------  -- #hide- module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle instead" #-} (   withHandle, withHandle', withHandle_,   wantWritableHandle, wantReadableHandle, wantSeekableHandle,

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude            , BangPatterns            , RankNTypes@@ -6,6 +7,7 @@   #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.IO@@ -381,7 +383,7 @@ -- with exceptions masked, you can be sure that the library call will not be -- able to unmask exceptions again.  If you are writing library code and need -- to use asynchronous exceptions, the only way is to create a new thread;--- see 'Control.Concurrent.forkIOUnmasked'.+-- see 'Control.Concurrent.forkIOWithUnmask'. -- -- Asynchronous exceptions may still be received while in the masked -- state if the masked thread /blocks/ in certain ways; see@@ -470,3 +472,4 @@ -- evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -- NB. see #2273, #5129+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude #-}  module GHC.IO where@@ -5,3 +6,4 @@ import GHC.Types  failIO :: [Char] -> IO a+

@@ -288,3 +288,4 @@ check :: Buffer a -> Bool -> IO () check _   True  = return () check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)+

@@ -124,3 +124,4 @@   res <- withBuffer bbuf $ \ptr ->             IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) bytes   return (res, bufferAdjustL res bbuf)+

@@ -176,3 +176,4 @@   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@                         -- from the end of the file.     deriving (Eq, Ord, Ix, Enum, Read, Show)+

@@ -22,7 +22,9 @@         utf8, utf8_bom,         utf16, utf16le, utf16be,         utf32, utf32le, utf32be, -        localeEncoding, fileSystemEncoding, foreignEncoding,+        initLocaleEncoding,+        getLocaleEncoding, getFileSystemEncoding, getForeignEncoding,+        setLocaleEncoding, setFileSystemEncoding, setForeignEncoding,         char8,         mkTextEncoding,     ) where@@ -32,9 +34,8 @@ import GHC.IO.Buffer import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types-import GHC.Word #if !defined(mingw32_HOST_OS)-import qualified GHC.IO.Encoding.Iconv  as Iconv+import qualified GHC.IO.Encoding.Iconv as Iconv #else import qualified GHC.IO.Encoding.CodePage as CodePage import Text.Read (reads)@@ -43,9 +44,13 @@ import qualified GHC.IO.Encoding.UTF8   as UTF8 import qualified GHC.IO.Encoding.UTF16  as UTF16 import qualified GHC.IO.Encoding.UTF32  as UTF32+import GHC.Word +import Data.IORef+import Data.Char (toUpper) import Data.List import Data.Maybe+import System.IO.Unsafe (unsafePerformIO)  -- ----------------------------------------------------------------------------- @@ -98,7 +103,7 @@ utf32be = UTF32.utf32be  -- | The Unicode encoding of the current locale-localeEncoding :: TextEncoding+getLocaleEncoding :: IO TextEncoding  -- | The Unicode encoding of the current locale, but allowing arbitrary -- undecodable bytes to be round-tripped through it.@@ -109,21 +114,43 @@ -- On Windows, this encoding *should not* be used if possible because -- the use of code pages is deprecated: Strings should be retrieved -- via the "wide" W-family of UTF-16 APIs instead-fileSystemEncoding :: TextEncoding+getFileSystemEncoding :: IO TextEncoding  -- | The Unicode encoding of the current locale, but where undecodable -- bytes are replaced with their closest visual match. Used for -- the 'CString' marshalling functions in "Foreign.C.String"-foreignEncoding :: TextEncoding+getForeignEncoding :: IO TextEncoding +setLocaleEncoding, setFileSystemEncoding, setForeignEncoding :: TextEncoding -> IO ()+(getLocaleEncoding, setLocaleEncoding)         = mkGlobal initLocaleEncoding+(getFileSystemEncoding, setFileSystemEncoding) = mkGlobal initFileSystemEncoding+(getForeignEncoding, setForeignEncoding)       = mkGlobal initForeignEncoding++mkGlobal :: a -> (IO a, a -> IO ())+mkGlobal x = unsafePerformIO $ do+    x_ref <- newIORef x+    return (readIORef x_ref, writeIORef x_ref)++initLocaleEncoding, initFileSystemEncoding, initForeignEncoding :: TextEncoding+ #if !defined(mingw32_HOST_OS)-localeEncoding = Iconv.localeEncoding-fileSystemEncoding = Iconv.mkLocaleEncoding RoundtripFailure-foreignEncoding = Iconv.mkLocaleEncoding IgnoreCodingFailure+-- It is rather important that we don't just call Iconv.mkIconvEncoding here+-- because some iconvs (in particular GNU iconv) will brokenly UTF-8 encode+-- lone surrogates without complaint.+--+-- By going through our Haskell implementations of those encodings, we are+-- guaranteed to catch such errors.+--+-- FIXME: this is not a complete solution because if the locale encoding is one+-- which we don't have a Haskell-side decoder for, iconv might still ignore the+-- lone surrogate in the input.+initLocaleEncoding     = unsafePerformIO $ mkTextEncoding' ErrorOnCodingFailure Iconv.localeEncodingName+initFileSystemEncoding = unsafePerformIO $ mkTextEncoding' RoundtripFailure     Iconv.localeEncodingName+initForeignEncoding    = unsafePerformIO $ mkTextEncoding' IgnoreCodingFailure  Iconv.localeEncodingName #else-localeEncoding = CodePage.localeEncoding-fileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure-foreignEncoding = CodePage.mkLocaleEncoding IgnoreCodingFailure+initLocaleEncoding     = CodePage.localeEncoding+initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure+initForeignEncoding    = CodePage.mkLocaleEncoding IgnoreCodingFailure #endif  -- | An encoding in which Unicode code points are translated to bytes@@ -164,21 +191,8 @@ -- mkTextEncoding :: String -> IO TextEncoding mkTextEncoding e = case mb_coding_failure_mode of-  Nothing -> unknown_encoding-  Just cfm -> case enc of-    "UTF-8"    -> return $ UTF8.mkUTF8 cfm-    "UTF-16"   -> return $ UTF16.mkUTF16 cfm-    "UTF-16LE" -> return $ UTF16.mkUTF16le cfm-    "UTF-16BE" -> return $ UTF16.mkUTF16be cfm-    "UTF-32"   -> return $ UTF32.mkUTF32 cfm-    "UTF-32LE" -> return $ UTF32.mkUTF32le cfm-    "UTF-32BE" -> return $ UTF32.mkUTF32be cfm-#if defined(mingw32_HOST_OS)-    'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp-    _ -> unknown_encoding-#else-    _ -> Iconv.mkIconvEncoding cfm enc-#endif+    Nothing -> unknownEncodingErr e+    Just cfm -> mkTextEncoding' cfm enc   where     -- The only problem with actually documenting //IGNORE and //TRANSLIT as     -- supported suffixes is that they are not necessarily supported with non-GNU iconv@@ -189,10 +203,23 @@         "//TRANSLIT"  -> Just TransliterateCodingFailure         "//ROUNDTRIP" -> Just RoundtripFailure         _             -> Nothing-    -    unknown_encoding = ioException (IOError Nothing NoSuchThing "mkTextEncoding"-                                            ("unknown encoding:" ++ e)  Nothing Nothing) +mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding+mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of+    "UTF8"    -> return $ UTF8.mkUTF8 cfm+    "UTF16"   -> return $ UTF16.mkUTF16 cfm+    "UTF16LE" -> return $ UTF16.mkUTF16le cfm+    "UTF16BE" -> return $ UTF16.mkUTF16be cfm+    "UTF32"   -> return $ UTF32.mkUTF32 cfm+    "UTF32LE" -> return $ UTF32.mkUTF32le cfm+    "UTF32BE" -> return $ UTF32.mkUTF32be cfm+#if defined(mingw32_HOST_OS)+    'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp+    _ -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm)+#else+    _ -> Iconv.mkIconvEncoding cfm enc+#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 --latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode@@ -200,3 +227,7 @@ latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer) latin1_decode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_decode input output --latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode++unknownEncodingErr :: String -> IO a    +unknownEncodingErr e = ioException (IOError Nothing NoSuchThing "mkTextEncoding"+                                            ("unknown encoding:" ++ e)  Nothing Nothing)

@@ -1,7 +1,10 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-}+ module GHC.IO.Encoding where +import GHC.IO (IO) import GHC.IO.Encoding.Types -localeEncoding, fileSystemEncoding, foreignEncoding :: TextEncoding+getLocaleEncoding, getFileSystemEncoding, getForeignEncoding :: IO TextEncoding+

@@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, BangPatterns, ForeignFunctionInterface, NoImplicitPrelude,              NondecreasingIndentation, MagicHash #-}+ module GHC.IO.Encoding.CodePage( #if !defined(mingw32_HOST_OS)  ) where@@ -168,3 +169,4 @@ indexChar (ConvArray p) (I# i) = C# (chr# (indexInt16OffAddr# p i))  #endif+

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, PatternGuards #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.IO.Encoding.Failure@@ -17,7 +18,6 @@ module GHC.IO.Encoding.Failure (     CodingFailureMode(..), codingFailureModeSuffix,     isSurrogate,-    surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter,     recoverDecode, recoverEncode   ) where @@ -35,33 +35,62 @@  import Data.Maybe --- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and specifies--- how they handle illegal sequences.-data CodingFailureMode = ErrorOnCodingFailure         -- ^ Throw an error when an illegal sequence is encountered-                       | IgnoreCodingFailure          -- ^ Attempt to ignore and recover if an illegal sequence is encountered-                       | TransliterateCodingFailure   -- ^ Replace with the closest visual match upon an illegal sequence-                       | RoundtripFailure             -- ^ Use the private-use escape mechanism to attempt to allow illegal sequences to be roundtripped.-                       deriving (Show)                -- This will only work properly for those encodings which are strict supersets of ASCII in the sense-                                                      -- that valid ASCII data is also valid in that encoding. This is not true for e.g. UTF-16, because-                                                      -- ASCII characters must be padded to two bytes to retain their meaning. +-- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and+-- specifies how they handle illegal sequences.+data CodingFailureMode+  = ErrorOnCodingFailure+       -- ^ Throw an error when an illegal sequence is encountered+  | IgnoreCodingFailure+       -- ^ Attempt to ignore and recover if an illegal sequence is+       -- encountered+  | TransliterateCodingFailure+       -- ^ Replace with the closest visual match upon an illegal+       -- sequence+  | RoundtripFailure+       -- ^ Use the private-use escape mechanism to attempt to allow+       -- illegal sequences to be roundtripped.+  deriving (Show)+       -- This will only work properly for those encodings which are+       -- strict supersets of ASCII in the sense that valid ASCII data+       -- is also valid in that encoding. This is not true for+       -- e.g. UTF-16, because ASCII characters must be padded to two+       -- bytes to retain their meaning.+ -- Note [Roundtripping] -- ~~~~~~~~~~~~~~~~~~~~ ----- Roundtripping is based on the ideas of PEP383. However, unlike PEP383 we do not wish to use lone surrogate codepoints--- to escape undecodable bytes, because that may confuse Unicode processing software written in Haskell. Instead, we use--- the range of private-use characters from 0xEF80 to 0xEFFF designated for "encoding hacks" by the ConScript Unicode Registery.+-- Roundtripping is based on the ideas of PEP383. ----- This introduces a technical problem when it comes to encoding back to bytes using iconv. The iconv code will not fail when--- it tries to encode a private-use character (as it would if trying to encode a surrogate), which means that we won't get a--- chance to replace it with the byte we originally escaped.+-- We used to use the range of private-use characters from 0xEF80 to+-- 0xEFFF designated for "encoding hacks" by the ConScript Unicode Registery+-- to encode these characters. ----- To work around this, when filling the buffer to be encoded (in writeBlocks/withEncodedCString/newEncodedCString), we replace--- the private-use characters with lone surrogates again! Likewise, when reading from a buffer (unpack/unpack_nl/peekEncodedCString)--- we have to do the inverse process.+-- However, people didn't like this because it means we don't get+-- guaranteed roundtripping for byte sequences that look like a UTF-8+-- encoded codepoint 0xEFxx. ----- The user of String should never see these lone surrogates, but it ensures that iconv will throw an error when encountering them.--- We use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose.+-- So now like PEP383 we use lone surrogate codepoints 0xDCxx to escape+-- undecodable bytes, even though that may confuse Unicode processing+-- software written in Haskell. This guarantees roundtripping because+-- unicode input that includes lone surrogate codepoints is invalid by+-- definition.+--+-- When we used private-use characters there was a technical problem when it+-- came to encoding back to bytes using iconv. The iconv code will not fail when+-- it tries to encode a private-use character (as it would if trying to encode+-- a surrogate), which means that we won't get a chance to replace it+-- with the byte we originally escaped.+--+-- To work around this, when filling the buffer to be encoded (in+-- writeBlocks/withEncodedCString/newEncodedCString), we replaced the+-- private-use characters with lone surrogates again! Likewise, when+-- reading from a buffer (unpack/unpack_nl/peekEncodedCString) we have+-- to do the inverse process.+--+-- The user of String would never see these lone surrogates, but it+-- ensures that iconv will throw an error when encountering them.  We+-- use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose.  codingFailureModeSuffix :: CodingFailureMode -> String codingFailureModeSuffix ErrorOnCodingFailure       = ""@@ -69,56 +98,53 @@ codingFailureModeSuffix TransliterateCodingFailure = "//TRANSLIT" codingFailureModeSuffix RoundtripFailure           = "//ROUNDTRIP" --- | In transliterate mode, we use this character when decoding unknown bytes.+-- | In transliterate mode, we use this character when decoding+-- unknown bytes. ----- This is the defined Unicode replacement character: <http://www.fileformat.info/info/unicode/char/0fffd/index.htm>+-- This is the defined Unicode replacement character:+-- <http://www.fileformat.info/info/unicode/char/0fffd/index.htm> unrepresentableChar :: Char unrepresentableChar = '\xFFFD' --- | Some characters are actually "surrogate" codepoints defined for use in UTF-16. We need to signal an--- invalid character if we detect them when encoding a sequence of 'Char's into 'Word8's because they won't--- give valid Unicode.+-- It is extraordinarily important that this series of+-- predicates/transformers gets inlined, because they tend to be used+-- in inner loops related to text encoding. In particular,+-- surrogatifyRoundtripCharacter must be inlined (see #5536)++-- | Some characters are actually "surrogate" codepoints defined for+-- use in UTF-16. We need to signal an invalid character if we detect+-- them when encoding a sequence of 'Char's into 'Word8's because they+-- won't give valid Unicode. ----- We may also need to signal an invalid character if we detect them when encoding a sequence of 'Char's into 'Word8's--- because the 'RoundtripFailure' mode creates these to round-trip bytes through our internal UTF-16 encoding.+-- We may also need to signal an invalid character if we detect them+-- when encoding a sequence of 'Char's into 'Word8's because the+-- 'RoundtripFailure' mode creates these to round-trip bytes through+-- our internal UTF-16 encoding.+{-# INLINE isSurrogate #-} isSurrogate :: Char -> Bool-isSurrogate c = (0xD800 <= x && x <= 0xDBFF) || (0xDC00 <= x && x <= 0xDFFF)-  where x = ord c---- | We use some private-use characters for roundtripping unknown bytes through a String-isRoundtripEscapeChar :: Char -> Bool-isRoundtripEscapeChar c = 0xEF00 <= x && x < 0xF000-  where x = ord c---- | We use some surrogate characters for roundtripping unknown bytes through a String-isRoundtripEscapeSurrogateChar :: Char -> Bool-isRoundtripEscapeSurrogateChar c = 0xDC00 <= x && x < 0xDD00+isSurrogate c = (0xD800 <= x && x <= 0xDBFF)+             || (0xDC00 <= x && x <= 0xDFFF)   where x = ord c --- Private use characters (in Strings) --> lone surrogates (in Buffer CharBufElem)-surrogatifyRoundtripCharacter :: Char -> Char-surrogatifyRoundtripCharacter c | isRoundtripEscapeChar c = chr (ord c - 0xEF00 + 0xDC00)-                                | otherwise               = c---- Lone surrogates (in Buffer CharBufElem) --> private use characters (in Strings)-desurrogatifyRoundtripCharacter :: Char -> Char-desurrogatifyRoundtripCharacter c | isRoundtripEscapeSurrogateChar c = chr (ord c - 0xDC00 + 0xEF00)-                                  | otherwise                        = c- -- Bytes (in Buffer Word8) --> lone surrogates (in Buffer CharBufElem)+{-# INLINE escapeToRoundtripCharacterSurrogate #-} escapeToRoundtripCharacterSurrogate :: Word8 -> Char escapeToRoundtripCharacterSurrogate b-  | b < 128   = chr (fromIntegral b) -- Disallow 'smuggling' of ASCII bytes. For roundtripping to work, this assumes encoding is ASCII-superset.+  | b < 128   = chr (fromIntegral b)+      -- Disallow 'smuggling' of ASCII bytes. For roundtripping to+      -- work, this assumes encoding is ASCII-superset.   | otherwise = chr (0xDC00 + fromIntegral b)  -- Lone surrogates (in Buffer CharBufElem) --> bytes (in Buffer Word8)+{-# INLINE unescapeRoundtripCharacterSurrogate #-} unescapeRoundtripCharacterSurrogate :: Char -> Maybe Word8 unescapeRoundtripCharacterSurrogate c     | 0xDC80 <= x && x < 0xDD00 = Just (fromIntegral x) -- Discard high byte     | otherwise                 = Nothing   where x = ord c -recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)+recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char+              -> IO (Buffer Word8, Buffer Char) recoverDecode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }                   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow } = do  --puts $ "recoverDecode " ++ show ir@@ -133,7 +159,8 @@       ow' <- writeCharBuf oraw ow (escapeToRoundtripCharacterSurrogate b)       return (input { bufL=ir+1 }, output { bufR=ow' }) -recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)+recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8+              -> IO (Buffer Char, Buffer Word8) recoverEncode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }                   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow } = do   (c,ir') <- readCharBuf iraw ir@@ -144,18 +171,20 @@         if c == '?'          then return (input { bufL=ir' }, output)          else do-          -- XXX: evil hack! To implement transliteration, we just poke an-          -- ASCII ? into the input buffer and tell the caller to try and decode-          -- again. This is *probably* safe given current uses of TextEncoding.+          -- XXX: evil hack! To implement transliteration, we just+          -- poke an ASCII ? into the input buffer and tell the caller+          -- to try and decode again. This is *probably* safe given+          -- current uses of TextEncoding.           ---          -- The "if" test above ensures we skip if the encoding fails to deal with-          -- the ?, though this should never happen in practice as all encodings are-          -- in fact capable of reperesenting all ASCII characters.+          -- The "if" test above ensures we skip if the encoding fails+          -- to deal with the ?, though this should never happen in+          -- practice as all encodings are in fact capable of+          -- reperesenting all ASCII characters.           _ir' <- writeCharBuf iraw ir '?'           return (input, output)         -        -- This implementation does not work because e.g. UTF-16 requires 2 bytes to-        -- encode a simple ASCII value+        -- This implementation does not work because e.g. UTF-16+        -- requires 2 bytes to encode a simple ASCII value         --writeWord8Buf oraw ow unrepresentableByte         --return (input { bufL=ir' }, output { bufR=ow+1 })     RoundtripFailure | Just x <- unescapeRoundtripCharacterSurrogate c -> do@@ -172,3 +201,4 @@ ioe_encodingError = ioException     (IOError Nothing InvalidArgument "recoverEncode"         "invalid character" Nothing Nothing)+

@@ -23,7 +23,7 @@ module GHC.IO.Encoding.Iconv ( #if !defined(mingw32_HOST_OS)    iconvEncoding, mkIconvEncoding,-   localeEncoding, mkLocaleEncoding+   localeEncodingName #endif  ) where @@ -65,12 +65,6 @@    cstr <- c_localeEncoding    peekCAString cstr -- Assume charset names are ASCII -localeEncoding :: TextEncoding-localeEncoding = mkLocaleEncoding ErrorOnCodingFailure--mkLocaleEncoding :: CodingFailureMode -> TextEncoding-mkLocaleEncoding cfm = unsafePerformIO $ mkIconvEncoding cfm localeEncodingName- -- We hope iconv_t is a storable type.  It should be, since it has at least the -- value -1, which is a possible return value from iconv_open. type IConv = CLong -- ToDo: (#type iconv_t)@@ -190,3 +184,4 @@               throwErrno "iconvRecoder"  #endif /* !mingw32_HOST_OS */+

@@ -150,3 +150,4 @@            invalid = done InvalidSequence ir ow     in     loop ir0 ow0+

@@ -131,3 +131,4 @@                                       -- to output at least one encoded ASCII character, but the input contains                                       -- an invalid or unrepresentable sequence                     deriving (Eq, Show)+

@@ -355,3 +355,4 @@ validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF &&                   x2 >= 0xDC00 && x2 <= 0xDFFF {-# INLINE validate2 #-}+

@@ -331,3 +331,4 @@ validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)    where x1 = ord c {-# INLINE validate #-}+

@@ -357,3 +357,4 @@                   between x2 0x80 0x8F &&                   between x3 0x80 0xBF &&                   between x4 0x80 0xBF+

@@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, MagicHash #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.IO.Exception@@ -303,9 +304,12 @@          "" -> id          _  -> showString " (" . showString s . showString ")") +-- Note the use of "lazy". This means that+--     assert False (throw e)+-- will throw the assertion failure rather than e. See trac #5561. assertError :: Addr# -> Bool -> a -> a assertError str predicate v-  | predicate = v+  | predicate = lazy v   | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))  unsupportedOperation :: IOError@@ -336,3 +340,4 @@           _         -> (loc, "")         }     not_bar c = c /= '|'+

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-}+ module GHC.IO.Exception where  import GHC.Base@@ -11,3 +12,4 @@ type IOError = IOException userError :: String  -> IOError unsupportedOperation :: IOError+

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP            , NoImplicitPrelude            , BangPatterns@@ -663,3 +664,4 @@ foreign import ccall unsafe "unlockFile"   unlockFile :: CInt -> IO CInt #endif+

@@ -562,8 +562,8 @@          flushCharBuffer h_          closeTextCodecs h_ -         let mb_te | bin       = Nothing-                   | otherwise = Just localeEncoding+         mb_te <- if bin then return Nothing+                         else fmap Just getLocaleEncoding           openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do @@ -639,7 +639,7 @@            -> IO Handle dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do    -- XXX wrong!-  let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing+  mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing   mkHandle new_dev filepath haType True{-buffered-} mb_codec       NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }       mb_finalizer other_side@@ -741,3 +741,4 @@       where        def :: Int         def = bufSize buf+

@@ -7,3 +7,4 @@ import GHC.IO.Handle.Types  hFlush :: Handle -> IO ()+

@@ -52,7 +52,8 @@ stdin = unsafePerformIO $ do    -- ToDo: acquire lock    setBinaryMode FD.stdin-   mkHandle FD.stdin "<stdin>" ReadHandle True (Just localeEncoding)+   enc <- getLocaleEncoding+   mkHandle FD.stdin "<stdin>" ReadHandle True (Just enc)                 nativeNewlineMode{-translate newlines-}                 (Just stdHandleFinalizer) Nothing @@ -62,7 +63,8 @@ stdout = unsafePerformIO $ do    -- ToDo: acquire lock    setBinaryMode FD.stdout-   mkHandle FD.stdout "<stdout>" WriteHandle True (Just localeEncoding)+   enc <- getLocaleEncoding+   mkHandle FD.stdout "<stdout>" WriteHandle True (Just enc)                 nativeNewlineMode{-translate newlines-}                 (Just stdHandleFinalizer) Nothing @@ -72,8 +74,9 @@ stderr = unsafePerformIO $ do     -- ToDo: acquire lock    setBinaryMode FD.stderr+   enc <- getLocaleEncoding    mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-} -                (Just localeEncoding)+                (Just enc)                 nativeNewlineMode{-translate newlines-}                 (Just stdHandleFinalizer) Nothing @@ -179,7 +182,7 @@   -- first open the file to get an FD   (fd, fd_type) <- FD.openFile filepath iomode non_blocking -  let mb_codec = if binary then Nothing else Just localeEncoding+  mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding    -- then use it to make a Handle   mkHandleFromFD fd fd_type filepath iomode@@ -253,8 +256,8 @@   (fd,fd_type) <- FD.mkFD fdint iomode mb_stat                        is_socket                        is_socket-  mkHandleFromFD fd fd_type filepath iomode is_socket-                       (if binary then Nothing else Just localeEncoding)+  enc <- if binary then return Nothing else fmap Just getLocaleEncoding+  mkHandleFromFD fd fd_type filepath iomode is_socket enc   -- | Turn an existing file descriptor into a Handle.  This is used by

@@ -1,8 +1,10 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-}+ module GHC.IO.Handle.FD where  import GHC.IO.Handle.Types  -- used in GHC.Conc, which is below GHC.IO.Handle.FD stdout :: Handle+

@@ -912,3 +912,4 @@    writeIORef haByteBuffer bbuf2   return cbuf'+

@@ -39,7 +39,6 @@ import GHC.IO.Buffer import qualified GHC.IO.BufferedIO as Buffered import GHC.IO.Exception-import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter) import GHC.Exception import GHC.IO.Handle.Types import GHC.IO.Handle.Internals@@ -273,6 +272,9 @@         unpackRB acc !i          | i < r  = return acc          | otherwise = do+              -- Here, we are rather careful to only put an *evaluated* character+              -- in the output string. Due to pointer tagging, this allows the consumer+              -- to avoid ping-ponging between the actual consumer code and the thunk code #ifdef CHARBUF_UTF16               -- reverse-order decoding of UTF-16               c2 <- peekElemOff pbuf i@@ -281,10 +283,11 @@                  else do c1 <- peekElemOff pbuf (i-1)                          let c = (fromIntegral c1 - 0xd800) * 0x400 +                                  (fromIntegral c2 - 0xdc00) + 0x10000-                         unpackRB (desurrogatifyRoundtripCharacter (unsafeChr c) : acc) (i-2)+                         case desurrogatifyRoundtripCharacter (unsafeChr c) of+                           { C# c# -> unpackRB (C# c# : acc) (i-2) } #else               c <- peekElemOff pbuf i-              unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1)+              unpackRB (c : acc) (i-1) #endif      in      unpackRB acc0 (w-1)@@ -307,7 +310,7 @@                             then unpackRB ('\n':acc) (i-2)                             else unpackRB ('\n':acc) (i-1)                  else do-                         unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1)+                         unpackRB (c : acc) (i-1)      in do      c <- peekElemOff pbuf (w-1)      if (c == '\r')@@ -321,6 +324,24 @@                 str <- unpackRB acc0 (w-1)                 return (str, w) +-- Note [#5536]+--+-- We originally had+--+--    let c' = desurrogatifyRoundtripCharacter c in+--    c' `seq` unpackRB (c':acc) (i-1)+--+-- but this resulted in Core like+--+--    case (case x <# y of True -> C# e1; False -> C# e2) of c+--      C# _ -> unpackRB (c:acc) (i-1)+--+-- which compiles into a continuation for the outer case, with each+-- branch of the inner case building a C# and then jumping to the+-- continuation.  We'd rather not have this extra jump, which makes+-- quite a difference to performance (see #5536) It turns out that+-- matching on the C# directly causes GHC to do the case-of-case,+-- giving much straighter code.  -- ----------------------------------------------------------------------------- -- hGetContents@@ -587,7 +608,7 @@            else do                shoveString n' cs rest      | otherwise = do-        n' <- writeCharBuf raw n (surrogatifyRoundtripCharacter c)+        n' <- writeCharBuf raw n c         shoveString n' cs rest   in   shoveString 0 s (if add_nl then "\n" else "")@@ -985,3 +1006,4 @@                             InvalidArgument  fn                             ("illegal buffer size " ++ showsPrec 9 sz [])                             Nothing Nothing)+

@@ -428,3 +428,4 @@  showHandle :: FilePath -> String -> String showHandle file = showString "{handle: " . showString file . showString "}"+

@@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.IO.IOMode@@ -26,3 +27,4 @@ -- | See 'System.IO.openFile' data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode                     deriving (Eq, Ord, Ix, Enum, Read, Show)+

@@ -1,6 +1,8 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.IOArray

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK hide #-} @@ -6,7 +7,7 @@ -- Module      :  GHC.IOBase -- Copyright   :  (c) The University of Glasgow 1994-2009 -- License     :  see libraries/base/LICENSE--- +-- -- Maintainer  :  cvs-ghc@haskell.org -- Stability   :  internal -- Portability :  non-portable (GHC Extensions)@@ -15,9 +16,8 @@ -- ----------------------------------------------------------------------------- - module GHC.IOBase {-# DEPRECATED "use GHC.IO instead" #-} (-    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, +    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO,     unsafePerformIO, unsafeInterleaveIO,     unsafeDupablePerformIO, unsafeDupableInterleaveIO,     noDuplicate,@@ -26,23 +26,23 @@     stToIO, ioToST, unsafeIOToST, unsafeSTToIO,          -- References-    IORef(..), newIORef, readIORef, writeIORef, +    IORef(..), newIORef, readIORef, writeIORef,     IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,     MVar(..),          -- Handles, file descriptors,-    FilePath,  -    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, +    FilePath,+    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD,     isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,          -- Buffers-    -- Buffer(..), RawBuffer, BufferState(..), +    -- Buffer(..), RawBuffer, BufferState(..),     BufferList(..), BufferMode(..),-    --bufferIsWritable, bufferEmpty, bufferFull, +    --bufferIsWritable, bufferEmpty, bufferFull,          -- Exceptions     Exception(..), ArithException(..), AsyncException(..), ArrayException(..),-    stackOverflow, heapOverflow, ioException, +    stackOverflow, heapOverflow, ioException,     IOError, IOException(..), IOErrorType(..), ioError, userError,     ExitCode(..),     throwIO, block, unblock, blocked, catchAny, catchException,@@ -62,7 +62,6 @@ import GHC.IORef import GHC.MVar import Foreign.C.Types-import GHC.Show import Data.Typeable  type FD = CInt@@ -91,3 +90,4 @@  blockedIndefinitely :: SomeException -- for the RTS blockedIndefinitely = toException BlockedIndefinitely+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-}@@ -15,6 +16,7 @@ -- The IORef type -- -----------------------------------------------------------------------------+ module GHC.IORef (         IORef(..),         newIORef, readIORef, writeIORef, atomicModifyIORef

@@ -1,13 +1,14 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash,              StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.Int -- Copyright   :  (c) The University of Glasgow 1997-2002 -- License     :  see libraries/base/LICENSE--- +-- -- Maintainer  :  cvs-ghc@haskell.org -- Stability   :  internal -- Portability :  non-portable (GHC Extensions)@@ -26,9 +27,6 @@  import Data.Bits -#if WORD_SIZE_IN_BITS < 32-import GHC.IntWord32-#endif #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 #endif@@ -139,8 +137,12 @@     (I8# x#) `shift` (I# i#)         | i# >=# 0#           = I8# (narrow8Int# (x# `iShiftL#` i#))         | otherwise           = I8# (x# `iShiftRA#` negateInt# i#)+    (I8# x#) `shiftL` (I# i#) = I8# (narrow8Int# (x# `iShiftL#` i#))+    (I8# x#) `unsafeShiftL` (I# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` i#))+    (I8# x#) `shiftR` (I# i#) = I8# (x# `iShiftRA#` i#)+    (I8# x#) `unsafeShiftR` (I# i#) = I8# (x# `uncheckedIShiftRA#` i#)     (I8# x#) `rotate` (I# i#)-        | i'# ==# 0# +        | i'# ==# 0#         = I8# x#         | otherwise         = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`@@ -150,6 +152,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)     bitSize  _                = 8     isSigned _                = True+    popCount (I8# x#)         = I# (word2Int# (popCnt8# (int2Word# x#)))  {-# RULES "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8@@ -281,8 +284,12 @@     (I16# x#) `shift` (I# i#)         | i# >=# 0#            = I16# (narrow16Int# (x# `iShiftL#` i#))         | otherwise            = I16# (x# `iShiftRA#` negateInt# i#)+    (I16# x#) `shiftL` (I# i#) = I16# (narrow16Int# (x# `iShiftL#` i#))+    (I16# x#) `unsafeShiftL` (I# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` i#))+    (I16# x#) `shiftR` (I# i#) = I16# (x# `iShiftRA#` i#)+    (I16# x#) `unsafeShiftR` (I# i#) = I16# (x# `uncheckedIShiftRA#` i#)     (I16# x#) `rotate` (I# i#)-        | i'# ==# 0# +        | i'# ==# 0#         = I16# x#         | otherwise         = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`@@ -292,6 +299,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)     bitSize  _                 = 16     isSigned _                 = True+    popCount (I16# x#)         = I# (word2Int# (popCnt16# (int2Word# x#)))   {-# RULES@@ -336,148 +344,6 @@ -- type Int32 ------------------------------------------------------------------------ -#if WORD_SIZE_IN_BITS < 32--data Int32 = I32# Int32#--- ^ 32-bit signed integer type--instance Eq Int32 where-    (I32# x#) == (I32# y#) = x# `eqInt32#` y#-    (I32# x#) /= (I32# y#) = x# `neInt32#` y#--instance Ord Int32 where-    (I32# x#) <  (I32# y#) = x# `ltInt32#` y#-    (I32# x#) <= (I32# y#) = x# `leInt32#` y#-    (I32# x#) >  (I32# y#) = x# `gtInt32#` y#-    (I32# x#) >= (I32# y#) = x# `geInt32#` y#--instance Show Int32 where-    showsPrec p x = showsPrec p (toInteger x)--instance Num Int32 where-    (I32# x#) + (I32# y#)  = I32# (x# `plusInt32#`  y#)-    (I32# x#) - (I32# y#)  = I32# (x# `minusInt32#` y#)-    (I32# x#) * (I32# y#)  = I32# (x# `timesInt32#` y#)-    negate (I32# x#)       = I32# (negateInt32# x#)-    abs x | x >= 0         = x-          | otherwise      = negate x-    signum x | x > 0       = 1-    signum 0               = 0-    signum _               = -1-    fromInteger (S# i#)    = I32# (intToInt32# i#)-    fromInteger (J# s# d#) = I32# (integerToInt32# s# d#)--instance Enum Int32 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Int32"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Int32"-    toEnum (I# i#)      = I32# (intToInt32# i#)-    fromEnum x@(I32# x#)-        | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)-                        = I# (int32ToInt# x#)-        | otherwise     = fromEnumError "Int32" x-    enumFrom            = integralEnumFrom-    enumFromThen        = integralEnumFromThen-    enumFromTo          = integralEnumFromTo-    enumFromThenTo      = integralEnumFromThenTo--instance Integral Int32 where-    quot    x@(I32# x#) y@(I32# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I32# (x# `quotInt32#` y#)-    rem       (I32# x#) y@(I32# y#)-        | y == 0                  = divZeroError-          -- The quotRem CPU instruction fails for minBound `quotRem` -1,-          -- but minBound `rem` -1 is well-defined (0). We therefore-          -- special-case it.-        | y == (-1)               = 0-        | otherwise               = I32# (x# `remInt32#` y#)-    div     x@(I32# x#) y@(I32# y#)-        | y == 0                  = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise               = I32# (x# `divInt32#` y#)-    mod       (I32# x#) y@(I32# y#)-        | y == 0                  = divZeroError-          -- The divMod CPU instruction fails for minBound `divMod` -1,-          -- but minBound `mod` -1 is well-defined (0). We therefore-          -- special-case it.-        | y == (-1)               = 0-        | otherwise               = I32# (x# `modInt32#` y#)-    quotRem x@(I32# x#) y@(I32# y#)-        | y == 0                  = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise               = (I32# (x# `quotInt32#` y#),-                                     I32# (x# `remInt32#` y#))-    divMod  x@(I32# x#) y@(I32# y#)-        | y == 0                  = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise               = (I32# (x# `divInt32#` y#),-                                     I32# (x# `modInt32#` y#))-    toInteger x@(I32# x#)-	| x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)-                                  = smallInteger (int32ToInt# x#)-        | otherwise               = case int32ToInteger# x# of (# s, d #) -> J# s d--divInt32#, modInt32# :: Int32# -> Int32# -> Int32#-x# `divInt32#` y#-    | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#)-        = ((x# `minusInt32#` y#) `minusInt32#` intToInt32# 1#) `quotInt32#` y#-    | (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)-        = ((x# `minusInt32#` y#) `plusInt32#` intToInt32# 1#) `quotInt32#` y#-    | otherwise                = x# `quotInt32#` y#-x# `modInt32#` y#-    | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) ||-      (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)-        = if r# `neInt32#` intToInt32# 0# then r# `plusInt32#` y# else intToInt32# 0#-    | otherwise = r#-    where-    r# = x# `remInt32#` y#--instance Read Int32 where-    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]--instance Bits Int32 where-    {-# INLINE shift #-}--    (I32# x#) .&.   (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `and32#` int32ToWord32# y#))-    (I32# x#) .|.   (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `or32#`  int32ToWord32# y#))-    (I32# x#) `xor` (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#))-    complement (I32# x#)       = I32# (word32ToInt32# (not32# (int32ToWord32# x#)))-    (I32# x#) `shift` (I# i#)-        | i# >=# 0#            = I32# (x# `iShiftL32#` i#)-        | otherwise            = I32# (x# `iShiftRA32#` negateInt# i#)-    (I32# x#) `rotate` (I# i#)-        | i'# ==# 0# -        = I32# x#-        | otherwise-        = I32# (word32ToInt32# ((x'# `shiftL32#` i'#) `or32#`-                                (x'# `shiftRL32#` (32# -# i'#))))-        where-        x'# = int32ToWord32# x#-        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)-    bitSize  _                 = 32-    isSigned _                 = True---{-# RULES-"fromIntegral/Int->Int32"    fromIntegral = \(I#   x#) -> I32# (intToInt32# x#)-"fromIntegral/Word->Int32"   fromIntegral = \(W#   x#) -> I32# (word32ToInt32# (wordToWord32# x#))-"fromIntegral/Word32->Int32" fromIntegral = \(W32# x#) -> I32# (word32ToInt32# x#)-"fromIntegral/Int32->Int"    fromIntegral = \(I32# x#) -> I#   (int32ToInt# x#)-"fromIntegral/Int32->Word"   fromIntegral = \(I32# x#) -> W#   (int2Word# (int32ToInt# x#))-"fromIntegral/Int32->Word32" fromIntegral = \(I32# x#) -> W32# (int32ToWord32# x#)-"fromIntegral/Int32->Int32"  fromIntegral = id :: Int32 -> Int32-  #-}---- No rules for RealFrac methods if Int32 is larger than Int-#else- -- Int32 is represented in the same way as Int. #if WORD_SIZE_IN_BITS > 32 -- Operations may assume and must ensure that it holds only values@@ -571,8 +437,13 @@     (I32# x#) `shift` (I# i#)         | i# >=# 0#            = I32# (narrow32Int# (x# `iShiftL#` i#))         | otherwise            = I32# (x# `iShiftRA#` negateInt# i#)+    (I32# x#) `shiftL` (I# i#) = I32# (narrow32Int# (x# `iShiftL#` i#))+    (I32# x#) `unsafeShiftL` (I# i#) =+        I32# (narrow32Int# (x# `uncheckedIShiftL#` i#))+    (I32# x#) `shiftR` (I# i#) = I32# (x# `iShiftRA#` i#)+    (I32# x#) `unsafeShiftR` (I# i#) = I32# (x# `uncheckedIShiftRA#` i#)     (I32# x#) `rotate` (I# i#)-        | i'# ==# 0# +        | i'# ==# 0#         = I32# x#         | otherwise         = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`@@ -582,6 +453,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)     bitSize  _                 = 32     isSigned _                 = True+    popCount (I32# x#)         = I# (word2Int# (popCnt32# (int2Word# x#)))  {-# RULES "fromIntegral/Word8->Int32"  fromIntegral = \(W8# x#) -> I32# (word2Int# x#)@@ -623,8 +495,6 @@     forall x. round    (x :: Double) = (fromIntegral :: Int -> Int32) (round x)   #-} -#endif- instance Real Int32 where     toRational x = toInteger x % 1 @@ -754,8 +624,12 @@     (I64# x#) `shift` (I# i#)         | i# >=# 0#            = I64# (x# `iShiftL64#` i#)         | otherwise            = I64# (x# `iShiftRA64#` negateInt# i#)+    (I64# x#) `shiftL` (I# i#) = I64# (x# `iShiftL64#` i#)+    (I64# x#) `unsafeShiftL` (I# i#) = I64# (x# `uncheckedIShiftL64#` i#)+    (I64# x#) `shiftR` (I# i#) = I64# (x# `iShiftRA64#` i#)+    (I64# x#) `unsafeShiftR` (I# i#) = I64# (x# `uncheckedIShiftRA64#` i#)     (I64# x#) `rotate` (I# i#)-        | i'# ==# 0# +        | i'# ==# 0#         = I64# x#         | otherwise         = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#`@@ -765,6 +639,8 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)     bitSize  _                 = 64     isSigned _                 = True+    popCount (I64# x#)         =+        I# (word2Int# (popCnt64# (int64ToWord64# x#)))  -- give the 64-bit shift operations the same treatment as the 32-bit -- ones (see GHC.Base), namely we wrap them in tests to catch the@@ -776,8 +652,8 @@ a `iShiftL64#` b  | b >=# 64# = intToInt64# 0# 		  | otherwise = a `uncheckedIShiftL64#` b -a `iShiftRA64#` b | b >=# 64# = if a `ltInt64#` (intToInt64# 0#) -					then intToInt64# (-1#) +a `iShiftRA64#` b | b >=# 64# = if a `ltInt64#` (intToInt64# 0#)+					then intToInt64# (-1#) 					else intToInt64# 0# 		  | otherwise = a `uncheckedIShiftRA64#` b @@ -877,8 +753,12 @@     (I64# x#) `shift` (I# i#)         | i# >=# 0#            = I64# (x# `iShiftL#` i#)         | otherwise            = I64# (x# `iShiftRA#` negateInt# i#)+    (I64# x#) `shiftL` (I# i#) = I64# (x# `iShiftL#` i#)+    (I64# x#) `unsafeShiftL` (I# i#) = I64# (x# `uncheckedIShiftL#` i#)+    (I64# x#) `shiftR` (I# i#) = I64# (x# `iShiftRA#` i#)+    (I64# x#) `unsafeShiftR` (I# i#) = I64# (x# `uncheckedIShiftRA#` i#)     (I64# x#) `rotate` (I# i#)-        | i'# ==# 0# +        | i'# ==# 0#         = I64# x#         | otherwise         = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`@@ -888,6 +768,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)     bitSize  _                 = 64     isSigned _                 = True+    popCount (I64# x#)         = I# (word2Int# (popCnt64# (int2Word# x#)))  {-# RULES "fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x#

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-}

@@ -1,9 +1,6 @@ \begin{code} {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}--- We believe we could deorphan this module, by moving lots of things--- around, but we haven't got there yet:-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- |@@ -19,26 +16,10 @@ -- ----------------------------------------------------------------------------- -#include "MachDeps.h"-#if SIZEOF_HSWORD == 4-#define DIGITS       9-#define BASE         1000000000-#elif SIZEOF_HSWORD == 8-#define DIGITS       18-#define BASE         1000000000000000000-#else-#error Please define DIGITS and BASE--- DIGITS should be the largest integer such that---     10^DIGITS < 2^(SIZEOF_HSWORD * 8 - 1)--- BASE should be 10^DIGITS. Note that ^ is not available yet.-#endif- -- #hide module GHC.Num (module GHC.Num, module GHC.Integer) where  import GHC.Base-import GHC.Enum-import GHC.Show import GHC.Integer  infixl 7  *@@ -58,7 +39,7 @@ -- | Basic numeric class. -- -- Minimal complete definition: all except 'negate' or @(-)@-class  (Eq a, Show a) => Num a  where+class  Num a  where     (+), (-), (*)       :: a -> a -> a     -- | Unary negation.     negate              :: a -> a@@ -126,103 +107,6 @@  %********************************************************* %*                                                      *-\subsection{The @Integer@ instances for @Show@}-%*                                                      *-%*********************************************************--\begin{code}-instance Show Integer where-    showsPrec p n r-        | p > 6 && n < 0 = '(' : integerToString n (')' : r)-        -- Minor point: testing p first gives better code-        -- in the not-uncommon case where the p argument-        -- is a constant-        | otherwise = integerToString n r-    showList = showList__ (showsPrec 0)---- Divide an conquer implementation of string conversion-integerToString :: Integer -> String -> String-integerToString n0 cs0-    | n0 < 0    = '-' : integerToString' (- n0) cs0-    | otherwise = integerToString' n0 cs0-    where-    integerToString' :: Integer -> String -> String-    integerToString' n cs-        | n < BASE  = jhead (fromInteger n) cs-        | otherwise = jprinth (jsplitf (BASE*BASE) n) cs--    -- Split n into digits in base p. We first split n into digits-    -- in base p*p and then split each of these digits into two.-    -- Note that the first 'digit' modulo p*p may have a leading zero-    -- in base p that we need to drop - this is what jsplith takes care of.-    -- jsplitb the handles the remaining digits.-    jsplitf :: Integer -> Integer -> [Integer]-    jsplitf p n-        | p > n     = [n]-        | otherwise = jsplith p (jsplitf (p*p) n)--    jsplith :: Integer -> [Integer] -> [Integer]-    jsplith p (n:ns) =-        case n `quotRemInteger` p of-        (# q, r #) ->-            if q > 0 then q : r : jsplitb p ns-                     else     r : jsplitb p ns-    jsplith _ [] = error "jsplith: []"--    jsplitb :: Integer -> [Integer] -> [Integer]-    jsplitb _ []     = []-    jsplitb p (n:ns) = case n `quotRemInteger` p of-                       (# q, r #) ->-                           q : r : jsplitb p ns--    -- Convert a number that has been split into digits in base BASE^2-    -- this includes a last splitting step and then conversion of digits-    -- that all fit into a machine word.-    jprinth :: [Integer] -> String -> String-    jprinth (n:ns) cs =-        case n `quotRemInteger` BASE of-        (# q', r' #) ->-            let q = fromInteger q'-                r = fromInteger r'-            in if q > 0 then jhead q $ jblock r $ jprintb ns cs-                        else jhead r $ jprintb ns cs-    jprinth [] _ = error "jprinth []"--    jprintb :: [Integer] -> String -> String-    jprintb []     cs = cs-    jprintb (n:ns) cs = case n `quotRemInteger` BASE of-                        (# q', r' #) ->-                            let q = fromInteger q'-                                r = fromInteger r'-                            in jblock q $ jblock r $ jprintb ns cs--    -- Convert an integer that fits into a machine word. Again, we have two-    -- functions, one that drops leading zeros (jhead) and one that doesn't-    -- (jblock)-    jhead :: Int -> String -> String-    jhead n cs-        | n < 10    = case unsafeChr (ord '0' + n) of-            c@(C# _) -> c : cs-        | otherwise = case unsafeChr (ord '0' + r) of-            c@(C# _) -> jhead q (c : cs)-        where-        (q, r) = n `quotRemInt` 10--    jblock = jblock' {- ' -} DIGITS--    jblock' :: Int -> Int -> String -> String-    jblock' d n cs-        | d == 1    = case unsafeChr (ord '0' + n) of-             c@(C# _) -> c : cs-        | otherwise = case unsafeChr (ord '0' + r) of-             c@(C# _) -> jblock' (d - 1) q (c : cs)-        where-        (q, r) = n `quotRemInt` 10-\end{code}---%*********************************************************-%*                                                      * \subsection{The @Integer@ instances for @Num@} %*                                                      * %*********************************************************@@ -237,80 +121,5 @@      abs = absInteger     signum = signumInteger-\end{code}---%*********************************************************-%*                                                      *-\subsection{The @Integer@ instance for @Enum@}-%*                                                      *-%*********************************************************--\begin{code}-instance  Enum Integer  where-    succ x               = x + 1-    pred x               = x - 1-    toEnum (I# n)        = smallInteger n-    fromEnum n           = I# (integerToInt n)--    {-# INLINE enumFrom #-}-    {-# INLINE enumFromThen #-}-    {-# INLINE enumFromTo #-}-    {-# INLINE enumFromThenTo #-}-    enumFrom x             = enumDeltaInteger  x 1-    enumFromThen x y       = enumDeltaInteger  x (y-x)-    enumFromTo x lim       = enumDeltaToInteger x 1     lim-    enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim--{-# RULES-"enumDeltaInteger"      [~1] forall x y.  enumDeltaInteger x y     = build (\c _ -> enumDeltaIntegerFB c x y)-"efdtInteger"           [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)-"enumDeltaInteger"      [1] enumDeltaIntegerFB   (:)    = enumDeltaInteger-"enumDeltaToInteger"    [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger- #-}--enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b-enumDeltaIntegerFB c x d = x `seq` (x `c` enumDeltaIntegerFB c (x+d) d)--enumDeltaInteger :: Integer -> Integer -> [Integer]-enumDeltaInteger x d = x `seq` (x : enumDeltaInteger (x+d) d)--- strict accumulator, so---     head (drop 1000000 [1 .. ]--- works--{-# NOINLINE [0] enumDeltaToIntegerFB #-}--- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire-enumDeltaToIntegerFB :: (Integer -> a -> a) -> a-                     -> Integer -> Integer -> Integer -> a-enumDeltaToIntegerFB c n x delta lim-  | delta >= 0 = up_fb c n x delta lim-  | otherwise  = dn_fb c n x delta lim--enumDeltaToInteger :: Integer -> Integer -> Integer -> [Integer]-enumDeltaToInteger x delta lim-  | delta >= 0 = up_list x delta lim-  | otherwise  = dn_list x delta lim--up_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a-up_fb c n x0 delta lim = go (x0 :: Integer)-                      where-                        go x | x > lim   = n-                             | otherwise = x `c` go (x+delta)-dn_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a-dn_fb c n x0 delta lim = go (x0 :: Integer)-                      where-                        go x | x < lim   = n-                             | otherwise = x `c` go (x+delta)--up_list :: Integer -> Integer -> Integer -> [Integer]-up_list x0 delta lim = go (x0 :: Integer)-                    where-                        go x | x > lim   = []-                             | otherwise = x : go (x+delta)-dn_list :: Integer -> Integer -> Integer -> [Integer]-dn_list x0 delta lim = go (x0 :: Integer)-                    where-                        go x | x < lim   = []-                             | otherwise = x : go (x+delta) \end{code} 

@@ -13,6 +13,12 @@ -- Stability   :  internal -- Portability :  non-portable (GHC Extensions) --+-- BIG UGLY HACK: The desugarer special cases this module.  Despite the uses of '-XParallelArrays',+--                the desugarer does not load 'Data.Array.Parallel' into its global state. (Hence,+--                the present module may not use any other piece of '-XParallelArray' syntax.)+--+--                This will be cleaned up when we change the internal represention of '[::]' to not+--                rely on a wired-in type constructor.  -- #hide module GHC.PArr where@@ -27,3 +33,5 @@ -- NB: This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! -- data [::] e = PArr !Int (Array# e)++type PArr = [::]   -- this synonym is to get access to '[::]' without using the special syntax

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} 

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} {-# OPTIONS_HADDOCK hide #-} 

@@ -27,6 +27,10 @@ import GHC.Show import GHC.Err +#ifdef OPTIMISE_INTEGER_GCD_LCM+import GHC.Integer.GMP.Internals+#endif+ infixr 8  ^, ^^ infixl 7  /, `quot`, `rem`, `div`, `mod` infixl 7  %@@ -239,7 +243,7 @@  \begin{code} instance  Real Int  where-    toRational x        =  toInteger x % 1+    toRational x        =  toInteger x :% 1  instance  Integral Int  where     toInteger (I# i) = smallInteger i@@ -294,7 +298,7 @@  \begin{code} instance  Real Integer  where-    toRational x        =  x % 1+    toRational x        =  x :% 1  instance  Integral Integer where     toInteger n      = n@@ -358,7 +362,7 @@     properFraction (x:%y) = (fromInteger (toInteger q), r:%y)                           where (q,r) = quotRem x y -instance  (Integral a)  => Show (Ratio a)  where+instance  (Integral a, Show a)  => Show (Ratio a)  where     {-# SPECIALIZE instance Show Rational #-}     showsPrec p (x:%y)  =  showParen (p > ratioPrec) $                            showsPrec ratioPrec1 x .@@ -402,10 +406,6 @@ -- | general coercion to fractional types realToFrac :: (Real a, Fractional b) => a -> b realToFrac = fromRational . toRational--{-# RULES-"realToFrac/Int->Int" realToFrac = id :: Int -> Int-    #-} \end{code}  %*********************************************************@@ -431,7 +431,7 @@  ------------------------------------------------------- -- | raise a number to a non-negative integral power-{-# SPECIALISE (^) ::+{-# SPECIALISE [1] (^) ::         Integer -> Integer -> Integer,         Integer -> Int -> Integer,         Int -> Int -> Int #-}@@ -464,6 +464,44 @@    Currently the fromInteger calls are not floated because we get              \d1 d2 x y -> blah    after the gentle round of simplification. -}++{- Rules for powers with known small exponent+    see #5237+    For small exponents, (^) is inefficient compared to manually+    expanding the multiplication tree.+    Here, rules for the most common exponent types are given.+    The range of exponents for which rules are given is quite+    arbitrary and kept small to not unduly increase the number of rules.+    0 and 1 are excluded based on the assumption that nobody would+    write x^0 or x^1 in code and the cases where an exponent could+    be statically resolved to 0 or 1 are rare.++    It might be desirable to have corresponding rules also for+    exponents of other types, in particular Word, but we can't+    have those rules here (importing GHC.Word or GHC.Int would+    create a cyclic module dependency), and it's doubtful they+    would fire, since the exponents of other types tend to get+    floated out before the rule has a chance to fire.++    Also desirable would be rules for (^^), but I haven't managed+    to get those to fire.++    Note: Trying to save multiplications by sharing the square for+    exponents 4 and 5 does not save time, indeed, for Double, it is+    up to twice slower, so the rules contain flat sequences of+    multiplications.+-}++{-# RULES+"^2/Int"        forall x. x ^ (2 :: Int) = let u = x in u*u+"^3/Int"        forall x. x ^ (3 :: Int) = let u = x in u*u*u+"^4/Int"        forall x. x ^ (4 :: Int) = let u = x in u*u*u*u+"^5/Int"        forall x. x ^ (5 :: Int) = let u = x in u*u*u*u*u+"^2/Integer"    forall x. x ^ (2 :: Integer) = let u = x in u*u+"^3/Integer"    forall x. x ^ (3 :: Integer) = let u = x in u*u*u+"^4/Integer"    forall x. x ^ (4 :: Integer) = let u = x in u*u*u*u+"^5/Integer"    forall x. x ^ (5 :: Integer) = let u = x in u*u*u*u*u+  #-}  ------------------------------------------------------- -- Special power functions for Rational

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, Rank2Types #-} {-# OPTIONS_HADDOCK hide #-} -----------------------------------------------------------------------------

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} 

@@ -1,14 +1,29 @@ \begin{code} {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, BangPatterns, MagicHash, StandaloneDeriving #-}+{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, StandaloneDeriving,+             MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} +#include "MachDeps.h"+#if SIZEOF_HSWORD == 4+#define DIGITS       9+#define BASE         1000000000+#elif SIZEOF_HSWORD == 8+#define DIGITS       18+#define BASE         1000000000000000000+#else+#error Please define DIGITS and BASE+-- DIGITS should be the largest integer such that+--     10^DIGITS < 2^(SIZEOF_HSWORD * 8 - 1)+-- BASE should be 10^DIGITS. Note that ^ is not available yet.+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  GHC.Show -- Copyright   :  (c) The University of Glasgow, 1992-2002 -- License     :  see libraries/base/LICENSE--- +-- -- Maintainer  :  cvs-ghc@haskell.org -- Stability   :  internal -- Portability :  non-portable (GHC Extensions)@@ -37,6 +52,7 @@         where  import GHC.Base+import GHC.Num import Data.Maybe import GHC.List ((!!), foldr1, break) -- For defining instances for the generic deriving mechanism@@ -98,7 +114,7 @@ -- >          where app_prec = 10 -- > -- >        showsPrec d (u :^: v) = showParen (d > up_prec) $--- >             showsPrec (up_prec+1) u . +-- >             showsPrec (up_prec+1) u . -- >             showString " :^: "      . -- >             showsPrec (up_prec+1) v -- >          where up_prec = 5@@ -165,7 +181,7 @@ %*********************************************************  \begin{code}- + instance  Show ()  where     showsPrec _ () = showString "()" @@ -193,8 +209,8 @@ instance Show a => Show (Maybe a) where     showsPrec _p Nothing s = showString "Nothing" s     showsPrec p (Just x) s-                          = (showParen (p > appPrec) $ -                             showString "Just " . +                          = (showParen (p > appPrec) $+                             showString "Just " .                              showsPrec appPrec1 x) s \end{code} @@ -229,58 +245,58 @@  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)         => Show (a,b,c,d,e,f,g) where-  showsPrec _ (a,b,c,d,e,f,g) s +  showsPrec _ (a,b,c,d,e,f,g) s         = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)          => Show (a,b,c,d,e,f,g,h) where-  showsPrec _ (a,b,c,d,e,f,g,h) s +  showsPrec _ (a,b,c,d,e,f,g,h) s         = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i)          => Show (a,b,c,d,e,f,g,h,i) where-  showsPrec _ (a,b,c,d,e,f,g,h,i) s -        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +  showsPrec _ (a,b,c,d,e,f,g,h,i) s+        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,                       shows i] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j)          => Show (a,b,c,d,e,f,g,h,i,j) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j) s -        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +  showsPrec _ (a,b,c,d,e,f,g,h,i,j) s+        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,                       shows i, shows j] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k)          => Show (a,b,c,d,e,f,g,h,i,j,k) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k) s -        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k) s+        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,                       shows i, shows j, shows k] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,           Show l)          => Show (a,b,c,d,e,f,g,h,i,j,k,l) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l) s -        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l) s+        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,                       shows i, shows j, shows k, shows l] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,           Show l, Show m)          => Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m) s -        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m) s+        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,                       shows i, shows j, shows k, shows l, shows m] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,           Show l, Show m, Show n)          => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) s -        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) s+        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,                       shows i, shows j, shows k, shows l, shows m, shows n] s  instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,           Show l, Show m, Show n, Show o)          => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) s -        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h, +  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) s+        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,                       shows i, shows j, shows k, shows l, shows m, shows n, shows o] s  show_tuple :: [ShowS] -> ShowS@@ -351,7 +367,7 @@ -- for non-printable characters. Does not add double-quotes around the -- whole thing; the caller should do that. -- The main difference from showLitChar (apart from the fact that the--- argument is a string not a list) is that we must escape double-quotes +-- argument is a string not a list) is that we must escape double-quotes showLitString []         s = s showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s) showLitString (c   : cs) s = showLitChar c (showLitString cs s)@@ -365,7 +381,7 @@ -- escape conventions), but --   * break the string into multiple lines --   * wrap the entire thing in double quotes--- Example:  @showLitString "hello\ngoodbye\nblah"@+-- Example:  @showMultiLineString "hello\ngoodbye\nblah"@ -- returns   @["\"hello\\", "\\goodbye\\", "\\blah\""]@ showMultiLineString str   = go '\"' str@@ -386,10 +402,10 @@ asciiTab :: [String] asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",-            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI", +            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",-            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US", -            "SP"] +            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",+            "SP"] \end{code}  Code specific for Ints.@@ -437,3 +453,101 @@ deriving instance Show Associativity deriving instance Show Fixity \end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instances for @Show@}+%*                                                      *+%*********************************************************++\begin{code}+instance Show Integer where+    showsPrec p n r+        | p > 6 && n < 0 = '(' : integerToString n (')' : r)+        -- Minor point: testing p first gives better code+        -- in the not-uncommon case where the p argument+        -- is a constant+        | otherwise = integerToString n r+    showList = showList__ (showsPrec 0)++-- Divide an conquer implementation of string conversion+integerToString :: Integer -> String -> String+integerToString n0 cs0+    | n0 < 0    = '-' : integerToString' (- n0) cs0+    | otherwise = integerToString' n0 cs0+    where+    integerToString' :: Integer -> String -> String+    integerToString' n cs+        | n < BASE  = jhead (fromInteger n) cs+        | otherwise = jprinth (jsplitf (BASE*BASE) n) cs++    -- Split n into digits in base p. We first split n into digits+    -- in base p*p and then split each of these digits into two.+    -- Note that the first 'digit' modulo p*p may have a leading zero+    -- in base p that we need to drop - this is what jsplith takes care of.+    -- jsplitb the handles the remaining digits.+    jsplitf :: Integer -> Integer -> [Integer]+    jsplitf p n+        | p > n     = [n]+        | otherwise = jsplith p (jsplitf (p*p) n)++    jsplith :: Integer -> [Integer] -> [Integer]+    jsplith p (n:ns) =+        case n `quotRemInteger` p of+        (# q, r #) ->+            if q > 0 then q : r : jsplitb p ns+                     else     r : jsplitb p ns+    jsplith _ [] = error "jsplith: []"++    jsplitb :: Integer -> [Integer] -> [Integer]+    jsplitb _ []     = []+    jsplitb p (n:ns) = case n `quotRemInteger` p of+                       (# q, r #) ->+                           q : r : jsplitb p ns++    -- Convert a number that has been split into digits in base BASE^2+    -- this includes a last splitting step and then conversion of digits+    -- that all fit into a machine word.+    jprinth :: [Integer] -> String -> String+    jprinth (n:ns) cs =+        case n `quotRemInteger` BASE of+        (# q', r' #) ->+            let q = fromInteger q'+                r = fromInteger r'+            in if q > 0 then jhead q $ jblock r $ jprintb ns cs+                        else jhead r $ jprintb ns cs+    jprinth [] _ = error "jprinth []"++    jprintb :: [Integer] -> String -> String+    jprintb []     cs = cs+    jprintb (n:ns) cs = case n `quotRemInteger` BASE of+                        (# q', r' #) ->+                            let q = fromInteger q'+                                r = fromInteger r'+                            in jblock q $ jblock r $ jprintb ns cs++    -- Convert an integer that fits into a machine word. Again, we have two+    -- functions, one that drops leading zeros (jhead) and one that doesn't+    -- (jblock)+    jhead :: Int -> String -> String+    jhead n cs+        | n < 10    = case unsafeChr (ord '0' + n) of+            c@(C# _) -> c : cs+        | otherwise = case unsafeChr (ord '0' + r) of+            c@(C# _) -> jhead q (c : cs)+        where+        (q, r) = n `quotRemInt` 10++    jblock = jblock' {- ' -} DIGITS++    jblock' :: Int -> Int -> String -> String+    jblock' d n cs+        | d == 1    = case unsafeChr (ord '0' + n) of+             c@(C# _) -> c : cs+        | otherwise = case unsafeChr (ord '0' + r) of+             c@(C# _) -> jblock' (d - 1) q (c : cs)+        where+        (q, r) = n `quotRemInt` 10+\end{code}+

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude            , MagicHash            , UnboxedTuples

@@ -0,0 +1,108 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Stack+-- Copyright   :  (c) The University of Glasgow 2011+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Access to GHC's call-stack simulation+--+-----------------------------------------------------------------------------++{-# LANGUAGE UnboxedTuples, MagicHash, EmptyDataDecls #-}+module GHC.Stack (+    -- * Call stack+    currentCallStack,+    whoCreated,++    -- * Internals+    CostCentreStack,+    CostCentre,+    getCurrentCCS,+    getCCSOf,+    ccsCC,+    ccsParent,+    ccLabel,+    ccModule,+    ccSrcSpan,+    ccsToStrings,+    renderStack+  ) where++import Foreign+import Foreign.C++import GHC.IO+import GHC.Base+import GHC.Ptr+import GHC.Foreign as GHC+import GHC.IO.Encoding++#define PROFILING+#include "Rts.h"++data CostCentreStack+data CostCentre++getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)+getCurrentCCS dummy = IO $ \s ->+   case getCurrentCCS## dummy s of+     (## s', addr ##) -> (## s', Ptr addr ##)++getCCSOf :: a -> IO (Ptr CostCentreStack)+getCCSOf obj = IO $ \s ->+   case getCCSOf## obj s of+     (## s', addr ##) -> (## s', Ptr addr ##)++ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)+ccsCC p = (# peek CostCentreStack, cc) p++ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)+ccsParent p = (# peek CostCentreStack, prevStack) p++ccLabel :: Ptr CostCentre -> IO CString+ccLabel p = (# peek CostCentre, label) p++ccModule :: Ptr CostCentre -> IO CString+ccModule p = (# peek CostCentre, module) p++ccSrcSpan :: Ptr CostCentre -> IO CString+ccSrcSpan p = (# peek CostCentre, srcloc) p++-- | returns a '[String]' representing the current call stack.  This+-- can be useful for debugging.+--+-- The implementation uses the call-stack simulation maintined by the+-- profiler, so it only works if the program was compiled with @-prof@+-- and contains suitable SCC annotations (e.g. by using @-fprof-auto@).+-- Otherwise, the list returned is likely to be empty or+-- uninformative.++currentCallStack :: IO [String]+currentCallStack = ccsToStrings =<< getCurrentCCS ()++ccsToStrings :: Ptr CostCentreStack -> IO [String]+ccsToStrings ccs0 = go ccs0 []+  where+    go ccs acc+     | ccs == nullPtr = return acc+     | otherwise = do+        cc  <- ccsCC ccs+        lbl <- GHC.peekCString utf8 =<< ccLabel cc+        mdl <- GHC.peekCString utf8 =<< ccModule cc+        loc <- GHC.peekCString utf8 =<< ccSrcSpan cc+        parent <- ccsParent ccs+        if (mdl == "MAIN" && lbl == "MAIN")+           then return acc+           else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)++whoCreated :: a -> IO [String]+whoCreated obj = do+  ccs <- getCCSOf obj+  ccsToStrings ccs++renderStack :: [String] -> String+renderStack strs = "Stack trace:" ++ concatMap ("\n  "++) (reverse strs)

@@ -0,0 +1,130 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-----------------------------------------------------------------------------+-- | This module provides access to internal garbage collection and+-- memory usage statistics.  These statistics are not available unless+-- a program is run with the @-T@ RTS flag.+--+-- This module is GHC-only and should not be considered portable.+--+-----------------------------------------------------------------------------+module GHC.Stats+    ( GCStats(..)+    , getGCStats+) where++import Foreign.Marshal.Alloc+import Foreign.Storable+import Foreign.Ptr+import Data.Int++#include "Rts.h"++foreign import ccall "getGCStats"    getGCStats_    :: Ptr () -> IO ()++-- I'm probably violating a bucket of constraints here... oops.++-- | Global garbage collection and memory statistics.+data GCStats = GCStats+    { bytesAllocated :: !Int64 -- ^ Total number of bytes allocated+    , numGcs :: !Int64 -- ^ Number of garbage collections performed+    , maxBytesUsed :: !Int64 -- ^ Maximum number of live bytes seen so far+    , numByteUsageSamples :: !Int64 -- ^ Number of byte usage samples taken+    -- | Sum of all byte usage samples, can be used with+    -- 'numByteUsageSamples' to calculate averages with+    -- arbitrary weighting (if you are sampling this record multiple+    -- times).+    , cumulativeBytesUsed :: !Int64+    , bytesCopied :: !Int64 -- ^ Number of bytes copied during GC+    , currentBytesUsed :: !Int64 -- ^ Current number of live bytes+    , currentBytesSlop :: !Int64 -- ^ Current number of bytes lost to slop+    , maxBytesSlop :: !Int64 -- ^ Maximum number of bytes lost to slop at any one time so far+    , peakMegabytesAllocated :: !Int64 -- ^ Maximum number of megabytes allocated+    -- | CPU time spent running mutator threads.  This does not include+    -- any profiling overhead or initialization.+    , mutatorCpuSeconds :: !Double+    -- | Wall clock time spent running mutator threads.  This does not+    -- include initialization.+    , mutatorWallSeconds :: !Double+    , gcCpuSeconds :: !Double -- ^ CPU time spent running GC+    , gcWallSeconds :: !Double -- ^ Wall clock time spent running GC+    , cpuSeconds :: !Double -- ^ Total CPU time elapsed since program start+    , wallSeconds :: !Double -- ^ Total wall clock time elapsed since start+    -- | Number of bytes copied during GC, minus space held by mutable+    -- lists held by the capabilities.  Can be used with+    -- 'parMaxBytesCopied' to determine how well parallel GC utilized+    -- all cores.+    , parAvgBytesCopied :: !Int64+    -- | Sum of number of bytes copied each GC by the most active GC+    -- thread each GC.  The ratio of 'parAvgBytesCopied' divided by+    -- 'parMaxBytesCopied' approaches 1 for a maximally sequential+    -- run and approaches the number of threads (set by the RTS flag+    -- @-N@) for a maximally parallel run.+    , parMaxBytesCopied :: !Int64+    } deriving (Show, Read)++    {-+    , initCpuSeconds :: !Double+    , initWallSeconds :: !Double+    -}++-- | Retrieves garbage collection and memory statistics as of the last+-- garbage collection.  If you would like your statistics as recent as+-- possible, first run a 'System.Mem.performGC'.+getGCStats :: IO GCStats+getGCStats = allocaBytes (#size GCStats) $ \p -> do+    getGCStats_ p+    bytesAllocated <- (# peek GCStats, bytes_allocated) p+    numGcs <- (# peek GCStats, num_gcs ) p+    numByteUsageSamples <- (# peek GCStats, num_byte_usage_samples ) p+    maxBytesUsed <- (# peek GCStats, max_bytes_used ) p+    cumulativeBytesUsed <- (# peek GCStats, cumulative_bytes_used ) p+    bytesCopied <- (# peek GCStats, bytes_copied ) p+    currentBytesUsed <- (# peek GCStats, current_bytes_used ) p+    currentBytesSlop <- (# peek GCStats, current_bytes_slop) p+    maxBytesSlop <- (# peek GCStats, max_bytes_slop) p+    peakMegabytesAllocated <- (# peek GCStats, peak_megabytes_allocated ) p+    {-+    initCpuSeconds <- (# peek GCStats, init_cpu_seconds) p+    initWallSeconds <- (# peek GCStats, init_wall_seconds) p+    -}+    mutatorCpuSeconds <- (# peek GCStats, mutator_cpu_seconds) p+    mutatorWallSeconds <- (# peek GCStats, mutator_wall_seconds) p+    gcCpuSeconds <- (# peek GCStats, gc_cpu_seconds) p+    gcWallSeconds <- (# peek GCStats, gc_wall_seconds) p+    cpuSeconds <- (# peek GCStats, cpu_seconds) p+    wallSeconds <- (# peek GCStats, wall_seconds) p+    parAvgBytesCopied <- (# peek GCStats, par_avg_bytes_copied) p+    parMaxBytesCopied <- (# peek GCStats, par_max_bytes_copied) p+    return GCStats { .. }++{-++-- Nontrivial to implement: TaskStats needs arbitrarily large+-- amounts of memory, spark stats wants to use SparkCounters+-- but that needs a new rts/ header.++data TaskStats = TaskStats+    { taskMutCpuSeconds :: Int64+    , taskMutWallSeconds :: Int64+    , taskGcCpuSeconds :: Int64+    , taskGcWallSeconds :: Int64+    } deriving (Show, Read)++data SparkStats = SparkStats+    { sparksCreated :: Int64+    , sparksDud :: Int64+    , sparksOverflowed :: Int64+    , sparksConverted :: Int64+    , sparksGcd :: Int64+    , sparksFizzled :: Int64+    } deriving (Show, Read)++-- We also could get per-generation stats, which requires a+-- non-constant but at runtime known about of memory.++-}

@@ -30,6 +30,7 @@         runMainIO, runIO, runIOFastExit, runNonIO,         topHandler, topHandlerFastExit,         reportStackOverflow, reportError,+        flushStdHandles     ) where  #include "HsBaseConfig.h"@@ -68,9 +69,7 @@            case m of                Nothing  -> return ()                Just tid -> throwTo tid (toException UserInterrupt)-      a <- main-      cleanUp-      return a+      main -- hs_exit() will flush     `catch`       topHandler @@ -157,8 +156,8 @@ --  another error, etc.) -- real_handler :: (Int -> IO a) -> SomeException -> IO a-real_handler exit se@(SomeException exn) =-  cleanUp >>+real_handler exit se@(SomeException exn) = do+  flushStdHandles -- before any error output   case cast exn of       Just StackOverflow -> do            reportStackOverflow@@ -184,8 +183,8 @@ -- try to flush stdout/stderr, but don't worry if we fail -- (these handles might have errors, and we don't want to go into -- an infinite loop).-cleanUp :: IO ()-cleanUp = do+flushStdHandles :: IO ()+flushStdHandles = do   hFlush stdout `catchAny` \_ -> return ()   hFlush stderr `catchAny` \_ -> return () 

@@ -32,7 +32,7 @@  import GHC.Base import GHC.Real        (fromIntegral)-import Foreign.C.Types (CInt)+import Foreign.C.Types (CInt(..))  #include "HsBaseConfig.h" 

@@ -17,3 +17,4 @@ isOctDigit      :: Char -> Bool isHexDigit      :: Char -> Bool isAlphaNum      :: Char -> Bool+

@@ -1,4 +1,5 @@ \begin{code}+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP            , NoImplicitPrelude            , BangPatterns

@@ -22,16 +22,12 @@ -- #hide module GHC.Word (     Word(..), Word8(..), Word16(..), Word32(..), Word64(..),-    toEnumError, fromEnumError, succError, predError,     uncheckedShiftL64#,     uncheckedShiftRL64#     ) where  import Data.Bits -#if WORD_SIZE_IN_BITS < 32-import GHC.IntWord32-#endif #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 #endif@@ -47,36 +43,6 @@ import GHC.Float ()     -- for RealFrac methods  --------------------------------------------------------------------------- Helper functions---------------------------------------------------------------------------{-# NOINLINE toEnumError #-}-toEnumError :: (Show a) => String -> Int -> (a,a) -> b-toEnumError inst_ty i bnds =-    error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++-            show i ++-            ") is outside of bounds " ++-            show bnds--{-# NOINLINE fromEnumError #-}-fromEnumError :: (Show a) => String -> a -> b-fromEnumError inst_ty x =-    error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++-            show x ++-            ") is outside of Int's bounds " ++-            show (minBound::Int, maxBound::Int)--{-# NOINLINE succError #-}-succError :: String -> a-succError inst_ty =-    error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"--{-# NOINLINE predError #-}-predError :: String -> a-predError inst_ty =-    error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"-------------------------------------------------------------------------- -- type Word ------------------------------------------------------------------------ @@ -84,8 +50,15 @@ data Word = W# Word# deriving (Eq, Ord)  instance Show Word where-    showsPrec p x = showsPrec p (toInteger x)+    showsPrec _ (W# w) = showWord w +showWord :: Word# -> ShowS+showWord w# cs+ | w# `ltWord#` 10## = C# (chr# (ord# '0'# +# word2Int# w#)) : cs+ | otherwise = case chr# (ord# '0'# +# word2Int# (w# `remWord#` 10##)) of+               c# ->+                   showWord (w# `quotWord#` 10##) (C# c# : cs)+ instance Num Word where     (W# x#) + (W# y#)      = W# (x# `plusWord#` y#)     (W# x#) - (W# y#)      = W# (x# `minusWord#` y#)@@ -148,9 +121,7 @@      -- use unboxed literals for maxBound, because GHC doesn't optimise     -- (fromInteger 0xffffffff :: Word).-#if WORD_SIZE_IN_BITS == 31-    maxBound = W# (int2Word# 0x7FFFFFFF#)-#elif WORD_SIZE_IN_BITS == 32+#if WORD_SIZE_IN_BITS == 32     maxBound = W# (int2Word# 0xFFFFFFFF#) #else     maxBound = W# (int2Word# 0xFFFFFFFFFFFFFFFF#)@@ -175,6 +146,10 @@     (W# x#) `shift` (I# i#)         | i# >=# 0#          = W# (x# `shiftL#` i#)         | otherwise          = W# (x# `shiftRL#` negateInt# i#)+    (W# x#) `shiftL` (I# i#) = W# (x# `shiftL#` i#)+    (W# x#) `unsafeShiftL` (I# i#) = W# (x# `uncheckedShiftL#` i#)+    (W# x#) `shiftR` (I# i#) = W# (x# `shiftRL#` i#)+    (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#)     (W# x#) `rotate` (I# i#)         | i'# ==# 0# = W# x#         | otherwise  = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))@@ -183,6 +158,7 @@         !wsib = WORD_SIZE_IN_BITS#  {- work around preprocessor problem (??) -}     bitSize  _               = WORD_SIZE_IN_BITS     isSigned _               = False+    popCount (W# x#)         = I# (word2Int# (popCnt# x#))  {-# RULES "fromIntegral/Int->Word"  fromIntegral = \(I# x#) -> W# (int2Word# x#)@@ -279,6 +255,11 @@     (W8# x#) `shift` (I# i#)         | i# >=# 0#           = W8# (narrow8Word# (x# `shiftL#` i#))         | otherwise           = W8# (x# `shiftRL#` negateInt# i#)+    (W8# x#) `shiftL` (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))+    (W8# x#) `unsafeShiftL` (I# i#) =+        W8# (narrow8Word# (x# `uncheckedShiftL#` i#))+    (W8# x#) `shiftR` (I# i#) = W8# (x# `shiftRL#` i#)+    (W8# x#) `unsafeShiftR` (I# i#) = W8# (x# `uncheckedShiftRL#` i#)     (W8# x#) `rotate` (I# i#)         | i'# ==# 0# = W8# x#         | otherwise  = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#`@@ -287,6 +268,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)     bitSize  _                = 8     isSigned _                = False+    popCount (W8# x#)         = I# (word2Int# (popCnt8# x#))  {-# RULES "fromIntegral/Word8->Word8"   fromIntegral = id :: Word8 -> Word8@@ -410,6 +392,11 @@     (W16# x#) `shift` (I# i#)         | i# >=# 0#            = W16# (narrow16Word# (x# `shiftL#` i#))         | otherwise            = W16# (x# `shiftRL#` negateInt# i#)+    (W16# x#) `shiftL` (I# i#) = W16# (narrow16Word# (x# `shiftL#` i#))+    (W16# x#) `unsafeShiftL` (I# i#) =+        W16# (narrow16Word# (x# `uncheckedShiftL#` i#))+    (W16# x#) `shiftR` (I# i#) = W16# (x# `shiftRL#` i#)+    (W16# x#) `unsafeShiftR` (I# i#) = W16# (x# `uncheckedShiftRL#` i#)     (W16# x#) `rotate` (I# i#)         | i'# ==# 0# = W16# x#         | otherwise  = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#`@@ -418,6 +405,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)     bitSize  _                = 16     isSigned _                = False+    popCount (W16# x#)        = I# (word2Int# (popCnt16# x#))  {-# RULES "fromIntegral/Word8->Word16"   fromIntegral = \(W8# x#) -> W16# x#@@ -461,103 +449,6 @@ -- type Word32 ------------------------------------------------------------------------ -#if WORD_SIZE_IN_BITS < 32--data Word32 = W32# Word32#--- ^ 32-bit unsigned integer type--instance Eq Word32 where-    (W32# x#) == (W32# y#) = x# `eqWord32#` y#-    (W32# x#) /= (W32# y#) = x# `neWord32#` y#--instance Ord Word32 where-    (W32# x#) <  (W32# y#) = x# `ltWord32#` y#-    (W32# x#) <= (W32# y#) = x# `leWord32#` y#-    (W32# x#) >  (W32# y#) = x# `gtWord32#` y#-    (W32# x#) >= (W32# y#) = x# `geWord32#` y#--instance Num Word32 where-    (W32# x#) + (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `plusInt32#` word32ToInt32# y#))-    (W32# x#) - (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `minusInt32#` word32ToInt32# y#))-    (W32# x#) * (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `timesInt32#` word32ToInt32# y#))-    negate (W32# x#)       = W32# (int32ToWord32# (negateInt32# (word32ToInt32# x#)))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger (S# i#)    = W32# (int32ToWord32# (intToInt32# i#))-    fromInteger (J# s# d#) = W32# (integerToWord32# s# d#)--instance Enum Word32 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word32"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word32"-    toEnum i@(I# i#)-        | i >= 0        = W32# (wordToWord32# (int2Word# i#))-        | otherwise     = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)-    fromEnum x@(W32# x#)-        | x <= fromIntegral (maxBound::Int)-                        = I# (word2Int# (word32ToWord# x#))-        | otherwise     = fromEnumError "Word32" x-    enumFrom            = integralEnumFrom-    enumFromThen        = integralEnumFromThen-    enumFromTo          = integralEnumFromTo-    enumFromThenTo      = integralEnumFromThenTo--instance Integral Word32 where-    quot    x@(W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (x# `quotWord32#` y#)-        | otherwise                 = divZeroError-    rem     x@(W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (x# `remWord32#` y#)-        | otherwise                 = divZeroError-    div     x@(W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (x# `quotWord32#` y#)-        | otherwise                 = divZeroError-    mod     x@(W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (x# `remWord32#` y#)-        | otherwise                 = divZeroError-    quotRem x@(W32# x#) y@(W32# y#)-        | y /= 0                    = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))-        | otherwise                 = divZeroError-    divMod  x@(W32# x#) y@(W32# y#)-        | y /= 0                    = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))-        | otherwise                 = divZeroError-    toInteger x@(W32# x#)-        | x <= fromIntegral (maxBound::Int)  = S# (word2Int# (word32ToWord# x#))-        | otherwise                 = case word32ToInteger# x# of (# s, d #) -> J# s d--instance Bits Word32 where-    {-# INLINE shift #-}--    (W32# x#) .&.   (W32# y#)  = W32# (x# `and32#` y#)-    (W32# x#) .|.   (W32# y#)  = W32# (x# `or32#`  y#)-    (W32# x#) `xor` (W32# y#)  = W32# (x# `xor32#` y#)-    complement (W32# x#)       = W32# (not32# x#)-    (W32# x#) `shift` (I# i#)-        | i# >=# 0#            = W32# (x# `shiftL32#` i#)-        | otherwise            = W32# (x# `shiftRL32#` negateInt# i#)-    (W32# x#) `rotate` (I# i#)-        | i'# ==# 0# = W32# x#-        | otherwise  = W32# ((x# `shiftL32#` i'#) `or32#`-                             (x# `shiftRL32#` (32# -# i'#)))-        where-        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)-    bitSize  _                = 32-    isSigned _                = False--{-# RULES-"fromIntegral/Int->Word32"    fromIntegral = \(I#   x#) -> W32# (int32ToWord32# (intToInt32# x#))-"fromIntegral/Word->Word32"   fromIntegral = \(W#   x#) -> W32# (wordToWord32# x#)-"fromIntegral/Word32->Int"    fromIntegral = \(W32# x#) -> I#   (word2Int# (word32ToWord# x#))-"fromIntegral/Word32->Word"   fromIntegral = \(W32# x#) -> W#   (word32ToWord# x#)-"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32-  #-}--#else - -- Word32 is represented in the same way as Word. #if WORD_SIZE_IN_BITS > 32 -- Operations may assume and must ensure that it holds only values@@ -679,6 +570,11 @@     (W32# x#) `shift` (I# i#)         | i# >=# 0#            = W32# (narrow32Word# (x# `shiftL#` i#))         | otherwise            = W32# (x# `shiftRL#` negateInt# i#)+    (W32# x#) `shiftL` (I# i#) = W32# (narrow32Word# (x# `shiftL#` i#))+    (W32# x#) `unsafeShiftL` (I# i#) =+        W32# (narrow32Word# (x# `uncheckedShiftL#` i#))+    (W32# x#) `shiftR` (I# i#) = W32# (x# `shiftRL#` i#)+    (W32# x#) `unsafeShiftR` (I# i#) = W32# (x# `uncheckedShiftRL#` i#)     (W32# x#) `rotate` (I# i#)         | i'# ==# 0# = W32# x#         | otherwise  = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#`@@ -687,6 +583,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)     bitSize  _                = 32     isSigned _                = False+    popCount (W32# x#)        = I# (word2Int# (popCnt32# x#))  {-# RULES "fromIntegral/Word8->Word32"   fromIntegral = \(W8# x#) -> W32# x#@@ -697,8 +594,6 @@ "fromIntegral/Word32->a"       fromIntegral = \(W32# x#) -> fromIntegral (W# x#)   #-} -#endif- instance Show Word32 where #if WORD_SIZE_IN_BITS < 33     showsPrec p x = showsPrec p (toInteger x)@@ -805,6 +700,10 @@     (W64# x#) `shift` (I# i#)         | i# >=# 0#            = W64# (x# `shiftL64#` i#)         | otherwise            = W64# (x# `shiftRL64#` negateInt# i#)+    (W64# x#) `shiftL` (I# i#) = W64# (x# `shiftL64#` i#)+    (W64# x#) `unsafeShiftL` (I# i#) = W64# (x# `uncheckedShiftL64#` i#)+    (W64# x#) `shiftR` (I# i#) = W64# (x# `shiftRL64#` i#)+    (W64# x#) `unsafeShiftR` (I# i#) = W64# (x# `uncheckedShiftRL64#` i#)     (W64# x#) `rotate` (I# i#)         | i'# ==# 0# = W64# x#         | otherwise  = W64# ((x# `uncheckedShiftL64#` i'#) `or64#`@@ -813,6 +712,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)     bitSize  _                = 64     isSigned _                = False+    popCount (W64# x#)        = I# (word2Int# (popCnt64# x#))  -- give the 64-bit shift operations the same treatment as the 32-bit -- ones (see GHC.Base), namely we wrap them in tests to catch the@@ -909,6 +809,10 @@     (W64# x#) `shift` (I# i#)         | i# >=# 0#            = W64# (x# `shiftL#` i#)         | otherwise            = W64# (x# `shiftRL#` negateInt# i#)+    (W64# x#) `shiftL` (I# i#) = W64# (x# `shiftL#` i#)+    (W64# x#) `unsafeShiftL` (I# i#) = W64# (x# `uncheckedShiftL#` i#)+    (W64# x#) `shiftR` (I# i#) = W64# (x# `shiftRL#` i#)+    (W64# x#) `unsafeShiftR` (I# i#) = W64# (x# `uncheckedShiftRL#` i#)     (W64# x#) `rotate` (I# i#)         | i'# ==# 0# = W64# x#         | otherwise  = W64# ((x# `uncheckedShiftL#` i'#) `or#`@@ -917,6 +821,7 @@         !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)     bitSize  _                = 64     isSigned _                = False+    popCount (W64# x#)        = I# (word2Int# (popCnt64# x#))  {-# RULES "fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x#@@ -948,3 +853,4 @@  instance Read Word64 where     readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]+

@@ -90,16 +90,16 @@ readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit)  -- | Read an unsigned number in octal notation.-readOct :: Num a => ReadS a+readOct :: (Eq a, Num a) => ReadS a readOct = readP_to_S L.readOctP  -- | Read an unsigned number in decimal notation.-readDec :: Num a => ReadS a+readDec :: (Eq a, Num a) => ReadS a readDec = readP_to_S L.readDecP  -- | Read an unsigned number in hexadecimal notation. -- Both upper or lower case letters are allowed.-readHex :: Num a => ReadS a+readHex :: (Eq a, Num a) => ReadS a readHex = readP_to_S L.readHexP   -- | Reads an /unsigned/ 'RealFrac' value,@@ -198,7 +198,7 @@  -- | Shows a /non-negative/ 'Integral' number using the base specified by the -- first argument, and the character representation specified by the second.-showIntAtBase :: Integral a => a -> (Int -> Char) -> a -> ShowS+showIntAtBase :: (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS showIntAtBase base toChr n0 r0   | base <= 1 = error ("Numeric.showIntAtBase: applied to unsupported base " ++ show base)   | n0 <  0   = error ("Numeric.showIntAtBase: applied to negative number " ++ show n0)@@ -213,9 +213,9 @@       r' = c : r  -- | Show /non-negative/ 'Integral' numbers in base 16.-showHex :: Integral a => a -> ShowS+showHex :: (Integral a,Show a) => a -> ShowS showHex = showIntAtBase 16 intToDigit  -- | Show /non-negative/ 'Integral' numbers in base 8.-showOct :: Integral a => a -> ShowS+showOct :: (Integral a, Show a) => a -> ShowS showOct = showIntAtBase 8  intToDigit

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NondecreasingIndentation, ForeignFunctionInterface #-}+{-# LANGUAGE CPP, NondecreasingIndentation, ForeignFunctionInterface, CApiFFI #-}  ----------------------------------------------------------------------------- -- |@@ -15,6 +15,9 @@ -- ----------------------------------------------------------------------------- +#include "HsFFI.h"+#include "HsBaseConfig.h"+ module System.CPUTime          (          getCPUTime,       -- :: IO Integer@@ -40,8 +43,6 @@ import System.IO.Unsafe (unsafePerformIO) #endif -#include "HsBaseConfig.h"- -- For _SC_CLK_TCK #if HAVE_UNISTD_H #include <unistd.h>@@ -110,9 +111,8 @@                 * 1000000)  type CRUsage = ()-foreign import ccall unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt-#else-# if defined(HAVE_TIMES)+foreign import capi unsafe "HsBase.h getrusage" getrusage :: CInt -> Ptr CRUsage -> IO CInt+#elif defined(HAVE_TIMES)     allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do     _ <- times p_tms     u_ticks  <- (#peek struct tms,tms_utime) p_tms :: IO CClock@@ -122,12 +122,11 @@  type CTms = () foreign import ccall unsafe times :: Ptr CTms -> IO CClock-# else+#else     ioException (IOError Nothing UnsupportedOperation                           "getCPUTime"                          "can't get CPU time"                          Nothing)-# endif #endif  #else /* win32 */@@ -184,3 +183,4 @@ foreign import ccall unsafe sysconf :: CInt -> IO CLong #endif #endif /* __GLASGOW_HASKELL__ */+

@@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  System.Console.GetOpt@@ -392,3 +393,4 @@ version messages, checking that file arguments exist, etc.  -}+

@@ -37,7 +37,7 @@ import Control.Exception.Base   ( bracket ) -- import GHC.IO import GHC.IO.Exception-import GHC.IO.Encoding (fileSystemEncoding)+import GHC.IO.Encoding (getFileSystemEncoding) import qualified GHC.Foreign as GHC import Data.List #ifdef mingw32_HOST_OS@@ -127,7 +127,8 @@    getProgArgv p_argc p_argv    p    <- fromIntegral `liftM` peek p_argc    argv <- peek p_argv-   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding)+   enc <- getFileSystemEncoding+   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)  foreign import ccall unsafe "getProgArgv"   getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()@@ -157,7 +158,8 @@  unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0] unpackProgName argv = do-  s <- peekElemOff argv 0 >>= GHC.peekCString fileSystemEncoding+  enc <- getFileSystemEncoding+  s <- peekElemOff argv 0 >>= GHC.peekCString enc   return (basename s) #endif @@ -213,7 +215,7 @@     withCString name $ \s -> do       litstring <- c_getenv s       if litstring /= nullPtr-        then GHC.peekCString fileSystemEncoding litstring+        then getFileSystemEncoding >>= \enc -> GHC.peekCString enc litstring         else ioe_missingEnvVar name  foreign import ccall unsafe "getenv"@@ -273,7 +275,8 @@  setProgArgv :: [String] -> IO (Ptr CString) setProgArgv argv = do-  vs <- mapM (GHC.newCString fileSystemEncoding) argv >>= newArray0 nullPtr+  enc <- getFileSystemEncoding+  vs <- mapM (GHC.newCString enc) argv >>= newArray0 nullPtr   c_setProgArgv (genericLength argv) vs   return vs @@ -323,7 +326,8 @@    pBlock <- getEnvBlock    if pBlock == nullPtr then return []     else do-      stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString fileSystemEncoding)+      enc <- getFileSystemEncoding+      stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)       return (map divvy stuff)  foreign import ccall unsafe "__hscore_environ" @@ -336,3 +340,4 @@     (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)     (name,_:value) -> (name,value) #endif  /* __GLASGOW_HASKELL__ */+

@@ -92,3 +92,4 @@ -- successfully. exitSuccess :: IO a exitSuccess = exitWith ExitSuccess+

@@ -253,12 +253,12 @@ import qualified GHC.IO.FD as FD import GHC.IO.Handle import GHC.IO.Handle.Text ( hGetBufSome, hPutStrLn )-import GHC.IORef import GHC.IO.Exception ( userError ) import GHC.IO.Encoding import GHC.Num import Text.Read import GHC.Show+import GHC.MVar #endif  #ifdef __HUGS__@@ -413,6 +413,13 @@                         [x]    -> return x                         []     -> ioError (userError "Prelude.readIO: no parse")                         _      -> ioError (userError "Prelude.readIO: ambiguous parse")++-- | The Unicode encoding of the current locale+--+-- This is the initial locale encoding: if it has been subsequently changed by+-- 'GHC.IO.Encoding.setLocaleEncoding' this value will not reflect that change.+localeEncoding :: TextEncoding+localeEncoding = initLocaleEncoding #endif  /* __GLASGOW_HASKELL__ */  #ifndef __NHC__@@ -462,15 +469,26 @@ #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) fixIO :: (a -> IO a) -> IO a fixIO k = do-    ref <- newIORef (throw NonTermination)-    ans <- unsafeInterleaveIO (readIORef ref)+    m <- newEmptyMVar+    ans <- unsafeInterleaveIO (takeMVar m)     result <- k ans-    writeIORef ref result+    putMVar m result     return result  -- NOTE: we do our own explicit black holing here, because GHC's lazy -- blackholing isn't enough.  In an infinite loop, GHC may run the IO -- computation a few times before it notices the loop, which is wrong.+--+-- NOTE2: the explicit black-holing with an IORef ran into trouble+-- with multiple threads (see #5421), so now we use an MVar.  I'm+-- actually wondering whether we should use readMVar rather than+-- takeMVar, just in case it ends up being executed multiple times,+-- but even then it would have to be masked to protect against async+-- exceptions.  Ugh.  What we really need here is an IVar, or an+-- atomic readMVar, or even STM.  All these seem like overkill.+--+-- See also System.IO.Unsafe.unsafeFixIO.+-- #endif  #if defined(__NHC__)@@ -573,8 +591,8 @@                               False{-is_socket-}                                True{-is_nonblock-} -         h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-}-                           (Just localeEncoding)+         enc <- getLocaleEncoding+         h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc)           return (filepath, h) #else@@ -634,3 +652,4 @@ -- It follows that an attempt to write to a file (using 'writeFile', for -- example) that was earlier opened by 'readFile' will usually result in -- failure with 'System.IO.Error.isAlreadyInUseError'.+

@@ -475,3 +475,4 @@ catch :: IO a -> (IOError -> IO a) -> IO a catch = New.catch #endif /* !__HUGS__ */+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude #-}  -----------------------------------------------------------------------------@@ -19,10 +20,15 @@    unsafePerformIO,     -- :: IO a -> a    unsafeDupablePerformIO, -- :: IO a -> a    unsafeInterleaveIO,  -- :: IO a -> IO a+   unsafeFixIO,   ) where  #ifdef __GLASGOW_HASKELL__-import GHC.IO      (unsafePerformIO, unsafeInterleaveIO, unsafeDupablePerformIO)+import GHC.Base+import GHC.IO+import GHC.IORef+import GHC.Exception+import Control.Exception #endif  #ifdef __HUGS__@@ -35,3 +41,21 @@ unsafeDupablePerformIO = unsafePerformIO #endif +-- | A slightly faster version of `System.IO.fixIO` that may not be+-- safe to use with multiple threads.  The unsafety arises when used+-- like this:+--+-- >  unsafeFixIO $ \r ->+-- >     forkIO (print r)+-- >     return (...)+--+-- In this case, the child thread will receive a @NonTermination@+-- exception instead of waiting for the value of @r@ to be computed.+--+unsafeFixIO :: (a -> IO a) -> IO a+unsafeFixIO k = do+  ref <- newIORef (throw NonTermination)+  ans <- unsafeDupableInterleaveIO (readIORef ref)+  result <- k ans+  writeIORef ref result+  return result

@@ -67,3 +67,4 @@ #else #error Unknown compiler name #endif+

@@ -1,6 +1,5 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE CPP #-}- #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE ForeignFunctionInterface #-} #endif@@ -37,3 +36,4 @@ #ifdef __NHC__ import NHC.IOExtras (performGC) #endif+

@@ -124,3 +124,4 @@  #include "Typeable.h" INSTANCE_TYPEABLE1(StableName,stableNameTc,"StableName")+

@@ -151,3 +151,4 @@   * It is the value or finalizer of an object whose key is reachable. -}+

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-}+{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface, CApiFFI #-} {-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------@@ -53,7 +53,7 @@ import GHC.IO.Exception import GHC.IO.Device #ifndef mingw32_HOST_OS-import {-# SOURCE #-} GHC.IO.Encoding (fileSystemEncoding)+import {-# SOURCE #-} GHC.IO.Encoding (getFileSystemEncoding) import qualified GHC.Foreign as GHC #endif #elif __HUGS__@@ -199,9 +199,9 @@ peekFilePathLen :: CStringLen -> IO FilePath  #if __GLASGOW_HASKELL__-withFilePath = GHC.withCString fileSystemEncoding-peekFilePath = GHC.peekCString fileSystemEncoding-peekFilePathLen = GHC.peekCStringLen fileSystemEncoding+withFilePath fp f = getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f+peekFilePath fp = getFileSystemEncoding >>= \enc -> GHC.peekCString enc fp+peekFilePathLen fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp #else withFilePath = withCString peekFilePath = peekCString@@ -459,13 +459,13 @@    c_getpid :: IO CPid  #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)-foreign import ccall unsafe "HsBase.h fcntl_read"+foreign import capi unsafe "HsBase.h fcntl"    c_fcntl_read  :: CInt -> CInt -> IO CInt -foreign import ccall unsafe "HsBase.h fcntl_write"+foreign import capi unsafe "HsBase.h fcntl"    c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt -foreign import ccall unsafe "HsBase.h fcntl_lock"+foreign import capi unsafe "HsBase.h fcntl"    c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt  foreign import ccall unsafe "HsBase.h fork"@@ -495,7 +495,7 @@ foreign import ccall unsafe "HsBase.h tcsetattr"    c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt -foreign import ccall unsafe "HsBase.h __hscore_utime"+foreign import capi unsafe "HsBase.h utime"    c_utime :: CString -> Ptr CUtimbuf -> IO CInt  foreign import ccall unsafe "HsBase.h waitpid"@@ -578,3 +578,4 @@ foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt+

@@ -6,3 +6,4 @@ import GHC.Base  puts :: String -> IO ()+

@@ -47,44 +47,44 @@    -- * POSIX data types #if defined(HTYPE_DEV_T)-  CDev,+  CDev(..), #endif #if defined(HTYPE_INO_T)-  CIno,+  CIno(..), #endif #if defined(HTYPE_MODE_T)-  CMode,+  CMode(..), #endif #if defined(HTYPE_OFF_T)-  COff,+  COff(..), #endif #if defined(HTYPE_PID_T)-  CPid,+  CPid(..), #endif #if defined(HTYPE_SSIZE_T)-  CSsize,+  CSsize(..), #endif  #if defined(HTYPE_GID_T)-  CGid,+  CGid(..), #endif #if defined(HTYPE_NLINK_T)-  CNlink,+  CNlink(..), #endif #if defined(HTYPE_UID_T)-  CUid,+  CUid(..), #endif #if defined(HTYPE_CC_T)-  CCc,+  CCc(..), #endif #if defined(HTYPE_SPEED_T)-  CSpeed,+  CSpeed(..), #endif #if defined(HTYPE_TCFLAG_T)-  CTcflag,+  CTcflag(..), #endif #if defined(HTYPE_RLIM_T)-  CRLim,+  CRLim(..), #endif    Fd(..),

@@ -92,3 +92,4 @@ #else timeout n f = fmap Just f #endif /* !__GLASGOW_HASKELL__ */+

@@ -543,3 +543,4 @@ >  prop_ReadS r s = >    readP_to_S (readS_to_P r) s =~. r s -}+

@@ -162,3 +162,4 @@  readS_to_Prec :: (Int -> ReadS a) -> ReadPrec a readS_to_Prec f = P (\n -> readS_to_P (f n))+

@@ -111,12 +111,12 @@ instance PrintfType (IO a) where     spr fmts args = do 	putStr (uprintf fmts (reverse args))-	return undefined+	return (error "PrintfType (IO a): result should not be used.")  instance HPrintfType (IO a) where     hspr hdl fmts args = do 	hPutStr hdl (uprintf fmts (reverse args))-	return undefined+	return (error "HPrintfType (IO a): result should not be used.")  instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where     spr fmts args = \ a -> spr fmts (toUPrintf a : args)@@ -328,3 +328,4 @@ fmterr = perror "formatting string ended prematurely" argerr = perror "argument list ended prematurely" baderr = perror "bad argument"+

@@ -6,7 +6,7 @@ -- Module      :  Text.Read.Lex -- Copyright   :  (c) The University of Glasgow 2002 -- License     :  BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer  :  libraries@haskell.org -- Stability   :  provisional -- Portability :  non-portable (uses Text.ParserCombinators.ReadP)@@ -19,13 +19,13 @@   -- lexing types   ( Lexeme(..)  -- :: *; Show, Eq -  -- lexer      +  -- lexer   , lex         -- :: ReadP Lexeme      Skips leading spaces   , hsLex       -- :: ReadP String   , lexChar     -- :: ReadP Char        Reads just one char, with H98 escapes    , readIntP    -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a-  , readOctP    -- :: Num a => ReadP a +  , readOctP    -- :: Num a => ReadP a   , readDecP    -- :: Num a => ReadP a   , readHexP    -- :: Num a => ReadP a   )@@ -40,8 +40,8 @@ #ifndef __HADDOCK__ import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum ) #endif-import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral, -                 toInteger, (^), (^^), infinity, notANumber )+import GHC.Real( Integral, Rational, (%), fromIntegral,+                 toInteger, (^), infinity, notANumber ) import GHC.List import GHC.Enum( maxBound ) #else@@ -78,17 +78,17 @@  hsLex :: ReadP String -- ^ Haskell lexer: returns the lexed string, rather than the lexeme-hsLex = do skipSpaces +hsLex = do skipSpaces            (s,_) <- gather lexToken            return s  lexToken :: ReadP Lexeme lexToken = lexEOF     +++-           lexLitChar +++ -           lexString  +++ -           lexPunc    +++ -           lexSymbol  +++ -           lexId      +++ +           lexLitChar ++++           lexString  ++++           lexPunc    ++++           lexSymbol  ++++           lexId      +++            lexNumber  @@ -115,7 +115,7 @@ lexSymbol :: ReadP Lexeme lexSymbol =   do s <- munch1 isSymbolChar-     if s `elem` reserved_ops then +     if s `elem` reserved_ops then         return (Punc s)         -- Reserved-ops count as punctuation       else         return (Symbol s)@@ -130,10 +130,10 @@ lexId = lex_nan <++ lex_id   where         -- NaN and Infinity look like identifiers, so-        -- we parse them first.  +        -- we parse them first.     lex_nan = (string "NaN"      >> return (Rat notANumber)) +++               (string "Infinity" >> return (Rat infinity))-  +     lex_id = do c <- satisfy isIdsChar                 s <- munch isIdfChar                 return (Ident (c:s))@@ -168,13 +168,13 @@      if c1 == '\\'        then do c2 <- lexEsc; return (c2, True)        else do return (c1, False)- where + where   lexEsc =     lexEscChar       +++ lexNumeric         +++ lexCntrlChar           +++ lexAscii-  +   lexEscChar =     do c <- get        case c of@@ -189,7 +189,7 @@          '\"' -> return '\"'          '\'' -> return '\''          _    -> pfail-  +   lexNumeric =     do base <- lexBaseChar <++ return 10        n    <- lexInteger base@@ -237,7 +237,7 @@   lexAscii =     do choice          [ (string "SOH" >> return '\SOH') <++-           (string "SO"  >> return '\SO') +           (string "SO"  >> return '\SO')                 -- \SO and \SOH need maximal-munch treatment                 -- See the Haskell report Sect 2.6 @@ -293,7 +293,7 @@    lexStrItem = (lexEmpty >> lexStrItem)                +++ lexCharE-  +   lexEmpty =     do _ <- char '\\'        c <- get@@ -309,11 +309,11 @@ type Digits = [Int]  lexNumber :: ReadP Lexeme-lexNumber +lexNumber   = lexHexOct  <++      -- First try for hex or octal 0x, 0o etc                         -- If that fails, try for a decimal number     lexDecNumber        -- Start with ordinary digits-                + lexHexOct :: ReadP Lexeme lexHexOct   = do  _ <- char '0'@@ -329,7 +329,7 @@                         'O' -> return 8                         'x' -> return 16                         'X' -> return 16-                        _   -> pfail } +                        _   -> pfail }  lexDecNumber :: ReadP Lexeme lexDecNumber =@@ -339,24 +339,20 @@      return (value xs mFrac mExp)  where   value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp-  -  valueFracExp :: Integer -> Maybe Digits -> Maybe Integer ++  valueFracExp :: Integer -> Maybe Digits -> Maybe Integer                -> Lexeme-  valueFracExp a Nothing Nothing        +  valueFracExp a Nothing Nothing     = Int a                                             -- 43   valueFracExp a Nothing (Just exp)     | exp >= 0  = Int (a * (10 ^ exp))                  -- 43e7-    | otherwise = Rat (valExp (fromInteger a) exp)      -- 43e-7-  valueFracExp a (Just fs) mExp -     = case mExp of-         Nothing  -> Rat rat                            -- 4.3-         Just exp -> Rat (valExp rat exp)               -- 4.3e-4-     where-        rat :: Rational-        rat = fromInteger a + frac 10 0 1 fs--  valExp :: Rational -> Integer -> Rational-  valExp rat exp = rat * (10 ^^ exp)+    | otherwise = Rat (a % (10 ^ (-exp)))               -- 43e-7+  valueFracExp a (Just fs) mExp                         -- 4.3[e2]+    = Rat (fracExp (fromMaybe 0 mExp) a fs)+    -- Be a bit more efficient in calculating the Rational.+    -- Instead of calculating the fractional part alone, then+    -- adding the integral part and finally multiplying with+    -- 10 ^ exp if an exponent was given, do it all at once.  lexFrac :: ReadP (Maybe Digits) -- Read the fractional part; fail if it doesn't@@ -370,7 +366,7 @@             exp <- signedExp +++ lexInteger 10             return (Just exp)  where-   signedExp +   signedExp      = do c <- char '-' +++ char '+'           n <- lexInteger 10           return (if c == '-' then -n else n)@@ -400,14 +396,24 @@  where   y' = y * base + fromIntegral x -frac :: Integral a => a -> a -> a -> Digits -> Ratio a-frac _    a b []     = a % b-frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs- where-  a' = a * base + fromIntegral x-  b' = b * base+-- Calculate a Rational from the exponent [of 10 to multiply with],+-- the integral part of the mantissa and the digits of the fractional+-- part. Leaving the calculation of the power of 10 until the end,+-- when we know the effective exponent, saves multiplications.+-- More importantly, this way we need at most one gcd instead of three.+--+-- frac was never used with anything but Integer and base 10, so+-- those are hardcoded now (trivial to change if necessary).+fracExp :: Integer -> Integer -> Digits -> Rational+fracExp exp mant []+  | exp < 0     = mant % (10 ^ (-exp))+  | otherwise   = fromInteger (mant * 10 ^ exp)+fracExp exp mant (d:ds) = exp' `seq` mant' `seq` fracExp exp' mant' ds+  where+    exp'  = exp - 1+    mant' = mant * 10 + fromIntegral d -valDig :: Num a => a -> Char -> Maybe Int+valDig :: (Eq a, Num a) => a -> Char -> Maybe Int valDig 8 c   | '0' <= c && c <= '7' = Just (ord c - ord '0')   | otherwise            = Nothing@@ -435,13 +441,14 @@   do s <- munch1 isDigit      return (val base 0 (map valDigit s)) -readIntP' :: Num a => a -> ReadP a+readIntP' :: (Eq a, Num a) => a -> ReadP a readIntP' base = readIntP base isDigit valDigit  where   isDigit  c = maybe False (const True) (valDig base c)   valDigit c = maybe 0     id           (valDig base c) -readOctP, readDecP, readHexP :: Num a => ReadP a+readOctP, readDecP, readHexP :: (Eq a, Num a) => ReadP a readOctP = readIntP' 8 readDecP = readIntP' 10 readHexP = readIntP' 16+

@@ -47,3 +47,4 @@     showl []     = ']' : s     showl (y:ys) = ',' : showx y (showl ys) #endif+

@@ -36,3 +36,4 @@                 where (value,result) = getTypes undefined                       getTypes x = (x,a x) #endif+

@@ -1,3 +1,4 @@+{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}  -----------------------------------------------------------------------------@@ -25,6 +26,8 @@ --   * In nhc98, the only representation-safe coercions are between Enum --     types with the same range (e.g. Int, Int32, Char, Word32), --     or between a newtype and the type that it wraps.+--+-----------------------------------------------------------------------------  module Unsafe.Coerce (unsafeCoerce) where @@ -41,3 +44,4 @@ #if defined(__HUGS__) import Hugs.IOExts (unsafeCoerce) #endif+

@@ -1,5 +1,5 @@ name:           base-version:        4.4.1.0+version:        4.5.0.0 license:        BSD3 license-file:   LICENSE maintainer:     libraries@haskell.org@@ -38,7 +38,6 @@             Foreign.Concurrent,             GHC.Arr,             GHC.Base,-            GHC.Classes,             GHC.Conc,             GHC.Conc.IO,             GHC.Conc.Signal,@@ -93,6 +92,8 @@             GHC.Read,             GHC.Real,             GHC.ST,+            GHC.Stack,+            GHC.Stats,             GHC.Show,             GHC.Stable,             GHC.Storable,@@ -130,7 +131,6 @@         Control.Monad.ST.Lazy.Safe,         Control.Monad.ST.Lazy.Unsafe,         Control.Monad.ST.Strict,-        Control.Monad.Group         Control.Monad.Zip         Data.Bits,         Data.Bool,

@@ -112,6 +112,16 @@ #ifdef IEEE_FLOATING_POINT  HsInt+isDoubleFinite(HsDouble d)+{+  union stg_ieee754_dbl u;++  u.d = d;++  return u.ieee.exponent != 2047;+}++HsInt isDoubleNaN(HsDouble d) {   union stg_ieee754_dbl u;@@ -190,6 +200,14 @@   HsInt+isFloatFinite(HsFloat f)+{+    union stg_ieee754_flt u;+    u.f = f;+    return u.ieee.exponent != 255;+}++HsInt isFloatNaN(HsFloat f) {     union stg_ieee754_flt u;@@ -426,15 +444,17 @@  #else /* ! IEEE_FLOATING_POINT */ -/* Dummy definitions of predicates - they all return false */-HsInt isDoubleNaN(d) HsDouble d; { return 0; }-HsInt isDoubleInfinite(d) HsDouble d; { return 0; }-HsInt isDoubleDenormalized(d) HsDouble d; { return 0; }-HsInt isDoubleNegativeZero(d) HsDouble d; { return 0; }-HsInt isFloatNaN(f) HsFloat f; { return 0; }-HsInt isFloatInfinite(f) HsFloat f; { return 0; }-HsInt isFloatDenormalized(f) HsFloat f; { return 0; }-HsInt isFloatNegativeZero(f) HsFloat f; { return 0; }+/* Dummy definitions of predicates - they all return "normal" values */+HsInt isDoubleFinite(HsDouble d) { return 1;}+HsInt isDoubleNaN(HsDouble d) { return 0; }+HsInt isDoubleInfinite(HsDouble d) { return 0; }+HsInt isDoubleDenormalized(HsDouble d) { return 0; }+HsInt isDoubleNegativeZero(HsDouble d) { return 0; }+HsInt isFloatFinite(HsFloat f) { return 1; }+HsInt isFloatNaN(HsFloat f) { return 0; }+HsInt isFloatInfinite(HsFloat f) { return 0; }+HsInt isFloatDenormalized(HsFloat f) { return 0; }+HsInt isFloatNegativeZero(HsFloat f) { return 0; }   /* For exotic floating point formats, we can't do much */

@@ -20136,6 +20136,13 @@ _ACEOF  +# We don't use iconv or libcharset on Windows, but if configure finds+# them then it can cause problems. So we don't even try looking if+# we are on Windows.+# See http://www.haskell.org/pipermail/cvs-ghc/2011-September/065980.html+if test "$WINDOWS" = "NO"+then+ # We can't just use AC_SEARCH_LIBS for this, as on OpenBSD the iconv.h # header needs to be included as iconv_open is #define'd to something # else. We therefore use our own FP_SEARCH_LIBS_PROTO, which allows us@@ -20194,10 +20201,7 @@   test "$ac_res" = "none required" || LIBS="$ac_res $LIBS"   EXTRA_LIBS="$EXTRA_LIBS $ac_lib" else-  if test "$WINDOWS" = "NO"-                      then-                          as_fn_error $? "iconv is required on non-Windows platforms" "$LINENO" 5-                      fi+  as_fn_error $? "iconv is required on non-Windows platforms" "$LINENO" 5 fi  # If possible, we use libcharset instead of nl_langinfo(CODESET) to@@ -20252,6 +20256,8 @@ $as_echo "#define HAVE_LIBCHARSET 1" >>confdefs.h       EXTRA_LIBS="$EXTRA_LIBS $ac_lib"+fi+ fi  # Hack - md5.h needs HsFFI.h.  Is there a better way to do this?

@@ -137,6 +137,13 @@ dnl ** can we open files in binary mode? FP_CHECK_CONST([O_BINARY], [#include <fcntl.h>], [0]) +# We don't use iconv or libcharset on Windows, but if configure finds+# them then it can cause problems. So we don't even try looking if+# we are on Windows.+# See http://www.haskell.org/pipermail/cvs-ghc/2011-September/065980.html+if test "$WINDOWS" = "NO"+then+ # We can't just use AC_SEARCH_LIBS for this, as on OpenBSD the iconv.h # header needs to be included as iconv_open is #define'd to something # else. We therefore use our own FP_SEARCH_LIBS_PROTO, which allows us@@ -152,10 +159,7 @@                       iconv_close(cd);],                      iconv,                      [EXTRA_LIBS="$EXTRA_LIBS $ac_lib"],-                     [if test "$WINDOWS" = "NO"-                      then-                          AC_MSG_ERROR([iconv is required on non-Windows platforms])-                      fi])+                     [AC_MSG_ERROR([iconv is required on non-Windows platforms])])  # If possible, we use libcharset instead of nl_langinfo(CODESET) to # determine the current locale's character encoding.@@ -166,6 +170,8 @@     [charset],     [AC_DEFINE([HAVE_LIBCHARSET], [1], [Define to 1 if you have libcharset.])      EXTRA_LIBS="$EXTRA_LIBS $ac_lib"])++fi  # Hack - md5.h needs HsFFI.h.  Is there a better way to do this? CFLAGS="-I../../includes $CFLAGS"

@@ -101,6 +101,8 @@   (T x) `xor`   (T y)   = T (x `xor` y) ; \   complement    (T x)   = T (complement x) ; \   shift         (T x) n = T (shift x n) ; \+  unsafeShiftL  (T x) n = T (unsafeShiftL x n) ; \+  unsafeShiftR  (T x) n = T (unsafeShiftR x n) ; \   rotate        (T x) n = T (rotate x n) ; \   bit                 n = T (bit n) ; \   setBit        (T x) n = T (setBit x n) ; \@@ -108,7 +110,8 @@   complementBit (T x) n = T (complementBit x n) ; \   testBit       (T x) n = testBit x n ; \   bitSize       (T x)   = bitSize x ; \-  isSigned      (T x)   = isSigned x }+  isSigned      (T x)   = isSigned x ; \+  popCount      (T x)   = popCount x }  #define INSTANCE_FRACTIONAL(T) \ instance Fractional T where { \

@@ -201,35 +201,26 @@ INLINE int __hscore_sigismember( sigset_t * set, int s ) { return sigismember(set,s); }--INLINE int-__hscore_utime( const char *file, const struct utimbuf *timep )-{ return utime(file,timep); } #endif -// This is used by dph:Data.Array.Parallel.Arr.BUArr, and shouldn't be INLINE void *-__hscore_memcpy_dst_off( char *dst, int dst_off, char *src, size_t sz )-{ return memcpy(dst+dst_off, src, sz); }--INLINE void * __hscore_memcpy_src_off( char *dst, char *src, int src_off, size_t sz ) { return memcpy(dst, src+src_off, sz); }  INLINE HsInt-__hscore_bufsiz()+__hscore_bufsiz(void) {   return BUFSIZ; }  INLINE int-__hscore_seek_cur()+__hscore_seek_cur(void) {   return SEEK_CUR; }  INLINE int-__hscore_o_binary()+__hscore_o_binary(void) { #if defined(_MSC_VER)   return O_BINARY;@@ -239,7 +230,7 @@ }  INLINE int-__hscore_o_rdonly()+__hscore_o_rdonly(void) { #ifdef O_RDONLY   return O_RDONLY;@@ -629,39 +620,16 @@ 	return (select(nfds,readfds,writefds,exceptfds,timeout)); } -// gettimeofday()-related--#if !defined(__MINGW32__)--INLINE HsInt sizeofTimeVal(void) { return sizeof(struct timeval); }--INLINE HsWord64 getUSecOfDay(void)-{-    struct timeval tv;-    gettimeofday(&tv, (struct timezone *) NULL);-    // Don't forget to cast *before* doing the arithmetic, otherwise-    // the arithmetic happens at the type of tv_sec, which is probably-    // only 'int'.-    return ((HsWord64)tv.tv_sec * 1000000 + (HsWord64)tv.tv_usec);-}--INLINE void setTimevalTicks(struct timeval *p, HsWord64 usecs)-{-    p->tv_sec  = usecs / 1000000;-    p->tv_usec = usecs % 1000000;-}-#endif /* !defined(__MINGW32__) */- #if darwin_HOST_OS // You should not access _environ directly on Darwin in a bundle/shared library. // See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html #include <crt_externs.h>-INLINE char **__hscore_environ() { return *(_NSGetEnviron()); }+INLINE char **__hscore_environ(void) { return *(_NSGetEnviron()); } #else /* ToDo: write a feature test that doesn't assume 'environ' to  *    be in scope at link-time. */ extern char** environ;-INLINE char **__hscore_environ() { return environ; }+INLINE char **__hscore_environ(void) { return environ; } #endif  /* lossless conversions between pointers and integral types */@@ -672,20 +640,6 @@  void errorBelch2(const char*s, char *t); void debugBelch2(const char*s, char *t);--#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)--INLINE int fcntl_read(int fd, int cmd) {-    return fcntl(fd, cmd);-}-INLINE int fcntl_write(int fd, int cmd, long arg) {-    return fcntl(fd, cmd, arg);-}-INLINE int fcntl_lock(int fd, int cmd, struct flock *lock) {-    return fcntl(fd, cmd, lock);-}--#endif  #endif /* __HSBASE_H__ */