base 4.5.1.0 → 4.6.0.0

raw patch · 95 files changed

+2137/−1919 lines, 95 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Applicative.hs +37/−4
• Control/Arrow.hs +7/−0
• Control/Category.hs +0/−3
• Control/Concurrent.hs +32/−4
• Control/Concurrent/Chan.hs +18/−4
• Control/Concurrent/MVar.hs +56/−16
• Control/Concurrent/QSem.hs +1/−0
• Control/Concurrent/QSemN.hs +1/−0
• Control/Concurrent/SampleVar.hs +1/−0
• Control/Exception.hs +3/−0
• Control/Monad.hs +4/−19
• Control/Monad/Fix.hs +0/−6
• Control/Monad/Instances.hs +2/−20
• Control/Monad/ST/Imp.hs +1/−3
• Control/OldException.hs +0/−806
• Data/Bits.hs +79/−15
• Data/Char.hs +1/−0
• Data/Either.hs +11/−3
• Data/Foldable.hs +16/−14
• Data/HashTable.hs +3/−1
• Data/IORef.hs +47/−1
• Data/List.hs +2/−1
• Data/Maybe.hs +2/−3
• Data/Monoid.hs +0/−14
• Data/Ord.hs +11/−0
• Data/STRef.hs +22/−2
• Data/Typeable.hs +0/−1
• Data/Typeable/Internal.hs +7/−3
• Data/Unique.hs +14/−8
• Foreign/C/Error.hs +1/−1
• Foreign/C/String.hs +1/−0
• Foreign/Marshal/Error.hs +1/−1
• Foreign/Ptr.hs +0/−3
• Foreign/Storable.hs +0/−1
• GHC/Arr.lhs +6/−0
• GHC/Base.lhs +31/−46
• GHC/Char.hs +15/−0
• GHC/Conc.lhs +1/−0
• GHC/Conc/Sync.lhs +34/−25
• GHC/Conc/Windows.hs +19/−5
• GHC/Desugar.hs +0/−2
• GHC/Enum.lhs +39/−21
• GHC/Environment.hs +11/−3
• GHC/Err.lhs +5/−2
• GHC/Event/Clock.hsc +69/−11
• GHC/Event/IntMap.hs +1/−3
• GHC/Event/Manager.hs +4/−4
• GHC/Event/Thread.hs +7/−1
• GHC/Exception.lhs +2/−0
• GHC/Exts.hs +3/−12
• GHC/Float.lhs +8/−6
• GHC/ForeignPtr.hs +34/−5
• GHC/GHCi.hs +44/−0
• GHC/Generics.hs +271/−0
• GHC/IO/Encoding/CodePage.hs +12/−2
• GHC/IO/Encoding/Failure.hs +1/−0
• GHC/IO/FD.hs +43/−36
• GHC/IP.hs +14/−0
• GHC/Int.hs +61/−26
• GHC/MVar.hs +0/−1
• GHC/Num.lhs +22/−12
• GHC/Read.lhs +12/−25
• GHC/Real.lhs +75/−4
• GHC/ST.lhs +0/−4
• GHC/Show.lhs +21/−20
• GHC/Stable.lhs +1/−1
• GHC/Stats.hsc +19/−6
• GHC/TopHandler.lhs +0/−8
• GHC/TypeLits.hs +187/−0
• GHC/Unicode.hs +2/−45
• GHC/Weak.lhs +1/−1
• GHC/Word.hs +45/−145
• Numeric.hs +2/−3
• Prelude.hs +1/−1
• System/CPUTime.hsc +13/−2
• System/Environment.hs +77/−46
• System/Environment/ExecutablePath.hsc +172/−0
• System/IO/Error.hs +2/−20
• System/Mem/Weak.hs +4/−3
• System/Posix/Internals.hs +41/−21
• System/Posix/Types.hs +2/−2
• System/Timeout.hs +4/−7
• Text/ParserCombinators/ReadP.hs +0/−2
• Text/Read.hs +13/−0
• Text/Read/Lex.hs +31/−97
• Unsafe/Coerce.hs +4/−1
• base.cabal +8/−3
• cbits/DarwinUtils.c +21/−0
• cbits/Win32Utils.c +14/−10
• cbits/selectUtils.c +0/−3
• configure +187/−154
• configure.ac +2/−0
• include/CTypes.h +6/−0
• include/HsBase.h +14/−93
• include/HsBaseConfig.h +18/−12

@@ -48,9 +48,8 @@ import Prelude hiding (id,(.))  import Control.Category-import Control.Arrow (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>)))+import Control.Arrow import Control.Monad (liftM, ap, MonadPlus(..))-import Control.Monad.Instances () #ifndef __NHC__ import Control.Monad.ST.Safe (ST) import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)@@ -58,6 +57,16 @@ import Data.Functor ((<$>), (<$)) import Data.Monoid (Monoid(..)) +import Text.ParserCombinators.ReadP+#ifndef __NHC__+  (ReadP)+#else+  (ReadPN)+#define ReadP (ReadPN b)+#endif++import Text.ParserCombinators.ReadPrec (ReadPrec)+ #ifdef __GLASGOW_HASKELL__ import GHC.Conc (STM, retry, orElse) #endif@@ -157,8 +166,8 @@  instance Alternative Maybe where     empty = Nothing-    Nothing <|> p = p-    Just x <|> _ = Just x+    Nothing <|> r = r+    l       <|> _ = l  instance Applicative [] where     pure = return@@ -204,6 +213,30 @@     pure          = Right     Left  e <*> _ = Left e     Right f <*> r = fmap f r++instance Applicative ReadP where+    pure = return+    (<*>) = ap++instance Alternative ReadP where+    empty = mzero+    (<|>) = mplus++instance Applicative ReadPrec where+    pure = return+    (<*>) = ap++instance Alternative ReadPrec where+    empty = mzero+    (<|>) = mplus++instance Arrow a => Applicative (ArrowMonad a) where+   pure x = ArrowMonad (arr (const x))+   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))++instance ArrowPlus a => Alternative (ArrowMonad a) where+   empty = ArrowMonad zeroArrow+   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)  -- new instances 

@@ -296,10 +296,17 @@  newtype ArrowMonad a b = ArrowMonad (a () b) +instance Arrow a => Functor (ArrowMonad a) where+    fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f+ instance ArrowApply a => Monad (ArrowMonad a) where     return x = ArrowMonad (arr (\_ -> x))     ArrowMonad m >>= f = ArrowMonad $         m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app++instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where+   mzero = ArrowMonad zeroArrow+   ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y)  -- | Any instance of 'ArrowApply' can be made into an instance of --   'ArrowChoice' by defining 'left' = 'leftApp'.

@@ -40,10 +40,7 @@  instance Category (->) where     id = Prelude.id-#ifndef __HADDOCK__--- Haddock 1.x cannot parse this:     (.) = (Prelude..)-#endif  -- | Right-to-left composition (<<<) :: Category cat => cat b c -> cat a b -> cat a c

@@ -6,6 +6,9 @@            , ScopedTypeVariables   #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+-- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN+-- and Control.Concurrent.SampleVar imports.  ----------------------------------------------------------------------------- -- |@@ -36,6 +39,7 @@          forkIO, #ifdef __GLASGOW_HASKELL__+        forkFinally,         forkIOWithUnmask,         killThread,         throwTo,@@ -45,6 +49,7 @@         forkOn,         forkOnWithUnmask,         getNumCapabilities,+        setNumCapabilities,         threadCapability,          -- * Scheduling@@ -88,6 +93,9 @@         runInUnboundThread, #endif +        -- * Weak references to ThreadIds+        mkWeakThreadId,+         -- * GHC's implementation of concurrency          -- |This section describes features specific to GHC's@@ -201,10 +209,31 @@ Haskell threads. -} +-- | fork a thread and call the supplied function when the thread is about+-- to terminate, with an exception or a returned value.  The function is+-- called with asynchronous exceptions masked.+--+-- > forkFinally action and_then =+-- >   mask $ \restore ->+-- >     forkIO $ try (restore action) >>= and_then+--+-- This function is useful for informing the parent when a child+-- terminates, for example.+--+forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinally action and_then =+  mask $ \restore ->+    forkIO $ try (restore action) >>= and_then++-- -----------------------------------------------------------------------------+-- Merging streams+ #ifndef __HUGS__ max_buff_size :: Int max_buff_size = 1 +{-# DEPRECATED mergeIO "Control.Concurrent.mergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}+{-# DEPRECATED nmergeIO "Control.Concurrent.nmergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-} mergeIO :: [a] -> [a] -> IO [a] nmergeIO :: [[a]] -> IO [a] @@ -594,11 +623,10 @@ >   myForkIO :: IO () -> IO (MVar ()) >   myForkIO io = do >     mvar <- newEmptyMVar->     forkIO (io `finally` putMVar mvar ())+>     forkFinally io (\_ -> putMVar mvar ()) >     return mvar -      Note that we use 'finally' from the-      "Control.Exception" module to make sure that the+      Note that we use 'forkFinally' to make sure that the       'MVar' is written to even if the thread dies or       is killed for some reason. @@ -623,7 +651,7 @@ >        mvar <- newEmptyMVar >        childs <- takeMVar children >        putMVar children (mvar:childs)->        forkIO (io `finally` putMVar mvar ())+>        forkFinally io (\_ -> putMVar mvar ()) > >     main = >       later waitForChildren $

@@ -45,21 +45,26 @@  #include "Typeable.h" +#define _UPK_(x) {-# UNPACK #-} !(x)+ -- A channel is represented by two @MVar@s keeping track of the two ends -- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s -- are used to handle consumers trying to read from an empty channel.  -- |'Chan' is an abstract type representing an unbounded FIFO channel. data Chan a- = Chan (MVar (Stream a))-        (MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar+ = Chan _UPK_(MVar (Stream a))+        _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar    deriving Eq  INSTANCE_TYPEABLE1(Chan,chanTc,"Chan")  type Stream a = MVar (ChItem a) -data ChItem a = ChItem a (Stream a)+data ChItem a = ChItem a _UPK_(Stream a)+  -- benchmarks show that unboxing the MVar here is worthwhile, because+  -- although it leads to higher allocation, the channel data takes up+  -- less space and is therefore quicker to GC.  -- See the Concurrent Haskell paper for a diagram explaining the -- how the different channel operations proceed.@@ -102,11 +107,20 @@ -- |Read the next value from the 'Chan'. readChan :: Chan a -> IO a readChan (Chan readVar _) = do-  modifyMVar readVar $ \read_end -> do+  modifyMVarMasked readVar $ \read_end -> do -- Note [modifyMVarMasked]     (ChItem val new_read_end) <- readMVar read_end         -- Use readMVar here, not takeMVar,         -- else dupChan doesn't work     return (new_read_end, val)++-- Note [modifyMVarMasked]+-- This prevents a theoretical deadlock if an asynchronous exception+-- happens during the readMVar while the MVar is empty.  In that case+-- the read_end MVar will be left empty, and subsequent readers will+-- deadlock.  Using modifyMVarMasked prevents this.  The deadlock can+-- be reproduced, but only by expanding readMVar and inserting an+-- artificial yield between its takeMVar and putMVar operations.+  -- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to -- either channel from then on will be available from both.  Hence this creates

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# LANGUAGE CPP, NoImplicitPrelude, UnboxedTuples, MagicHash #-}  ----------------------------------------------------------------------------- -- |@@ -124,20 +124,23 @@ module Control.Concurrent.MVar         (           -- * @MVar@s-          MVar          -- abstract-        , newEmptyMVar  -- :: IO (MVar a)-        , newMVar       -- :: a -> IO (MVar a)-        , takeMVar      -- :: MVar a -> IO a-        , putMVar       -- :: MVar a -> a -> IO ()-        , readMVar      -- :: MVar a -> IO a-        , swapMVar      -- :: MVar a -> a -> IO a-        , tryTakeMVar   -- :: MVar a -> IO (Maybe a)-        , tryPutMVar    -- :: MVar a -> a -> IO Bool-        , isEmptyMVar   -- :: MVar a -> IO Bool-        , withMVar      -- :: MVar a -> (a -> IO b) -> IO b-        , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()-        , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b+          MVar+        , newEmptyMVar+        , newMVar+        , takeMVar+        , putMVar+        , readMVar+        , swapMVar+        , tryTakeMVar+        , tryPutMVar+        , isEmptyMVar+        , withMVar+        , modifyMVar_+        , modifyMVar+        , modifyMVarMasked_+        , modifyMVarMasked #ifndef __HUGS__+        , mkWeakMVar         , addMVarFinalizer -- :: MVar a -> IO () -> IO () #endif     ) where@@ -149,9 +152,11 @@ #endif  #ifdef __GLASGOW_HASKELL__-import GHC.MVar ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,-                  tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer+import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,+                  tryTakeMVar, tryPutMVar, isEmptyMVar                 )+import qualified GHC.MVar+import GHC.Weak #endif  #ifdef __GLASGOW_HASKELL__@@ -232,3 +237,38 @@     (a',b) <- restore (io a) `onException` putMVar m a     putMVar m a'     return b++{-|+  Like 'modifyMVar_', but the @IO@ action in the second argument is executed with+  asynchronous exceptions masked.+-}+{-# INLINE modifyMVarMasked_ #-}+modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVarMasked_ m io =+  mask_ $ do+    a  <- takeMVar m+    a' <- io a `onException` putMVar m a+    putMVar m a'++{-|+  Like 'modifyMVar', but the @IO@ action in the second argument is executed with+  asynchronous exceptions masked.+-}+{-# INLINE modifyMVarMasked #-}+modifyMVarMasked :: MVar a -> (a -> IO (a,b)) -> IO b+modifyMVarMasked m io =+  mask_ $ do+    a      <- takeMVar m+    (a',b) <- io a `onException` putMVar m a+    putMVar m a'+    return b++{-# DEPRECATED addMVarFinalizer "use mkWeakMVar instead" #-}+addMVarFinalizer :: MVar a -> IO () -> IO ()+addMVarFinalizer = GHC.MVar.addMVarFinalizer++-- | Make a 'Weak' pointer to an 'MVar', using the second argument as+-- a finalizer to run when 'MVar' is garbage-collected+mkWeakMVar :: MVar a -> IO () -> IO (Weak (MVar a))+mkWeakMVar m@(MVar m#) f = IO $ \s ->+  case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)

@@ -19,6 +19,7 @@ -----------------------------------------------------------------------------  module Control.Concurrent.QSem+        {-# DEPRECATED "Control.Concurrent.QSem will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}         ( -- * Simple Quantity Semaphores           QSem,         -- abstract           newQSem,      -- :: Int  -> IO QSem

@@ -20,6 +20,7 @@ -----------------------------------------------------------------------------  module Control.Concurrent.QSemN+        {-# DEPRECATED "Control.Concurrent.QSemN will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}         (  -- * General Quantity Semaphores           QSemN,        -- abstract           newQSemN,     -- :: Int   -> IO QSemN

@@ -19,6 +19,7 @@ -----------------------------------------------------------------------------  module Control.Concurrent.SampleVar+        {-# DEPRECATED "Control.Concurrent.SampleVar will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}        (          -- * Sample Variables          SampleVar,         -- :: type _ =

@@ -164,6 +164,9 @@ -- | You need this when using 'catches'. data Handler a = forall e . Exception e => Handler (e -> IO a) +instance Functor Handler where+     fmap f (Handler h) = Handler (fmap f . h)+ {- | Sometimes you want to catch two different sorts of exception. You could do something like

@@ -190,25 +190,10 @@  -- | @'forever' act@ repeats the action infinitely. forever     :: (Monad m) => m a -> m b-{-# INLINABLE forever #-}  -- See Note [Make forever INLINABLE]-forever a   = a >> forever a--{- Note [Make forever INLINABLE]--If you say   x = forever a-you'll get   x = a >> a >> a >> a >> ... etc ...-and that can make a massive space leak (see Trac #5205)--In some monads, where (>>) is expensive, this might be the right-thing, but not in the IO monad.  We want to specialise 'forever' for-the IO monad, so that eta expansion happens and there's no space leak.-To achieve this we must make forever INLINABLE, so that it'll get-specialised at call sites.--Still delicate, though, because it depends on optimisation.  But there-really is a space/time tradeoff here, and only optimisation reveals-the "right" answer.--}+{-# INLINE forever #-}+forever a   = let a' = a >> a' in a'+-- Use explicit sharing here, as it is prevents a space leak regardless of+-- optimizations.  -- | @'void' value@ discards or ignores the result of evaluation, such as the return value of an 'IO' action. void :: Functor f => f a -> f ()

@@ -27,7 +27,6 @@  import Prelude import System.IO-import Control.Monad.Instances () import Data.Function (fix) #ifdef __HUGS__ import Hugs.Prelude (MonadFix(mfix))@@ -65,23 +64,18 @@  -- Instances of MonadFix for Prelude monads --- Maybe: instance MonadFix Maybe where     mfix f = let a = f (unJust a) in a              where unJust (Just x) = x                    unJust Nothing  = error "mfix Maybe: Nothing" --- List: instance MonadFix [] where     mfix f = case fix (f . head) of                []    -> []                (x:_) -> x : mfix (tail . f) --- IO: instance MonadFix IO where     mfix = fixIO ---- Prelude types with Monad instances in Control.Monad.Instances  instance MonadFix ((->) r) where     mfix f = \ r -> let a = f a r in a

@@ -13,29 +13,11 @@ -- Stability   :  provisional -- Portability :  portable --+-- /This module is DEPRECATED and will be removed in the future!/+-- -- 'Functor' and 'Monad' instances for @(->) r@ and -- 'Functor' instances for @(,) a@ and @'Either' a@.  module Control.Monad.Instances (Functor(..),Monad(..)) where  import Prelude--instance Functor ((->) r) where-        fmap = (.)--instance Monad ((->) r) where-        return = const-        f >>= k = \ r -> k (f r) r--instance Functor ((,) a) where-        fmap f (x,y) = (x, f y)--instance Functor (Either a) where-        fmap _ (Left x) = Left x-        fmap f (Right y) = Right (f y)--instance Monad (Either e) where-        return = Right-        Left  l >>= _ = Left l-        Right r >>= k = k r-

@@ -35,9 +35,7 @@         unsafeSTToIO            -- :: ST s a -> IO a     ) where -#if defined(__GLASGOW_HASKELL__)-import Control.Monad.Fix ()-#else+#if !defined(__GLASGOW_HASKELL__) import Control.Monad.Fix #endif 

@@ -1,806 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , ForeignFunctionInterface-           , ExistentialQuantification-  #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif--#include "Typeable.h"---------------------------------------------------------------------------------- |--- Module      :  Control.OldException--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (extended exceptions)------ This module provides support for raising and catching both built-in--- and user-defined exceptions.------ In addition to exceptions thrown by 'IO' operations, exceptions may--- be thrown by pure code (imprecise exceptions) or by external events--- (asynchronous exceptions), but may only be caught in the 'IO' monad.--- For more details, see:------  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,---    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,---    in /PLDI'99/.------  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton---    Jones, Andy Moran and John Reppy, in /PLDI'01/.-----------------------------------------------------------------------------------module Control.OldException {-# DEPRECATED "Future versions of base will not support the old exceptions style. Please switch to extensible exceptions." #-} (--        -- * The Exception type-        Exception(..),          -- instance Eq, Ord, Show, Typeable-        New.IOException,        -- instance Eq, Ord, Show, Typeable-        New.ArithException(..), -- instance Eq, Ord, Show, Typeable-        New.ArrayException(..), -- instance Eq, Ord, Show, Typeable-        New.AsyncException(..), -- instance Eq, Ord, Show, Typeable--        -- * Throwing exceptions-        throwIO,        -- :: Exception -> IO a-        throw,          -- :: Exception -> a-        ioError,        -- :: IOError -> IO a-#ifdef __GLASGOW_HASKELL__-        -- XXX Need to restrict the type of this:-        New.throwTo,        -- :: ThreadId -> Exception -> a-#endif--        -- * Catching Exceptions--        -- |There are several functions for catching and examining-        -- exceptions; all of them may only be used from within the-        -- 'IO' monad.--        -- ** The @catch@ functions-        catch,     -- :: IO a -> (Exception -> IO a) -> IO a-        catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a--        -- ** The @handle@ functions-        handle,    -- :: (Exception -> IO a) -> IO a -> IO a-        handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a--        -- ** The @try@ functions-        try,       -- :: IO a -> IO (Either Exception a)-        tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)--        -- ** The @evaluate@ function-        evaluate,  -- :: a -> IO a--        -- ** The @mapException@ function-        mapException,           -- :: (Exception -> Exception) -> a -> a--        -- ** Exception predicates-        -        -- $preds--        ioErrors,               -- :: Exception -> Maybe IOError-        arithExceptions,        -- :: Exception -> Maybe ArithException-        errorCalls,             -- :: Exception -> Maybe String-        dynExceptions,          -- :: Exception -> Maybe Dynamic-        assertions,             -- :: Exception -> Maybe String-        asyncExceptions,        -- :: Exception -> Maybe AsyncException-        userErrors,             -- :: Exception -> Maybe String--        -- * Dynamic exceptions--        -- $dynamic-        throwDyn,       -- :: Typeable ex => ex -> b-#ifdef __GLASGOW_HASKELL__-        throwDynTo,     -- :: Typeable ex => ThreadId -> ex -> b-#endif-        catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a-        -        -- * Asynchronous Exceptions--        -- $async--        -- ** Asynchronous exception control--        -- |The following two functions allow a thread to control delivery of-        -- asynchronous exceptions during a critical region.--        block,          -- :: IO a -> IO a-        unblock,        -- :: IO a -> IO a--        -- *** Applying @block@ to an exception handler--        -- $block_handler--        -- *** Interruptible operations--        -- $interruptible--        -- * Assertions--        assert,         -- :: Bool -> a -> a--        -- * Utilities--        bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()-        bracket_,       -- :: IO a -> IO b -> IO c -> IO ()-        bracketOnError,--        finally,        -- :: IO a -> IO b -> IO a-        -#ifdef __GLASGOW_HASKELL__-        setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()-        getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())-#endif-  ) where--#ifdef __GLASGOW_HASKELL__-import GHC.Base-import GHC.Show--- import GHC.IO ( IO )-import GHC.IO.Handle.FD ( stdout )-import qualified GHC.IO as New-import qualified GHC.IO.Exception as New-import GHC.Conc hiding (setUncaughtExceptionHandler,-                        getUncaughtExceptionHandler)-import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )-import Foreign.C.String ( CString, withCString )-import GHC.IO.Handle ( hFlush )-#endif--#ifdef __HUGS__-import Prelude          hiding (catch)-import Hugs.Prelude     as New (ExitCode(..))-#endif--import qualified Control.Exception as New-import           Control.Exception ( toException, fromException, throw, block, unblock, mask, evaluate, throwIO )-import System.IO.Error  hiding ( catch, try )-import System.IO.Unsafe (unsafePerformIO)-import Data.Dynamic-import Data.Either-import Data.Maybe--#ifdef __NHC__-import System.IO.Error (catch, ioError)-import IO              (bracket)-import DIOError         -- defn of IOError type---- minimum needed for nhc98 to pretend it has Exceptions-type Exception   = IOError-type IOException = IOError-data ArithException-data ArrayException-data AsyncException--throwIO  :: Exception -> IO a-throwIO   = ioError-throw    :: Exception -> a-throw     = unsafePerformIO . throwIO--evaluate :: a -> IO a-evaluate x = x `seq` return x--ioErrors        :: Exception -> Maybe IOError-ioErrors e       = Just e-arithExceptions :: Exception -> Maybe ArithException-arithExceptions  = const Nothing-errorCalls      :: Exception -> Maybe String-errorCalls       = const Nothing-dynExceptions   :: Exception -> Maybe Dynamic-dynExceptions    = const Nothing-assertions      :: Exception -> Maybe String-assertions       = const Nothing-asyncExceptions :: Exception -> Maybe AsyncException-asyncExceptions  = const Nothing-userErrors      :: Exception -> Maybe String-userErrors (UserError _ s) = Just s-userErrors  _              = Nothing--block   :: IO a -> IO a-block    = id-unblock :: IO a -> IO a-unblock  = id--assert :: Bool -> a -> a-assert True  x = x-assert False _ = throw (UserError "" "Assertion failed")-#endif---------------------------------------------------------------------------------- Catching exceptions---- |This is the simplest of the exception-catching functions.  It--- takes a single argument, runs it, and if an exception is raised--- the \"handler\" is executed, with the value of the exception passed as an--- argument.  Otherwise, the result is returned as normal.  For example:------ >   catch (openFile f ReadMode) --- >       (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))------ For catching exceptions in pure (non-'IO') expressions, see the--- function 'evaluate'.------ Note that due to Haskell\'s unspecified evaluation order, an--- expression may return one of several possible exceptions: consider--- the expression @error \"urk\" + 1 \`div\` 0@.  Does--- 'catch' execute the handler passing--- @ErrorCall \"urk\"@, or @ArithError DivideByZero@?------ The answer is \"either\": 'catch' makes a--- non-deterministic choice about which exception to catch.  If you--- call it again, you might get a different exception back.  This is--- ok, because 'catch' is an 'IO' computation.------ Note that 'catch' catches all types of exceptions, and is generally--- used for \"cleaning up\" before passing on the exception using--- 'throwIO'.  It is not good practice to discard the exception and--- continue, without first checking the type of the exception (it--- might be a 'ThreadKilled', for example).  In this case it is usually better--- to use 'catchJust' and select the kinds of exceptions to catch.------ Also note that the "Prelude" also exports a function called--- 'Prelude.catch' with a similar type to 'Control.OldException.catch',--- except that the "Prelude" version only catches the IO and user--- families of exceptions (as required by Haskell 98).  ------ We recommend either hiding the "Prelude" version of 'Prelude.catch'--- when importing "Control.OldException": ------ > import Prelude hiding (catch)------ or importing "Control.OldException" qualified, to avoid name-clashes:------ > import qualified Control.OldException as C------ and then using @C.catch@-----catch   :: IO a                 -- ^ The computation to run-        -> (Exception -> IO a)  -- ^ Handler to invoke if an exception is raised-        -> IO a--- note: bundling the exceptions is done in the New.Exception--- instance of Exception; see below.-catch = New.catch---- | The function 'catchJust' is like 'catch', but it takes an extra--- argument which is an /exception predicate/, a function which--- selects which type of exceptions we\'re interested in.  There are--- some predefined exception predicates for useful subsets of--- exceptions: 'ioErrors', 'arithExceptions', and so on.  For example,--- to catch just calls to the 'error' function, we could use------ >   result <- catchJust errorCalls thing_to_try handler------ Any other exceptions which are not matched by the predicate--- are re-raised, and may be caught by an enclosing--- 'catch' or 'catchJust'.-catchJust-        :: (Exception -> Maybe b) -- ^ Predicate to select exceptions-        -> IO a                   -- ^ Computation to run-        -> (b -> IO a)            -- ^ Handler-        -> IO a-catchJust p a handler = catch a handler'-  where handler' e = case p e of -                        Nothing -> throw e-                        Just b  -> handler b---- | A version of 'catch' with the arguments swapped around; useful in--- situations where the code for the handler is shorter.  For example:------ >   do handle (\e -> exitWith (ExitFailure 1)) $--- >      ...-handle     :: (Exception -> IO a) -> IO a -> IO a-handle     =  flip catch---- | A version of 'catchJust' with the arguments swapped around (see--- 'handle').-handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a-handleJust p =  flip (catchJust p)---------------------------------------------------------------------------------- 'mapException'---- | This function maps one exception into another as proposed in the--- paper \"A semantics for imprecise exceptions\".---- Notice that the usage of 'unsafePerformIO' is safe here.--mapException :: (Exception -> Exception) -> a -> a-mapException f v = unsafePerformIO (catch (evaluate v)-                                          (\x -> throw (f x)))---------------------------------------------------------------------------------- 'try' and variations.---- | Similar to 'catch', but returns an 'Either' result which is--- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an--- exception was raised and its value is @e@.------ >  try a = catch (Right `liftM` a) (return . Left)------ Note: as with 'catch', it is only polite to use this variant if you intend--- to re-throw the exception after performing whatever cleanup is needed.--- Otherwise, 'tryJust' is generally considered to be better.------ Also note that "System.IO.Error" also exports a function called--- 'System.IO.Error.try' with a similar type to 'Control.OldException.try',--- except that it catches only the IO and user families of exceptions--- (as required by the Haskell 98 @IO@ module).--try :: IO a -> IO (Either Exception a)-try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))---- | A variant of 'try' that takes an exception predicate to select--- which exceptions are caught (c.f. 'catchJust').  If the exception--- does not match the predicate, it is re-thrown.-tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)-tryJust p a = do-  r <- try a-  case r of-        Right v -> return (Right v)-        Left  e -> case p e of-                        Nothing -> throw e-                        Just b  -> return (Left b)---------------------------------------------------------------------------------- Dynamic exceptions---- $dynamic---  #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an--- interface for throwing and catching exceptions of type 'Dynamic'--- (see "Data.Dynamic") which allows exception values of any type in--- the 'Typeable' class to be thrown and caught.---- | Raise any value as an exception, provided it is in the--- 'Typeable' class.-throwDyn :: Typeable exception => exception -> b-#ifdef __NHC__-throwDyn exception = throw (UserError "" "dynamic exception")-#else-throwDyn exception = throw (DynException (toDyn exception))-#endif--#ifdef __GLASGOW_HASKELL__--- | A variant of 'throwDyn' that throws the dynamic exception to an--- arbitrary thread (GHC only: c.f. 'throwTo').-throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()-throwDynTo t exception = New.throwTo t (DynException (toDyn exception))-#endif /* __GLASGOW_HASKELL__ */---- | Catch dynamic exceptions of the required type.  All other--- exceptions are re-thrown, including dynamic exceptions of the wrong--- type.------ When using dynamic exceptions it is advisable to define a new--- datatype to use for your exception type, to avoid possible clashes--- with dynamic exceptions used in other libraries.----catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a-#ifdef __NHC__-catchDyn m k = m        -- can't catch dyn exceptions in nhc98-#else-catchDyn m k = New.catch m handler-  where handler ex = case ex of-                           (DynException dyn) ->-                                case fromDynamic dyn of-                                    Just exception  -> k exception-                                    Nothing -> throw ex-                           _ -> throw ex-#endif---------------------------------------------------------------------------------- Exception Predicates---- $preds--- These pre-defined predicates may be used as the first argument to--- 'catchJust', 'tryJust', or 'handleJust' to select certain common--- classes of exceptions.-#ifndef __NHC__-ioErrors                :: Exception -> Maybe IOError-arithExceptions         :: Exception -> Maybe New.ArithException-errorCalls              :: Exception -> Maybe String-assertions              :: Exception -> Maybe String-dynExceptions           :: Exception -> Maybe Dynamic-asyncExceptions         :: Exception -> Maybe New.AsyncException-userErrors              :: Exception -> Maybe String--ioErrors (IOException e) = Just e-ioErrors _ = Nothing--arithExceptions (ArithException e) = Just e-arithExceptions _ = Nothing--errorCalls (ErrorCall e) = Just e-errorCalls _ = Nothing--assertions (AssertionFailed e) = Just e-assertions _ = Nothing--dynExceptions (DynException e) = Just e-dynExceptions _ = Nothing--asyncExceptions (AsyncException e) = Just e-asyncExceptions _ = Nothing--userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e)-userErrors _ = Nothing-#endif--------------------------------------------------------------------------------- Some Useful Functions---- | When you want to acquire a resource, do some work with it, and--- then release the resource, it is a good idea to use 'bracket',--- because 'bracket' will install the necessary exception handler to--- release the resource in the event that an exception is raised--- during the computation.  If an exception is raised, then 'bracket' will --- re-raise the exception (after performing the release).------ A common example is opening a file:------ > bracket--- >   (openFile "filename" ReadMode)--- >   (hClose)--- >   (\handle -> do { ... })------ The arguments to 'bracket' are in this order so that we can partially apply --- it, e.g.:------ > withFile name mode = bracket (openFile name mode) hClose----#ifndef __NHC__-bracket -        :: IO a         -- ^ computation to run first (\"acquire resource\")-        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")-        -> (a -> IO c)  -- ^ computation to run in-between-        -> IO c         -- returns the value from the in-between computation-bracket before after thing =-  mask $ \restore -> do-    a <- before -    r <- catch -           (restore (thing a))-           (\e -> do { _ <- after a; throw e })-    _ <- after a-    return r-#endif---- | A specialised variant of 'bracket' with just a computation to run--- afterward.--- -finally :: IO a         -- ^ computation to run first-        -> IO b         -- ^ computation to run afterward (even if an exception -                        -- was raised)-        -> IO a         -- returns the value from the first computation-a `finally` sequel =-  mask $ \restore -> do-    r <- catch -             (restore a)-             (\e -> do { _ <- sequel; throw e })-    _ <- sequel-    return r---- | A variant of 'bracket' where the return value from the first computation--- is not required.-bracket_ :: IO a -> IO b -> IO c -> IO c-bracket_ before after thing = bracket before (const after) (const thing)---- | Like bracket, but only performs the final action if there was an --- exception raised by the in-between computation.-bracketOnError-        :: IO a         -- ^ computation to run first (\"acquire resource\")-        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")-        -> (a -> IO c)  -- ^ computation to run in-between-        -> IO c         -- returns the value from the in-between computation-bracketOnError before after thing =-  mask $ \restore -> do-    a <- before -    catch -        (restore (thing a))-        (\e -> do { _ <- after a; throw e })---- -------------------------------------------------------------------------------- Asynchronous exceptions--{- $async-- #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to-external influences, and can be raised at any point during execution.-'StackOverflow' and 'HeapOverflow' are two examples of-system-generated asynchronous exceptions.--The primary source of asynchronous exceptions, however, is-'throwTo':-->  throwTo :: ThreadId -> Exception -> IO ()--'throwTo' (also 'throwDynTo' and 'Control.Concurrent.killThread') allows one-running thread to raise an arbitrary exception in another thread.  The-exception is therefore asynchronous with respect to the target thread,-which could be doing anything at the time it receives the exception.-Great care should be taken with asynchronous exceptions; it is all too-easy to introduce race conditions by the over zealous use of-'throwTo'.--}--{- $block_handler-There\'s an implied 'mask_' around every exception handler in a call-to one of the 'catch' family of functions.  This is because that is-what you want most of the time - it eliminates a common race condition-in starting an exception handler, because there may be no exception-handler on the stack to handle another exception if one arrives-immediately.  If asynchronous exceptions are blocked on entering the-handler, though, we have time to install a new exception handler-before being interrupted.  If this weren\'t the default, one would have-to write something like-->      mask $ \restore ->->           catch (restore (...))->                      (\e -> handler)--If you need to unblock asynchronous exceptions again in the exception-handler, just use 'unblock' as normal.--Note that 'try' and friends /do not/ have a similar default, because-there is no exception handler in this case.  If you want to use 'try'-in an asynchronous-exception-safe way, you will need to use-'mask'.--}--{- $interruptible--Some operations are /interruptible/, which means that they can receive-asynchronous exceptions even in the scope of a 'mask'.  Any function-which may itself block is defined as interruptible; this includes-'Control.Concurrent.MVar.takeMVar'-(but not 'Control.Concurrent.MVar.tryTakeMVar'),-and most operations which perform-some I\/O with the outside world.  The reason for having-interruptible operations is so that we can write things like-->      mask $ \restore -> do->         a <- takeMVar m->         catch (restore (...))->               (\e -> ...)--if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,-then this particular-combination could lead to deadlock, because the thread itself would be-blocked in a state where it can\'t receive any asynchronous exceptions.-With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be-safe in the knowledge that the thread can receive exceptions right up-until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.-Similar arguments apply for other interruptible operations like-'System.IO.openFile'.--}--#if !(__GLASGOW_HASKELL__ || __NHC__)-assert :: Bool -> a -> a-assert True x = x-assert False _ = throw (AssertionFailed "")-#endif---#ifdef __GLASGOW_HASKELL__-{-# NOINLINE uncaughtExceptionHandler #-}-uncaughtExceptionHandler :: IORef (Exception -> IO ())-uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)-   where-      defaultHandler :: Exception -> IO ()-      defaultHandler ex = do-         (hFlush stdout) `New.catchAny` (\ _ -> return ())-         let msg = case ex of-               Deadlock    -> "no threads to run:  infinite loop or deadlock?"-               ErrorCall s -> s-               other       -> showsPrec 0 other ""-         withCString "%s" $ \cfmt ->-          withCString msg $ \cmsg ->-            errorBelch cfmt cmsg---- don't use errorBelch() directly, because we cannot call varargs functions--- using the FFI.-foreign import ccall unsafe "HsBase.h errorBelch2"-   errorBelch :: CString -> CString -> IO ()--setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()-setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler--getUncaughtExceptionHandler :: IO (Exception -> IO ())-getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler-#endif---- --------------------------------------------------------------------------- Exception datatype and operations---- |The type of exceptions.  Every kind of system-generated exception--- has a constructor in the 'Exception' type, and values of other--- types may be injected into 'Exception' by coercing them to--- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions:--- "Control.OldException\#DynamicExceptions").-data Exception-  = ArithException      New.ArithException-        -- ^Exceptions raised by arithmetic-        -- operations.  (NOTE: GHC currently does not throw-        -- 'ArithException's except for 'DivideByZero').-  | ArrayException      New.ArrayException-        -- ^Exceptions raised by array-related-        -- operations.  (NOTE: GHC currently does not throw-        -- 'ArrayException's).-  | AssertionFailed     String-        -- ^This exception is thrown by the-        -- 'assert' operation when the condition-        -- fails.  The 'String' argument contains the-        -- location of the assertion in the source program.-  | AsyncException      New.AsyncException-        -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.OldException\#AsynchronousExceptions").-  | BlockedOnDeadMVar-        -- ^The current thread was executing a call to-        -- 'Control.Concurrent.MVar.takeMVar' that could never return,-        -- because there are no other references to this 'MVar'.-  | BlockedIndefinitely-        -- ^The current thread was waiting to retry an atomic memory transaction-        -- that could never become possible to complete because there are no other-        -- threads referring to any of the TVars involved.-  | NestedAtomically-        -- ^The runtime detected an attempt to nest one STM transaction-        -- inside another one, presumably due to the use of -        -- 'unsafePeformIO' with 'atomically'.-  | Deadlock-        -- ^There are no runnable threads, so the program is-        -- deadlocked.  The 'Deadlock' exception is-        -- raised in the main thread only (see also: "Control.Concurrent").-  | DynException        Dynamic-        -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.OldException\#DynamicExceptions").-  | ErrorCall           String-        -- ^The 'ErrorCall' exception is thrown by 'error'.  The 'String'-        -- argument of 'ErrorCall' is the string passed to 'error' when it was-        -- called.-  | ExitException       New.ExitCode-        -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and-        -- 'System.Exit.exitFailure').  The 'ExitCode' argument is the value passed -        -- to 'System.Exit.exitWith'.  An unhandled 'ExitException' exception in the-        -- main thread will cause the program to be terminated with the given -        -- exit code.-  | IOException         New.IOException-        -- ^These are the standard IO exceptions generated by-        -- Haskell\'s @IO@ operations.  See also "System.IO.Error".-  | NoMethodError       String-        -- ^An attempt was made to invoke a class method which has-        -- no definition in this instance, and there was no default-        -- definition given in the class declaration.  GHC issues a-        -- warning when you compile an instance which has missing-        -- methods.-  | NonTermination-        -- ^The current thread is stuck in an infinite loop.  This-        -- exception may or may not be thrown when the program is-        -- non-terminating.-  | PatternMatchFail    String-        -- ^A pattern matching failure.  The 'String' argument should contain a-        -- descriptive message including the function name, source file-        -- and line number.-  | RecConError         String-        -- ^An attempt was made to evaluate a field of a record-        -- for which no value was given at construction time.  The-        -- 'String' argument gives the location of the-        -- record construction in the source program.-  | RecSelError         String-        -- ^A field selection was attempted on a constructor that-        -- doesn\'t have the requested field.  This can happen with-        -- multi-constructor records when one or more fields are-        -- missing from some of the constructors.  The-        -- 'String' argument gives the location of the-        -- record selection in the source program.-  | RecUpdError         String-        -- ^An attempt was made to update a field in a record,-        -- where the record doesn\'t have the requested field.  This can-        -- only occur with multi-constructor records, when one or more-        -- fields are missing from some of the constructors.  The-        -- 'String' argument gives the location of the-        -- record update in the source program.-INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")---- helper type for simplifying the type casting logic below-data Caster = forall e . New.Exception e => Caster (e -> Exception)--instance New.Exception Exception where-  -- We need to collect all the sorts of exceptions that used to be-  -- bundled up into the Exception type, and rebundle them for-  -- legacy handlers.-  fromException exc0 = foldr tryCast Nothing casters where-    tryCast (Caster f) e = case fromException exc0 of-      Just exc -> Just (f exc)-      _        -> e-    casters =-      [Caster (\exc -> ArithException exc),-       Caster (\exc -> ArrayException exc),-       Caster (\(New.AssertionFailed err) -> AssertionFailed err),-       Caster (\exc -> AsyncException exc),-       Caster (\New.BlockedIndefinitelyOnMVar -> BlockedOnDeadMVar),-       Caster (\New.BlockedIndefinitelyOnSTM -> BlockedIndefinitely),-       Caster (\New.NestedAtomically -> NestedAtomically),-       Caster (\New.Deadlock -> Deadlock),-       Caster (\exc -> DynException exc),-       Caster (\(New.ErrorCall err) -> ErrorCall err),-       Caster (\exc -> ExitException exc),-       Caster (\exc -> IOException exc),-       Caster (\(New.NoMethodError err) -> NoMethodError err),-       Caster (\New.NonTermination -> NonTermination),-       Caster (\(New.PatternMatchFail err) -> PatternMatchFail err),-       Caster (\(New.RecConError err) -> RecConError err),-       Caster (\(New.RecSelError err) -> RecSelError err),-       Caster (\(New.RecUpdError err) -> RecUpdError err),-       -- Anything else gets taken as a Dynamic exception. It's-       -- important that we put all exceptions into the old Exception-       -- type somehow, or throwing a new exception wouldn't cause-       -- the cleanup code for bracket, finally etc to happen.-       Caster (\exc -> DynException (toDyn (exc :: New.SomeException)))]--  -- Unbundle exceptions.-  toException (ArithException exc)   = toException exc-  toException (ArrayException exc)   = toException exc-  toException (AssertionFailed err)  = toException (New.AssertionFailed err)-  toException (AsyncException exc)   = toException exc-  toException BlockedOnDeadMVar      = toException New.BlockedIndefinitelyOnMVar-  toException BlockedIndefinitely    = toException New.BlockedIndefinitelyOnSTM-  toException NestedAtomically       = toException New.NestedAtomically-  toException Deadlock               = toException New.Deadlock-  -- If a dynamic exception is a SomeException then resurrect it, so-  -- that bracket, catch+throw etc rethrow the same exception even-  -- when the exception is in the new style.-  -- If it's not a SomeException, then just throw the Dynamic.-  toException (DynException exc)     = case fromDynamic exc of-                                       Just exc' -> exc'-                                       Nothing -> toException exc-  toException (ErrorCall err)        = toException (New.ErrorCall err)-  toException (ExitException exc)    = toException exc-  toException (IOException exc)      = toException exc-  toException (NoMethodError err)    = toException (New.NoMethodError err)-  toException NonTermination         = toException New.NonTermination-  toException (PatternMatchFail err) = toException (New.PatternMatchFail err)-  toException (RecConError err)      = toException (New.RecConError err)-  toException (RecSelError err)      = toException (New.RecSelError err)-  toException (RecUpdError err)      = toException (New.RecUpdError err)--instance Show Exception where-  showsPrec _ (IOException err)          = shows err-  showsPrec _ (ArithException err)       = shows err-  showsPrec _ (ArrayException err)       = shows err-  showsPrec _ (ErrorCall err)            = showString err-  showsPrec _ (ExitException err)        = showString "exit: " . shows err-  showsPrec _ (NoMethodError err)        = showString err-  showsPrec _ (PatternMatchFail err)     = showString err-  showsPrec _ (RecSelError err)          = showString err-  showsPrec _ (RecConError err)          = showString err-  showsPrec _ (RecUpdError err)          = showString err-  showsPrec _ (AssertionFailed err)      = showString err-  showsPrec _ (DynException err)         = showString "exception :: " . showsTypeRep (dynTypeRep err)-  showsPrec _ (AsyncException e)         = shows e-  showsPrec p BlockedOnDeadMVar          = showsPrec p New.BlockedIndefinitelyOnMVar-  showsPrec p BlockedIndefinitely        = showsPrec p New.BlockedIndefinitelyOnSTM-  showsPrec p NestedAtomically           = showsPrec p New.NestedAtomically-  showsPrec p NonTermination             = showsPrec p New.NonTermination-  showsPrec p Deadlock                   = showsPrec p New.Deadlock--instance Eq Exception where-  IOException e1      == IOException e2      = e1 == e2-  ArithException e1   == ArithException e2   = e1 == e2-  ArrayException e1   == ArrayException e2   = e1 == e2-  ErrorCall e1        == ErrorCall e2        = e1 == e2-  ExitException e1    == ExitException e2    = e1 == e2-  NoMethodError e1    == NoMethodError e2    = e1 == e2-  PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2-  RecSelError e1      == RecSelError e2      = e1 == e2-  RecConError e1      == RecConError e2      = e1 == e2-  RecUpdError e1      == RecUpdError e2      = e1 == e2-  AssertionFailed e1  == AssertionFailed e2  = e1 == e2-  DynException _      == DynException _      = False -- incomparable-  AsyncException e1   == AsyncException e2   = e1 == e2-  BlockedOnDeadMVar   == BlockedOnDeadMVar   = True-  NonTermination      == NonTermination      = True-  NestedAtomically    == NestedAtomically    = True-  Deadlock            == Deadlock            = True-  _                   == _                   = False-

@@ -36,8 +36,11 @@     unsafeShiftL, unsafeShiftR,  -- :: a -> Int -> a     rotateL, rotateR,  -- :: a -> Int -> a     popCount           -- :: a -> Int-  )+  ), +  bitDefault,+  testBitDefault,+  popCountDefault   -- instance Bits Int   -- instance Bits Integer  ) where@@ -51,6 +54,7 @@ #endif  #ifdef __GLASGOW_HASKELL__+import GHC.Enum import GHC.Num import GHC.Base #endif@@ -72,9 +76,11 @@  Minimal complete definition: '.&.', '.|.', 'xor', 'complement', ('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')),-'bitSize' and 'isSigned'.+'bitSize', 'isSigned', 'testBit', 'bit', and 'popCount'.  The latter three can+be implemented using `testBitDefault', 'bitDefault, and 'popCountDefault', if+@a@ is also an instance of 'Num'. -}-class (Eq a, Num a) => Bits a where+class Eq a => Bits a where     -- | Bitwise \"and\"     (.&.) :: a -> a -> a @@ -155,16 +161,12 @@         value of the argument is ignored -}     isSigned          :: a -> Bool -    {-# INLINE bit #-}     {-# INLINE setBit #-}     {-# INLINE clearBit #-}     {-# INLINE complementBit #-}-    {-# INLINE testBit #-}-    bit i               = 1 `shiftL` i     x `setBit` i        = x .|. bit i     x `clearBit` i      = x .&. complement (bit i)     x `complementBit` i = x `xor` bit i-    x `testBit` i       = (x .&. bit i) /= 0      {-| Shift the argument left by the specified number of bits         (which must be non-negative).@@ -235,19 +237,42 @@     {-| 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-    {-# INLINABLE popCount #-}-    {- This implementation is intentionally naive.  Instances are-       expected to override it with something optimized for their-       size. -} +-- | Default implementation for 'bit'.+--+-- Note that: @bitDefault i = 1 `shiftL` i@+bitDefault :: (Bits a, Num a) => Int -> a+bitDefault i = 1 `shiftL` i+{-# INLINE bitDefault #-}++-- | Default implementation for 'testBit'.+--+-- Note that: @testBitDefault x i = (x .&. bit i) /= 0@+testBitDefault ::  (Bits a, Num a) => a -> Int -> Bool+testBitDefault x i = (x .&. bit i) /= 0+{-# INLINE testBitDefault #-}++-- | Default implementation for 'popCount'.+--+-- This implementation is intentionally naive. Instances are expected to provide+-- an optimized implementation for their size.+popCountDefault :: (Bits a, Num a) => a -> Int+popCountDefault = go 0+ where+   go !c 0 = c+   go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant+{-# INLINABLE popCountDefault #-}+ instance Bits Int where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}  #ifdef __GLASGOW_HASKELL__+    bit     = bitDefault++    testBit = testBitDefault+     (I# x#) .&.   (I# y#)  = I# (word2Int# (int2Word# x# `and#` int2Word# y#))      (I# x#) .|.   (I# y#)  = I# (word2Int# (int2Word# x# `or#`  int2Word# y#))@@ -278,6 +303,8 @@  #else /* !__GLASGOW_HASKELL__ */ +    popCount               = popCountDefault+ #ifdef __HUGS__     (.&.)                  = primAndInt     (.|.)                  = primOrInt@@ -294,6 +321,8 @@     complement             = nhc_primIntCompl     shiftL                 = nhc_primIntLsh     shiftR                 = nhc_primIntRsh+    bit                    = bitDefault+    testBit                = testBitDefault     bitSize _              = 32 #endif /* __NHC__ */ @@ -318,6 +347,37 @@ foreign import ccall nhc_primIntCompl :: Int -> Int #endif /* __NHC__ */ +#if defined(__GLASGOW_HASKELL__)+instance Bits Word where+    {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}++    (W# x#) .&.   (W# y#)    = W# (x# `and#` y#)+    (W# x#) .|.   (W# y#)    = W# (x# `or#`  y#)+    (W# x#) `xor` (W# y#)    = W# (x# `xor#` y#)+    complement (W# x#)       = W# (x# `xor#` mb#)+        where !(W# mb#) = maxBound+    (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'#)))+        where+        !i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))+        !wsib = WORD_SIZE_IN_BITS#  {- work around preprocessor problem (??) -}+    bitSize  _               = WORD_SIZE_IN_BITS+    isSigned _               = False+    popCount (W# x#)         = I# (word2Int# (popCnt# x#))+    bit                      = bitDefault+    testBit                  = testBitDefault+#endif+ instance Bits Integer where #if defined(__GLASGOW_HASKELL__)    (.&.) = andInteger@@ -345,6 +405,10 @@    shift x i | i >= 0    = x * 2^i              | otherwise = x `div` 2^(-i) #endif++   bit        = bitDefault+   testBit    = testBitDefault+   popCount   = popCountDefault     rotate x i = shift x i   -- since an Integer never wraps around 

@@ -55,6 +55,7 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Arr (Ix)+import GHC.Char import GHC.Real (fromIntegral) import GHC.Show import GHC.Read (Read, readLitChar, lexLitChar)

@@ -1,7 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} #ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif  -----------------------------------------------------------------------------@@ -35,7 +35,6 @@ #endif  import Data.Typeable-import GHC.Generics (Generic)  #ifdef __GLASGOW_HASKELL__ {-@@ -54,7 +53,16 @@ hold a correct value (mnemonic: \"right\" also means \"correct\"). -} data  Either a b  =  Left a | Right b-  deriving (Eq, Ord, Read, Show, Generic)+  deriving (Eq, Ord, Read, Show)++instance Functor (Either a) where+    fmap _ (Left x) = Left x+    fmap f (Right y) = Right (f y)++instance Monad (Either e) where+    return = Right+    Left  l >>= _ = Left l+    Right r >>= k = k r  -- | Case analysis for the 'Either' type. -- If the value is @'Left' a@, apply the first function to @a@;

@@ -25,8 +25,6 @@     -- * Folds     Foldable(..),     -- ** Special biased folds-    foldr',-    foldl',     foldrM,     foldlM,     -- ** Folding actions@@ -64,6 +62,7 @@                 elem, notElem, concat, concatMap, and, or, any, all,                 sum, product, maximum, minimum) import qualified Prelude (foldl, foldr, foldl1, foldr1)+import qualified Data.List as List (foldl') import Control.Applicative import Control.Monad (MonadPlus(..)) import Data.Maybe (fromMaybe, listToMaybe)@@ -124,12 +123,26 @@     foldr :: (a -> b -> b) -> b -> t a -> b     foldr f z t = appEndo (foldMap (Endo . f) t) z +    -- | Right-associative fold of a structure, +    -- but with strict application of the operator.+    foldr' :: (a -> b -> b) -> b -> t a -> b+    foldr' f z0 xs = foldl f' id xs z0+      where f' k x z = k $! f x z+     -- | Left-associative fold of a structure.     --     -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@     foldl :: (a -> b -> a) -> a -> t b -> a     foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z +    -- | Left-associative fold of a structure.+    -- but with strict application of the operator.+    --+    -- @'foldl' f z = 'List.foldl'' f z . 'toList'@+    foldl' :: (a -> b -> a) -> a -> t b -> a+    foldl' f z0 xs = foldr f' id xs z0+      where f' x k z = k $! f z x+     -- | A variant of 'foldr' that has no base case,     -- and thus may only be applied to non-empty structures.     --@@ -164,6 +177,7 @@ instance Foldable [] where     foldr = Prelude.foldr     foldl = Prelude.foldl+    foldl' = List.foldl'     foldr1 = Prelude.foldr1     foldl1 = Prelude.foldl1 @@ -173,23 +187,11 @@     foldr1 f = Prelude.foldr1 f . elems     foldl1 f = Prelude.foldl1 f . elems --- | Fold over the elements of a structure,--- associating to the right, but strictly.-foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b-foldr' f z0 xs = foldl f' id xs z0-  where f' k x z = k $! f x z- -- | Monadic fold over the elements of a structure, -- associating to the right, i.e. from right to left. foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b foldrM f z0 xs = foldl f' return xs z0   where f' k x z = f x z >>= k---- | Fold over the elements of a structure,--- associating to the left, but strictly.-foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a-foldl' f z0 xs = foldr f' id xs z0-  where f' x k z = k $! f z x  -- | Monadic fold over the elements of a structure, -- associating to the left, i.e. from left to right.

@@ -19,7 +19,9 @@ -- ----------------------------------------------------------------------------- -module Data.HashTable (+module Data.HashTable+      {-# DEPRECATED "Data.HashTable will be removed in GHC 7.8. Please use an alternative, e.g. the hashtables package, instead." #-}+      (         -- * Basic hash table operations         HashTable, new, newHint, insert, delete, lookup, update,         -- * Converting to and from lists

@@ -23,7 +23,10 @@         readIORef,            -- :: IORef a -> IO a         writeIORef,           -- :: IORef a -> a -> IO ()         modifyIORef,          -- :: IORef a -> (a -> a) -> IO ()+        modifyIORef',         -- :: IORef a -> (a -> a) -> IO ()         atomicModifyIORef,    -- :: IORef a -> (a -> (a,b)) -> IO b+        atomicModifyIORef',   -- :: IORef a -> (a -> (a,b)) -> IO b+        atomicWriteIORef,  #if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__)         mkWeakIORef,          -- :: IORef a -> IO () -> IO (Weak (IORef a))@@ -66,10 +69,28 @@   case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #) #endif --- |Mutate the contents of an 'IORef'+-- |Mutate the contents of an 'IORef'.+--+-- Be warned that 'modifyIORef' does not apply the function strictly.  This+-- means if the program calls 'modifyIORef' many times, but seldomly uses the+-- value, thunks will pile up in memory resulting in a space leak.  This is a+-- common mistake made when using an IORef as a counter.  For example, the+-- following will likely produce a stack overflow:+--+-- >ref <- newIORef 0+-- >replicateM_ 1000000 $ modifyIORef ref (+1)+-- >readIORef ref >>= print+--+-- To avoid this problem, use 'modifyIORef'' instead. modifyIORef :: IORef a -> (a -> a) -> IO () modifyIORef ref f = readIORef ref >>= writeIORef ref . f +-- |Strict version of 'modifyIORef'+modifyIORef' :: IORef a -> (a -> a) -> IO ()+modifyIORef' ref f = do+    x <- readIORef ref+    let x' = f x+    x' `seq` writeIORef ref x'  -- |Atomically modifies the contents of an 'IORef'. --@@ -81,6 +102,15 @@ -- is recommended that if you need to do anything more complicated -- then using 'Control.Concurrent.MVar.MVar' instead is a good idea. --+-- 'atomicModifyIORef' does not apply the function strictly.  This is important+-- to know even if all you are doing is replacing the value.  For example, this+-- will leak memory:+--+-- >ref <- newIORef '1'+-- >forever $ atomicModifyIORef ref (\_ -> ('2', ()))+--+-- Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem.+-- atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b #if defined(__GLASGOW_HASKELL__) atomicModifyIORef = GHC.IORef.atomicModifyIORef@@ -98,6 +128,22 @@     writeIORef r a'     return b #endif++-- | Strict version of 'atomicModifyIORef'.  This forces both the value stored+-- in the 'IORef' as well as the value returned.+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORef' ref f = do+    b <- atomicModifyIORef ref+            (\x -> let (a, b) = f x+                    in (a, a `seq` b))+    b `seq` return b++-- | Variant of 'writeIORef' with the \"barrier to reordering\" property that+-- 'atomicModifyIORef' has.+atomicWriteIORef :: IORef a -> a -> IO ()+atomicWriteIORef ref a = do+    x <- atomicModifyIORef ref (\_ -> (a, ()))+    x `seq` return ()  {- $memmodel 

@@ -416,7 +416,8 @@ -- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4] -- -- It is a special case of 'intersectBy', which allows the programmer to--- supply their own equality test.+-- supply their own equality test. If the element is found in both the first+-- and the second list, the element from the first list will be used.  intersect               :: (Eq a) => [a] -> [a] -> [a] intersect               =  intersectBy (==)

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, DeriveGeneric #-}+{-# LANGUAGE CPP, NoImplicitPrelude #-}  ----------------------------------------------------------------------------- -- |@@ -34,7 +34,6 @@  #ifdef __GLASGOW_HASKELL__ import GHC.Base-import GHC.Generics (Generic) #endif  #ifdef __NHC__@@ -67,7 +66,7 @@ -- error monad can be built using the 'Data.Either.Either' type.  data  Maybe a  =  Nothing | Just a-  deriving (Eq, Ord, Generic)+  deriving (Eq, Ord)  instance  Functor Maybe  where     fmap _ Nothing       = Nothing

@@ -235,14 +235,7 @@  -- | Maybe monoid returning the leftmost non-Nothing value. newtype First a = First { getFirst :: Maybe a }-#ifndef __HADDOCK__         deriving (Eq, Ord, Read, Show)-#else  /* __HADDOCK__ */-instance Eq a => Eq (First a)-instance Ord a => Ord (First a)-instance Read a => Read (First a)-instance Show a => Show (First a)-#endif  instance Monoid (First a) where         mempty = First Nothing@@ -251,14 +244,7 @@  -- | Maybe monoid returning the rightmost non-Nothing value. newtype Last a = Last { getLast :: Maybe a }-#ifndef __HADDOCK__         deriving (Eq, Ord, Read, Show)-#else  /* __HADDOCK__ */-instance Eq a => Eq (Last a)-instance Ord a => Ord (Last a)-instance Read a => Read (Last a)-instance Show a => Show (Last a)-#endif  instance Monoid (Last a) where         mempty = Last Nothing

@@ -18,6 +18,7 @@ module Data.Ord (    Ord(..),    Ordering(..),+   Down(..),    comparing,  ) where @@ -35,3 +36,13 @@ comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering comparing p x y = compare (p x) (p y) +-- | The 'Down' type allows you to reverse sort order conveniently.  A value of type+-- @'Down' a@ contains a value of type @a@ (represented as @'Down' a@).+-- If @a@ has an @'Ord'@ instance associated with it then comparing two+-- values thus wrapped will give you the opposite of their normal sort order.+-- This is particularly useful when sorting in generalised list comprehensions,+-- as in: @then sortWith by 'Down' x@+newtype Down a = Down a deriving (Eq)++instance Ord a => Ord (Down a) where+    compare (Down x) (Down y) = y `compare` x

@@ -21,7 +21,8 @@         newSTRef,       -- :: a -> ST s (STRef s a)         readSTRef,      -- :: STRef s a -> ST s a         writeSTRef,     -- :: STRef s a -> a -> ST s ()-        modifySTRef     -- :: STRef s a -> (a -> a) -> ST s ()+        modifySTRef,    -- :: STRef s a -> (a -> a) -> ST s ()+        modifySTRef'    -- :: STRef s a -> (a -> a) -> ST s ()  ) where  import Prelude@@ -39,7 +40,26 @@ INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef") #endif --- |Mutate the contents of an 'STRef'+-- | Mutate the contents of an 'STRef'.+--+-- Be warned that 'modifySTRef' does not apply the function strictly.  This+-- means if the program calls 'modifySTRef' many times, but seldomly uses the+-- value, thunks will pile up in memory resulting in a space leak.  This is a+-- common mistake made when using an STRef as a counter.  For example, the+-- following will leak memory and likely produce a stack overflow:+--+-- >print $ runST $ do+-- >    ref <- newSTRef 0+-- >    replicateM_ 1000000 $ modifySTRef ref (+1)+-- >    readSTRef ref+--+-- To avoid this problem, use 'modifySTRef'' instead. modifySTRef :: STRef s a -> (a -> a) -> ST s () modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref +-- | Strict version of 'modifySTRef'+modifySTRef' :: STRef s a -> (a -> a) -> ST s ()+modifySTRef' ref f = do+    x <- readSTRef ref+    let x' = f x+    x' `seq` writeSTRef ref x'

@@ -104,7 +104,6 @@ import GHC.Base import GHC.Err          (undefined) -import GHC.Fingerprint.Type import {-# SOURCE #-} GHC.Fingerprint    -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable    -- Better to break the loop here, because we want non-SOURCE imports

@@ -24,6 +24,7 @@  module Data.Typeable.Internal (     TypeRep(..),+    Fingerprint(..),     TyCon(..),     mkTyCon,     mkTyCon3,@@ -157,9 +158,12 @@  -- | Adds a TypeRep argument to a TypeRep. mkAppTy :: TypeRep -> TypeRep -> TypeRep-mkAppTy (TypeRep tr_k tc trs) arg_tr-  = let (TypeRep arg_k _ _) = arg_tr-     in  TypeRep (fingerprintFingerprints [tr_k,arg_k]) tc (trs++[arg_tr])+mkAppTy (TypeRep _ tc trs) arg_tr = mkTyConApp tc (trs ++ [arg_tr])+   -- Notice that we call mkTyConApp to construct the fingerprint from tc and+   -- the arg fingerprints.  Simply combining the current fingerprint with+   -- the new one won't give the same answer, but of course we want to +   -- ensure that a TypeRep of the same shape has the same fingerprint!+   -- See Trac #5962  -- | Builds a 'TyCon' object representing a type constructor.  An -- implementation of "Data.Typeable" should ensure that the following holds:

@@ -33,8 +33,8 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Num-import GHC.Conc import Data.Typeable+import Data.IORef #endif  -- | An abstract unique object.  Objects of type 'Unique' may be@@ -45,8 +45,8 @@ #endif    ) -uniqSource :: TVar Integer-uniqSource = unsafePerformIO (newTVarIO 0)+uniqSource :: IORef Integer+uniqSource = unsafePerformIO (newIORef 0) {-# NOINLINE uniqSource #-}  -- | Creates a new object of type 'Unique'.  The value returned will@@ -54,11 +54,9 @@ -- previous calls to 'newUnique'.  There is no limit on the number of -- times 'newUnique' may be called. newUnique :: IO Unique-newUnique = atomically $ do-  val <- readTVar uniqSource-  let next = val+1-  writeTVar uniqSource $! next-  return (Unique next)+newUnique = do+  r <- atomicModifyIORef uniqSource $ \x -> let z = x+1 in (z,z)+  r `seq` return (Unique r)  -- SDM (18/3/2010): changed from MVar to STM.  This fixes --  1. there was no async exception protection@@ -66,6 +64,14 @@ --  3. using atomicModifyIORef would be slightly quicker, but can --     suffer from adverse scheduling issues (see #3838) --  4. also, the STM version is faster.++-- SDM (30/4/2012): changed to IORef using atomicModifyIORef.  Reasons:+--  1. STM version could not be used inside unsafePerformIO, if it+--     happened to be poked inside an STM transaction.+--  2. IORef version can be used with unsafeIOToSTM inside STM,+--     because if the transaction retries then we just get a new+--     Unique.+--  3. IORef version is very slightly faster.  -- | Hashes a 'Unique' into an 'Int'.  Two 'Unique's may hash to the -- same value, although in practice this is unlikely.  The 'Int'

@@ -107,7 +107,7 @@ import Foreign.Ptr import Foreign.C.Types import Foreign.C.String-import Foreign.Marshal.Error    ( void )+import Control.Monad            ( void ) import Data.Maybe  #if __GLASGOW_HASKELL__

@@ -110,6 +110,7 @@ #ifdef __GLASGOW_HASKELL__ import Control.Monad +import GHC.Char import GHC.List import GHC.Real import GHC.Num

@@ -83,4 +83,4 @@ -- void     :: IO a -> IO () void act  = act >> return ()-+{-# DEPRECATED void "use Control.Monad.void instead" #-}

@@ -66,9 +66,6 @@ import GHC.Real import GHC.Show import GHC.Enum-import GHC.Word         ( Word(..) )--import Data.Word #else import Control.Monad    ( liftM ) import Foreign.C.Types

@@ -47,7 +47,6 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Storable import GHC.Stable       ( StablePtr )-import GHC.IO()		-- Instance Monad IO import GHC.Num import GHC.Int import GHC.Word

@@ -47,6 +47,7 @@ import GHC.ST import GHC.Base import GHC.List+import GHC.Real import GHC.Show  infixl 9  !, //@@ -227,6 +228,11 @@      {-# INLINE inRange #-}     inRange (I# m,I# n) (I# i) =  m <=# i && i <=# n++instance Ix Word where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n  ---------------------------------------------------------------------- instance  Ix Integer  where

@@ -109,7 +109,6 @@ import GHC.Classes import GHC.CString import GHC.Prim-import {-# SOURCE #-} GHC.Show import {-# SOURCE #-} GHC.Err import {-# SOURCE #-} GHC.IO (failIO) @@ -229,6 +228,16 @@     {-# INLINE (>>) #-}     m >> k      = m >>= \_ -> k     fail s      = error s++instance Functor ((->) r) where+    fmap = (.)++instance Monad ((->) r) where+    return = const+    f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+    fmap f (x,y) = (x, f y) \end{code}  @@ -448,13 +457,6 @@ "x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False   #-} --- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.-chr :: Int -> Char-chr i@(I# i#)- | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)- | otherwise-    = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")- unsafeChr :: Int -> Char unsafeChr (I# i#) = C# (chr# i#) @@ -484,10 +486,7 @@ %*********************************************************  \begin{code}-zeroInt, oneInt, twoInt, maxInt, minInt :: Int-zeroInt = I# 0#-oneInt  = I# 1#-twoInt  = I# 2#+maxInt, minInt :: Int  {- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -} #if WORD_SIZE_IN_BITS == 31@@ -656,47 +655,36 @@ %*                                                      * %********************************************************* -\begin{code}-divInt# :: Int# -> Int# -> Int#-x# `divInt#` y#-        -- Be careful NOT to overflow if we do any additional arithmetic-        -- on the arguments...  the following  previous version of this-        -- code has problems with overflow:---    | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#---    | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#-    | (x# ># 0#) && (y# <# 0#) = ((x# -# 1#) `quotInt#` y#) -# 1#-    | (x# <# 0#) && (y# ># 0#) = ((x# +# 1#) `quotInt#` y#) -# 1#-    | otherwise                = x# `quotInt#` y#--modInt# :: Int# -> Int# -> Int#-x# `modInt#` y#-    | (x# ># 0#) && (y# <# 0#) ||-      (x# <# 0#) && (y# ># 0#)    = if r# /=# 0# then r# +# y# else 0#-    | otherwise                   = r#-    where-    !r# = x# `remInt#` y#-\end{code}- Definitions of the boxed PrimOps; these will be used in the case of partial applications, etc.  \begin{code}-{-# INLINE plusInt #-}-{-# INLINE minusInt #-}-{-# INLINE timesInt #-} {-# INLINE quotInt #-} {-# INLINE remInt #-}-{-# INLINE negateInt #-} -plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt :: Int -> Int -> Int-(I# x) `plusInt`  (I# y) = I# (x +# y)-(I# x) `minusInt` (I# y) = I# (x -# y)-(I# x) `timesInt` (I# y) = I# (x *# y)+quotInt, remInt, divInt, modInt :: Int -> Int -> Int (I# x) `quotInt`  (I# y) = I# (x `quotInt#` y) (I# x) `remInt`   (I# y) = I# (x `remInt#`  y) (I# x) `divInt`   (I# y) = I# (x `divInt#`  y) (I# x) `modInt`   (I# y) = I# (x `modInt#`  y) +quotRemInt :: Int -> Int -> (Int, Int)+(I# x) `quotRemInt` (I# y) = case x `quotRemInt#` y of+                             (# q, r #) ->+                                 (I# q, I# r)++divModInt :: Int -> Int -> (Int, Int)+(I# x) `divModInt` (I# y) = case x `divModInt#` y of+                            (# q, r #) -> (I# q, I# r)++divModInt# :: Int# -> Int# -> (# Int#, Int# #)+x# `divModInt#` y#+ | (x# ># 0#) && (y# <# 0#) = case (x# -# 1#) `quotRemInt#` y# of+                              (# q, r #) -> (# q -# 1#, r +# y# +# 1# #)+ | (x# <# 0#) && (y# ># 0#) = case (x# +# 1#) `quotRemInt#` y# of+                              (# q, r #) -> (# q -# 1#, r +# y# -# 1# #)+ | otherwise                = x# `quotRemInt#` y#+ {-# RULES "x# +# 0#" forall x#. x# +# 0# = x# "0# +# x#" forall x#. 0# +# x# = x#@@ -708,9 +696,6 @@ "1# *# x#" forall x#. 1# *# x# = x#   #-} -negateInt :: Int -> Int-negateInt (I# x) = I# (negateInt# x)- {-# RULES "x# ># x#"  forall x#. x# >#  x# = False "x# >=# x#" forall x#. x# >=# x# = True@@ -770,13 +755,13 @@ -- | Shift the argument left by the specified number of bits -- (which must be non-negative). shiftL# :: Word# -> Int# -> Word#-a `shiftL#` b   | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#+a `shiftL#` b   | b >=# WORD_SIZE_IN_BITS# = 0##                 | otherwise                = a `uncheckedShiftL#` b  -- | Shift the argument right by the specified number of bits -- (which must be non-negative). shiftRL# :: Word# -> Int# -> Word#-a `shiftRL#` b  | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#+a `shiftRL#` b  | b >=# WORD_SIZE_IN_BITS# = 0##                 | otherwise                = a `uncheckedShiftRL#` b  -- | Shift the argument left by the specified number of bits

@@ -0,0 +1,15 @@++{-# LANGUAGE NoImplicitPrelude, MagicHash #-}++module GHC.Char (chr) where++import GHC.Base+import GHC.Show++-- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.+chr :: Int -> Char+chr i@(I# i#)+ | int2Word# i# `leWord#` 0x10FFFF## = C# (chr# i#)+ | otherwise+    = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")+

@@ -51,6 +51,7 @@         , runSparks         , yield         -- :: IO ()         , labelThread   -- :: ThreadId -> String -> IO ()+        , mkWeakThreadId -- :: ThreadId -> IO (Weak ThreadId)          , ThreadStatus(..), BlockReason(..)         , threadStatus  -- :: ThreadId -> IO ThreadStatus

@@ -61,6 +61,7 @@         , runSparks         , yield         -- :: IO ()         , labelThread   -- :: ThreadId -> String -> IO ()+        , mkWeakThreadId -- :: ThreadId -> IO (Weak ThreadId)          , ThreadStatus(..), BlockReason(..)         , threadStatus  -- :: ThreadId -> IO ThreadStatus@@ -119,6 +120,7 @@ import GHC.Real         ( fromIntegral ) import GHC.Pack         ( packCString# ) import GHC.Show         ( Show(..), showString )+import GHC.Weak  infixr 0 `par`, `pseq` \end{code}@@ -204,7 +206,7 @@   action_plus = catchException action childHandler  {-# DEPRECATED forkIOUnmasked "use forkIOWithUnmask instead" #-}--- | This function is deprecated; use 'forkIOWIthUnmask' instead+-- | This function is deprecated; use 'forkIOWithUnmask' instead forkIOUnmasked :: IO () -> IO ThreadId forkIOUnmasked io = forkIO (unsafeUnmask io) @@ -281,21 +283,8 @@  {- | Returns the number of Haskell threads that can run truly-simultaneously (on separate physical processors) at any given time.-The number passed to `forkOn` is interpreted modulo this-value.--An implementation in which Haskell threads are mapped directly to-OS threads might return the number of physical processor cores in-the machine, and 'forkOn' would be implemented using the OS's-affinity facilities.  An implementation that schedules Haskell-threads onto a smaller number of OS threads (like GHC) would return-the number of such OS threads that can be running simultaneously.--GHC notes: this returns the number passed as the argument to the-@+RTS -N@ flag.  In current implementations, the value is fixed-when the program starts and never changes, but it is possible that-in the future the number of capabilities might vary at runtime.+simultaneously (on separate physical processors) at any given time.  To change+this value, use 'setNumCapabilities'. -} getNumCapabilities :: IO Int getNumCapabilities = do@@ -304,12 +293,15 @@  {- | Set the number of Haskell threads that can run truly simultaneously-(on separate physical processors) at any given time.+(on separate physical processors) at any given time.  The number+passed to `forkOn` is interpreted modulo this value.  The initial+value is given by the @+RTS -N@ runtime flag. -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'.+This is also the number of threads that will participate in parallel+garbage collection.  It is strongly recommended that the number of+capabilities is not set larger than the number of physical processor+cores, and it may often be beneficial to leave one or more cores free+to avoid contention with other processes in the machine. -} setNumCapabilities :: Int -> IO () setNumCapabilities i = c_setNumCapabilities (fromIntegral i)@@ -327,11 +319,8 @@ numSparks :: IO Int numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #) -#if defined(mingw32_HOST_OS) && defined(__PIC__)-foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt-#else foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt-#endif+ childHandler :: SomeException -> IO () childHandler err = catchException (real_handler err) childHandler @@ -524,6 +513,26 @@ threadCapability (ThreadId t) = IO $ \s ->    case threadStatus# t s of      (# s', _, cap#, locked# #) -> (# s', (I# cap#, locked# /=# 0#) #)++-- | make a weak pointer to a 'ThreadId'.  It can be important to do+-- this if you want to hold a reference to a 'ThreadId' while still+-- allowing the thread to receive the @BlockedIndefinitely@ family of+-- exceptions (e.g. 'BlockedIndefinitelyOnMVar').  Holding a normal+-- 'ThreadId' reference will prevent the delivery of+-- @BlockedIndefinitely@ exceptions because the reference could be+-- used as the target of 'throwTo' at any time, which would unblock+-- the thread.+--+-- Holding a @Weak ThreadId@, on the other hand, will not prevent the+-- thread from receiving @BlockedIndefinitely@ exceptions.  It is+-- still possible to throw an exception to a @Weak ThreadId@, but the+-- caller must use @deRefWeak@ first to determine whether the thread+-- still exists.+--+mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)+mkWeakThreadId t@(ThreadId t#) = IO $ \s ->+   case mkWeakNoFinalizer# t# t s of+      (# s1, w #) -> (# s1, Weak w #) \end{code}  

@@ -57,6 +57,16 @@ import GHC.Word (Word32, Word64) import GHC.Windows +#ifdef mingw32_HOST_OS+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+#endif+ -- ---------------------------------------------------------------------------- -- Thread waiting @@ -140,7 +150,7 @@  calculateTarget :: Int -> IO USecs calculateTarget usecs = do-    now <- getUSecOfDay+    now <- getMonotonicUSec     return $ now + (fromIntegral usecs)  data DelayReq@@ -194,10 +204,14 @@ delayTime (DelaySTM t _) = t  type USecs = Word64+type NSecs = Word64 -foreign import ccall unsafe "getUSecOfDay"-  getUSecOfDay :: IO USecs+foreign import ccall unsafe "getMonotonicNSec"+  getMonotonicNSec :: IO NSecs +getMonotonicUSec :: IO USecs+getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec+ {-# NOINLINE prodding #-} prodding :: IORef Bool prodding = unsafePerformIO $ do@@ -232,7 +246,7 @@   new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))   let  delays = foldr insertDelay old_delays new_delays -  now <- getUSecOfDay+  now <- getMonotonicUSec   (delays', timeout) <- getDelay now delays    r <- c_WaitForSingleObject wakeup timeout@@ -322,6 +336,6 @@ foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)   c_sendIOManagerEvent :: Word32 -> IO () -foreign import stdcall "WaitForSingleObject"+foreign import WINDOWS_CCONV "WaitForSingleObject"    c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD 

@@ -27,9 +27,7 @@ import Data.Data        (Data)  -- A version of Control.Category.>>> overloaded on Arrow-#ifndef __HADDOCK__ (>>>) :: forall arr. Arrow arr => forall a b c. arr a b -> arr b c -> arr a c-#endif -- NB: the type of this function is the "shape" that GHC expects --     in tcInstClassOp.  So don't put all the foralls at the front!   --     Yes, this is a bit grotesque, but heck it works and the whole

@@ -28,10 +28,10 @@    ) where  import GHC.Base+import GHC.Char import GHC.Integer import GHC.Num import GHC.Show-import Data.Tuple       ()              -- for dependencies default ()              -- Double isn't available yet \end{code} @@ -106,8 +106,8 @@     -- | Used in Haskell's translation of @[n,n'..m]@.     enumFromThenTo      :: a -> a -> a -> [a] -    succ                   = toEnum . (`plusInt` oneInt)  . fromEnum-    pred                   = toEnum . (`minusInt` oneInt) . fromEnum+    succ                   = toEnum . (+ 1)  . fromEnum+    pred                   = toEnum . (subtract 1) . fromEnum     enumFrom x             = map toEnum [fromEnum x ..]     enumFromThen x y       = map toEnum [fromEnum x, fromEnum y ..]     enumFromTo x y         = map toEnum [fromEnum x .. fromEnum y]@@ -174,10 +174,10 @@     succ _      = error "Prelude.Enum.().succ: bad argument"     pred _      = error "Prelude.Enum.().pred: bad argument" -    toEnum x | x == zeroInt = ()-             | otherwise    = error "Prelude.Enum.().toEnum: bad argument"+    toEnum x | x == 0    = ()+             | otherwise = error "Prelude.Enum.().toEnum: bad argument" -    fromEnum () = zeroInt+    fromEnum () = 0     enumFrom ()         = [()]     enumFromThen () ()  = let many = ():many in many     enumFromTo () ()    = [()]@@ -294,12 +294,12 @@   pred True  = False   pred False  = error "Prelude.Enum.Bool.pred: bad argument" -  toEnum n | n == zeroInt = False-           | n == oneInt  = True-           | otherwise    = error "Prelude.Enum.Bool.toEnum: bad argument"+  toEnum n | n == 0    = False+           | n == 1    = True+           | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument" -  fromEnum False = zeroInt-  fromEnum True  = oneInt+  fromEnum False = 0+  fromEnum True  = 1    -- Use defaults for the rest   enumFrom     = boundedEnumFrom@@ -326,14 +326,14 @@   pred EQ = LT   pred LT = error "Prelude.Enum.Ordering.pred: bad argument" -  toEnum n | n == zeroInt = LT-           | n == oneInt  = EQ-           | n == twoInt  = GT+  toEnum n | n == 0 = LT+           | n == 1 = EQ+           | n == 2 = GT   toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument" -  fromEnum LT = zeroInt-  fromEnum EQ = oneInt-  fromEnum GT = twoInt+  fromEnum LT = 0+  fromEnum EQ = 1+  fromEnum GT = 2    -- Use defaults for the rest   enumFrom     = boundedEnumFrom@@ -471,8 +471,6 @@         (b) be careful of Int overflow         (c) remember that Int is bounded, so [1..] terminates at maxInt -Also NB that the Num class isn't available in this module.-         \begin{code} instance  Bounded Int where     minBound =  minInt@@ -481,10 +479,10 @@ instance  Enum Int  where     succ x          | x == maxBound  = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound"-       | otherwise      = x `plusInt` oneInt+       | otherwise      = x + 1     pred x        | x == minBound  = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound"-       | otherwise      = x `minusInt` oneInt+       | otherwise      = x - 1      toEnum   x = x     fromEnum x = x@@ -620,6 +618,26 @@                    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{Type @Word@}+%*                                                      *+%*********************************************************++\begin{code}+instance Bounded Word where+    minBound = 0++    -- use unboxed literals for maxBound, because GHC doesn't optimise+    -- (fromInteger 0xffffffff :: Word).+#if WORD_SIZE_IN_BITS == 32+    maxBound = W# (int2Word# 0xFFFFFFFF#)+#else+    maxBound = W# (int2Word# 0xFFFFFFFFFFFFFFFF#)+#endif \end{code}  

@@ -11,6 +11,14 @@ import GHC.IO (finally) import GHC.Windows +# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+ -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat getFullArgs :: IO [String] getFullArgs = do@@ -24,13 +32,13 @@        p_argvs <- peekArray (fromIntegral argc) p_argv        mapM peekCWString p_argvs -foreign import stdcall unsafe "windows.h GetCommandLineW"+foreign import WINDOWS_CCONV unsafe "windows.h GetCommandLineW"     c_GetCommandLine :: IO (Ptr CWString) -foreign import stdcall unsafe "windows.h CommandLineToArgvW"+foreign import WINDOWS_CCONV unsafe "windows.h CommandLineToArgvW"     c_CommandLineToArgv :: Ptr CWString -> Ptr CInt -> IO (Ptr CWString) -foreign import stdcall unsafe "Windows.h LocalFree"+foreign import WINDOWS_CCONV unsafe "Windows.h LocalFree"     c_LocalFree :: Ptr a -> IO (Ptr a) #else import Control.Monad

@@ -27,6 +27,7 @@        (          absentErr                 -- :: a        , divZeroError              -- :: a+       , ratioZeroDenominatorError -- :: a        , overflowError             -- :: a         , error                     -- :: String -> a@@ -34,10 +35,8 @@        , undefined                 -- :: a        ) where -#ifndef __HADDOCK__ import GHC.Types import GHC.Exception-#endif \end{code}  %*********************************************************@@ -83,6 +82,10 @@ {-# NOINLINE divZeroError #-} divZeroError :: a divZeroError = throw DivideByZero++{-# NOINLINE ratioZeroDenominatorError #-}+ratioZeroDenominatorError :: a+ratioZeroDenominatorError = throw RatioZeroDenominator  {-# NOINLINE overflowError #-} overflowError :: a

@@ -1,32 +1,89 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface, CApiFFI #-} -module GHC.Event.Clock (getCurrentTime) where+module GHC.Event.Clock (getMonotonicTime, initializeTimer) where -#include <sys/time.h>+#include "HsBase.h" -import Foreign (Ptr, Storable(..), nullPtr, with)-import Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign import Foreign.C.Types import GHC.Base+import GHC.Real++#if !darwin_HOST_OS+import Foreign.C.Error (throwErrnoIfMinus1_) import GHC.Err import GHC.Num-import GHC.Real+#endif  -- TODO: Implement this for Windows. --- | Return the current time, in seconds since Jan. 1, 1970.-getCurrentTime :: IO Double-getCurrentTime = do+initializeTimer :: IO ()++-- | Return monotonic time in seconds, since some unspecified starting point+getMonotonicTime :: IO Double++------------------------------------------------------------------------+-- FFI binding++#if HAVE_CLOCK_GETTIME++initializeTimer = return ()++getMonotonicTime = do+    tv <- with (CTimespec 0 0) $ \tvptr -> do+        throwErrnoIfMinus1_ "clock_gettime" (clock_gettime (#const CLOCK_ID) tvptr)+        peek tvptr+    let !t = realToFrac (sec tv) + realToFrac (nsec tv) / 1000000000.0+    return t++data CTimespec = CTimespec+    { sec  :: {-# UNPACK #-} !CTime+    , nsec :: {-# UNPACK #-} !CLong+    }++instance Storable CTimespec where+    sizeOf _ = #size struct timespec+    alignment _ = alignment (undefined :: CLong)++    peek ptr = do+        sec' <- #{peek struct timespec, tv_sec} ptr+        nsec' <- #{peek struct timespec, tv_nsec} ptr+        return $ CTimespec sec' nsec'++    poke ptr tv = do+        #{poke struct timespec, tv_sec} ptr (sec tv)+        #{poke struct timespec, tv_nsec} ptr (nsec tv)++foreign import capi unsafe "HsBase.h clock_gettime" clock_gettime+    :: Int -> Ptr CTimespec -> IO CInt++#elif darwin_HOST_OS++getMonotonicTime = do+    with 0.0 $ \timeptr -> do+    absolute_time timeptr+    ctime <- peek timeptr+    let !time = realToFrac ctime+    return time++foreign import capi unsafe "HsBase.h absolute_time" absolute_time ::+    Ptr CDouble -> IO ()++foreign import capi unsafe "HsBase.h initialize_timer"+  initializeTimer :: IO ()++#else++initializeTimer = return ()++getMonotonicTime = do     tv <- with (CTimeval 0 0) $ \tvptr -> do         throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr)         peek tvptr     let !t = realToFrac (sec tv) + realToFrac (usec tv) / 1000000.0     return t ---------------------------------------------------------------------------- FFI binding- data CTimeval = CTimeval     { sec  :: {-# UNPACK #-} !CTime     , usec :: {-# UNPACK #-} !CSUSeconds@@ -48,3 +105,4 @@ foreign import capi unsafe "HsBase.h gettimeofday" gettimeofday     :: Ptr CTimeval -> Ptr () -> IO CInt +#endif

@@ -78,9 +78,7 @@ import GHC.Real (fromIntegral) import GHC.Show (Show(showsPrec), showParen, shows, showString) -#if __GLASGOW_HASKELL__-import GHC.Word (Word(..))-#else+#if !defined(__GLASGOW_HASKELL__) import Data.Word #endif 

@@ -63,7 +63,7 @@ import GHC.Num (Num(..)) import GHC.Real ((/), fromIntegral ) import GHC.Show (Show(..))-import GHC.Event.Clock (getCurrentTime)+import GHC.Event.Clock (getMonotonicTime) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite,                            Timeout(..))@@ -256,7 +256,7 @@   -- next timeout.   mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)   mkTimeout q = do-      now <- getCurrentTime+      now <- getMonotonicTime       applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f)       let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q'       sequence_ $ map Q.value expired@@ -363,7 +363,7 @@   !key <- newUnique (emUniqueSource mgr)   if us <= 0 then cb     else do-      now <- getCurrentTime+      now <- getMonotonicTime       let expTime = fromIntegral us / 1000000.0 + now        -- We intentionally do not evaluate the modified map to WHNF here.@@ -387,7 +387,7 @@ -- microseconds. updateTimeout :: EventManager -> TimeoutKey -> Int -> IO () updateTimeout mgr (TK key) us = do-  now <- getCurrentTime+  now <- getMonotonicTime   let expTime = fromIntegral us / 1000000.0 + now    atomicModifyIORef (emTimeouts mgr) $ \f ->

@@ -25,6 +25,7 @@ import GHC.Event.Internal (eventIs, evtClose) import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,                              new, registerFd, unregisterFd_, registerTimeout)+import GHC.Event.Clock (initializeTimer) import qualified GHC.Event.Manager as M import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types (Fd)@@ -122,7 +123,12 @@ ensureIOManagerIsRunning :: IO () ensureIOManagerIsRunning   | not threaded = return ()-  | otherwise = modifyMVar_ ioManager $ \old -> do+  | otherwise = do+      initializeTimer+      startIOManagerThread++startIOManagerThread :: IO ()+startIOManagerThread = modifyMVar_ ioManager $ \old -> do   let create = do         !mgr <- new         writeIORef eventManager $ Just mgr

@@ -182,6 +182,7 @@   | LossOfPrecision   | DivideByZero   | Denormal+  | RatioZeroDenominator   deriving (Eq, Ord, Typeable)  instance Exception ArithException@@ -192,5 +193,6 @@   showsPrec _ LossOfPrecision = showString "loss of precision"   showsPrec _ DivideByZero    = showString "divide by zero"   showsPrec _ Denormal        = showString "denormal"+  showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator"  \end{code}

@@ -13,6 +13,7 @@ -- -- GHC Extensions: this is the Approved Way to get at GHC-specific extensions. --+-- Note: no other base module should import this module. -----------------------------------------------------------------------------  module GHC.Exts@@ -71,23 +72,13 @@ import Data.String import Data.List import Data.Data+import Data.Ord import qualified Debug.Trace  -- XXX This should really be in Data.Tuple, where the definitions are maxTupleSize :: Int maxTupleSize = 62 --- | The 'Down' type allows you to reverse sort order conveniently.  A value of type--- @'Down' a@ contains a value of type @a@ (represented as @'Down' a@).--- If @a@ has an @'Ord'@ instance associated with it then comparing two--- values thus wrapped will give you the opposite of their normal sort order.--- This is particularly useful when sorting in generalised list comprehensions,--- as in: @then sortWith by 'Down' x@-newtype Down a = Down a deriving (Eq)--instance Ord a => Ord (Down a) where-    compare (Down x) (Down y) = y `compare` x- -- | 'the' ensures that all the elements of the list are identical -- and then returns that unique element the :: Eq a => [a] -> a@@ -102,7 +93,7 @@ sortWith f = sortBy (\x y -> compare (f x) (f y))  -- | The 'groupWith' function uses the user supplied function which--- projects an element out of every list element in order to to first sort the +-- projects an element out of every list element in order to first sort the -- input list and then to form groups by equality on these projected elements {-# INLINE groupWith #-} groupWith :: Ord b => (a -> b) -> [a] -> [[a]]

@@ -15,6 +15,7 @@ -- | -- Module      :  GHC.Float -- Copyright   :  (c) The University of Glasgow 1994-2002+--                Portions obtained from hbc (c) Lennart Augusstson -- License     :  see libraries/base/LICENSE -- -- Maintainer  :  cvs-ghc@haskell.org@@ -635,20 +636,21 @@  roundTo :: Int -> Int -> [Int] -> (Int,[Int]) roundTo base d is =-  case f d is of+  case f d True is of     x@(0,_) -> x     (1,xs)  -> (1, 1:xs)     _       -> error "roundTo: bad Value"  where-  b2 = base `div` 2+  b2 = base `quot` 2 -  f n []     = (0, replicate n 0)-  f 0 (x:_)  = (if x >= b2 then 1 else 0, [])-  f n (i:xs)+  f n _ []     = (0, replicate n 0)+  f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, [])   -- Round to even when at exactly half the base+               | otherwise = (if x >= b2 then 1 else 0, [])+  f n _ (i:xs)      | i' == base = (1,0:ds)      | otherwise  = (0,i':ds)       where-       (c,ds) = f (n-1) xs+       (c,ds) = f (n-1) (even i) xs        i'     = c + i  -- Based on "Printing Floating-Point Numbers Quickly and Accurately"

@@ -26,6 +26,7 @@ module GHC.ForeignPtr   (         ForeignPtr(..),+        ForeignPtrContents(..),         FinalizerPtr,         FinalizerEnvPtr,         newForeignPtr_,@@ -33,6 +34,8 @@         mallocPlainForeignPtr,         mallocForeignPtrBytes,         mallocPlainForeignPtrBytes,+        mallocForeignPtrAlignedBytes,+        mallocPlainForeignPtrAlignedBytes,         addForeignPtrFinalizer,         addForeignPtrFinalizerEnv,         touchForeignPtr,@@ -182,6 +185,20 @@                          (MallocPtr mbarr# r) #)      } +-- | This function is similar to 'mallocForeignPtrBytes', except that the+-- size and alignment of the memory required is given explicitly as numbers of+-- bytes.+mallocForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)+mallocForeignPtrAlignedBytes size _align | size < 0 =+  error "mallocForeignPtrAlignedBytes: size must be >= 0"+mallocForeignPtrAlignedBytes (I# size) (I# align) = do+  r <- newIORef (NoFinalizers, [])+  IO $ \s ->+     case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->+       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                         (MallocPtr mbarr# r) #)+     }+ -- | Allocate some memory and return a 'ForeignPtr' to it.  The memory -- will be released automatically when the 'ForeignPtr' is discarded. --@@ -221,6 +238,19 @@                          (PlainPtr mbarr#) #)      } +-- | This function is similar to 'mallocForeignPtrAlignedBytes', except that+-- the internally an optimised ForeignPtr representation with no+-- finalizer is used. Attempts to add a finalizer will cause an+-- exception to be thrown.+mallocPlainForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)+mallocPlainForeignPtrAlignedBytes size _align | size < 0 =+  error "mallocPlainForeignPtrAlignedBytes: size must be >= 0"+mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ \s ->+    case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->+       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                         (PlainPtr mbarr#) #)+     }+ addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO () -- ^This function adds a finalizer to the given foreign object.  The -- finalizer will run /before/ all other finalizers for the same@@ -312,7 +342,9 @@        return (null fs)  foreignPtrFinalizer :: IORef (Finalizers, [IO ()]) -> IO ()-foreignPtrFinalizer r = do (_, fs) <- readIORef r; sequence_ fs+foreignPtrFinalizer r = do+  fs <- atomicModifyIORef r $ \(f,fs) -> ((f,[]), fs) -- atomic, see #7170+  sequence_ fs  newForeignPtr_ :: Ptr a -> IO (ForeignPtr a) -- ^Turns a plain memory reference into a foreign pointer that may be@@ -377,10 +409,7 @@ -- immediately. finalizeForeignPtr :: ForeignPtr a -> IO () finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect-finalizeForeignPtr (ForeignPtr _ foreignPtr) = do-        (ftype, finalizers) <- readIORef refFinalizers-        sequence_ finalizers-        writeIORef refFinalizers (ftype, [])+finalizeForeignPtr (ForeignPtr _ foreignPtr) = foreignPtrFinalizer refFinalizers         where                 refFinalizers = case foreignPtr of                         (PlainForeignPtr ref) -> ref

@@ -0,0 +1,44 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.GHCi+-- Copyright   :  (c) The University of Glasgow 2012+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The GHCi Monad lifting interface.+--+-- EXPERIMENTAL! DON'T USE.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.GHCi {-# WARNING "This is an unstable interface." #-} (+        GHCiSandboxIO(..), NoIO()+    ) where++import GHC.Base (IO(), Monad, (>>=), return, id, (.))++-- | A monad that can execute GHCi statements by lifting them out of+-- m into the IO monad. (e.g state monads)+class (Monad m) => GHCiSandboxIO m where+    ghciStepIO :: m a -> IO a++instance GHCiSandboxIO IO where+    ghciStepIO = id++-- | A monad that doesn't allow any IO.+newtype NoIO a = NoIO { noio :: IO a }++instance Monad NoIO where+    return a  = NoIO (return a)+    (>>=) k f = NoIO (noio k >>= noio . f)++instance GHCiSandboxIO NoIO where+    ghciStepIO = noio+

@@ -0,0 +1,271 @@+{-# LANGUAGE Trustworthy            #-}+{-# LANGUAGE NoImplicitPrelude      #-}+{-# LANGUAGE EmptyDataDecls         #-}+{-# LANGUAGE TypeSynonymInstances   #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE DeriveGeneric          #-}++module GHC.Generics  (+  -- * Generic representation types+    V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..)+  , (:+:)(..), (:*:)(..), (:.:)(..)++  -- ** Synonyms for convenience+  , Rec0, Par0, R, P+  , D1, C1, S1, D, C, S++  -- * Meta-information+  , Datatype(..), Constructor(..), Selector(..), NoSelector+  , Fixity(..), Associativity(..), Arity(..), prec++  -- * Generic type classes+  , Generic(..), Generic1(..)++  ) where++-- We use some base types+import GHC.Types+import Data.Maybe ( Maybe(..) )+import Data.Either ( Either(..) )++-- Needed for instances+import GHC.Classes ( Eq, Ord )+import GHC.Read ( Read )+import GHC.Show ( Show )++--------------------------------------------------------------------------------+-- Representation types+--------------------------------------------------------------------------------++-- | Void: used for datatypes without constructors+data V1 p++-- | Unit: used for constructors without arguments+data U1 p = U1++-- | Used for marking occurrences of the parameter+newtype Par1 p = Par1 { unPar1 :: p }+++-- | Recursive calls of kind * -> *+newtype Rec1 f p = Rec1 { unRec1 :: f p }++-- | Constants, additional parameters and recursion of kind *+newtype K1 i c p = K1 { unK1 :: c }++-- | Meta-information (constructor names, etc.)+newtype M1 i c f p = M1 { unM1 :: f p }++-- | Sums: encode choice between constructors+infixr 5 :+:+data (:+:) f g p = L1 (f p) | R1 (g p)++-- | Products: encode multiple arguments to constructors+infixr 6 :*:+data (:*:) f g p = f p :*: g p++-- | Composition of functors+infixr 7 :.:+newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) }++-- | Tag for K1: recursion (of kind *)+data R+-- | Tag for K1: parameters (other than the last)+data P++-- | Type synonym for encoding recursion (of kind *)+type Rec0  = K1 R+-- | Type synonym for encoding parameters (other than the last)+type Par0  = K1 P+{-# DEPRECATED Par0 "Par0 is no longer used; use Rec0 instead" #-}+{-# DEPRECATED P "P is no longer used; use R instead" #-}++-- | Tag for M1: datatype+data D+-- | Tag for M1: constructor+data C+-- | Tag for M1: record selector+data S++-- | Type synonym for encoding meta-information for datatypes+type D1 = M1 D++-- | Type synonym for encoding meta-information for constructors+type C1 = M1 C++-- | Type synonym for encoding meta-information for record selectors+type S1 = M1 S+++-- | Class for datatypes that represent datatypes+class Datatype d where+  -- | The name of the datatype (unqualified)+  datatypeName :: t d (f :: * -> *) a -> [Char]+  -- | The fully-qualified name of the module where the type is declared+  moduleName   :: t d (f :: * -> *) a -> [Char]+++-- | Class for datatypes that represent records+class Selector s where+  -- | The name of the selector+  selName :: t s (f :: * -> *) a -> [Char]++-- | Used for constructor fields without a name+data NoSelector++instance Selector NoSelector where selName _ = ""++-- | Class for datatypes that represent data constructors+class Constructor c where+  -- | The name of the constructor+  conName :: t c (f :: * -> *) a -> [Char]++  -- | The fixity of the constructor+  conFixity :: t c (f :: * -> *) a -> Fixity+  conFixity _ = Prefix++  -- | Marks if this constructor is a record+  conIsRecord :: t c (f :: * -> *) a -> Bool+  conIsRecord _ = False+++-- | Datatype to represent the arity of a tuple.+data Arity = NoArity | Arity Int+  deriving (Eq, Show, Ord, Read)++-- | Datatype to represent the fixity of a constructor. An infix+-- | declaration directly corresponds to an application of 'Infix'.+data Fixity = Prefix | Infix Associativity Int+  deriving (Eq, Show, Ord, Read)++-- | Get the precedence of a fixity value.+prec :: Fixity -> Int+prec Prefix      = 10+prec (Infix _ n) = n++-- | Datatype to represent the associativity of a constructor+data Associativity = LeftAssociative+                   | RightAssociative+                   | NotAssociative+  deriving (Eq, Show, Ord, Read)++-- | Representable types of kind *.+-- This class is derivable in GHC with the DeriveGeneric flag on.+class Generic a where+  -- | Generic representation type+  type Rep a :: * -> *+  -- | Convert from the datatype to its representation+  from  :: a -> (Rep a) x+  -- | Convert from the representation to the datatype+  to    :: (Rep a) x -> a+++-- | Representable types of kind * -> * (not yet derivable)+class Generic1 f where+  -- | Generic representation type+  type Rep1 f :: * -> *+  -- | Convert from the datatype to its representation+  from1  :: f a -> (Rep1 f) a+  -- | Convert from the representation to the datatype+  to1    :: (Rep1 f) a -> f a+++--------------------------------------------------------------------------------+-- Derived instances+--------------------------------------------------------------------------------+deriving instance Generic [a]+deriving instance Generic (Maybe a)+deriving instance Generic (Either a b)+deriving instance Generic Bool+deriving instance Generic Ordering+deriving instance Generic ()+deriving instance Generic ((,) a b)+deriving instance Generic ((,,) a b c)+deriving instance Generic ((,,,) a b c d)+deriving instance Generic ((,,,,) a b c d e)+deriving instance Generic ((,,,,,) a b c d e f)+deriving instance Generic ((,,,,,,) a b c d e f g)++deriving instance Generic1 []+deriving instance Generic1 Maybe+deriving instance Generic1 (Either a)+deriving instance Generic1 ((,) a)+deriving instance Generic1 ((,,) a b)+deriving instance Generic1 ((,,,) a b c)+deriving instance Generic1 ((,,,,) a b c d)+deriving instance Generic1 ((,,,,,) a b c d e)+deriving instance Generic1 ((,,,,,,) a b c d e f)++--------------------------------------------------------------------------------+-- Primitive representations+--------------------------------------------------------------------------------++-- Int+data D_Int+data C_Int++instance Datatype D_Int where+  datatypeName _ = "Int"+  moduleName   _ = "GHC.Int"++instance Constructor C_Int where+  conName _ = "" -- JPM: I'm not sure this is the right implementation...++instance Generic Int where+  type Rep Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int)))+  from x = M1 (M1 (M1 (K1 x)))+  to (M1 (M1 (M1 (K1 x)))) = x+++-- Float+data D_Float+data C_Float++instance Datatype D_Float where+  datatypeName _ = "Float"+  moduleName   _ = "GHC.Float"++instance Constructor C_Float where+  conName _ = "" -- JPM: I'm not sure this is the right implementation...++instance Generic Float where+  type Rep Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float)))+  from x = M1 (M1 (M1 (K1 x)))+  to (M1 (M1 (M1 (K1 x)))) = x+++-- Double+data D_Double+data C_Double++instance Datatype D_Double where+  datatypeName _ = "Double"+  moduleName   _ = "GHC.Float"++instance Constructor C_Double where+  conName _ = "" -- JPM: I'm not sure this is the right implementation...++instance Generic Double where+  type Rep Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double)))+  from x = M1 (M1 (M1 (K1 x)))+  to (M1 (M1 (M1 (K1 x)))) = x+++-- Char+data D_Char+data C_Char++instance Datatype D_Char where+  datatypeName _ = "Char"+  moduleName   _ = "GHC.Base"++instance Constructor C_Char where+  conName _ = "" -- JPM: I'm not sure this is the right implementation...++instance Generic Char where+  type Rep Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char)))+  from x = M1 (M1 (M1 (K1 x)))+  to (M1 (M1 (M1 (K1 x)))) = x

@@ -30,6 +30,16 @@ import GHC.IO.Encoding.UTF16 (mkUTF16le, mkUTF16be) import GHC.IO.Encoding.UTF32 (mkUTF32le, mkUTF32be) +#ifdef mingw32_HOST_OS+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+#endif+ -- note CodePage = UInt which might not work on Win64.  But the Win32 package -- also has this issue. getCurrentCodePage :: IO Word32@@ -40,10 +50,10 @@         else getACP  -- Since the Win32 package depends on base, we have to import these ourselves:-foreign import stdcall unsafe "windows.h GetConsoleCP"+foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP"     getConsoleCP :: IO Word32 -foreign import stdcall unsafe "windows.h GetACP"+foreign import WINDOWS_CCONV unsafe "windows.h GetACP"     getACP :: IO Word32  {-# NOINLINE currentCodePage #-}

@@ -26,6 +26,7 @@ import GHC.IO.Exception  import GHC.Base+import GHC.Char import GHC.Word import GHC.Show import GHC.Num

@@ -58,6 +58,16 @@ import System.Posix.Internals hiding (FD, setEcho, getEcho) import System.Posix.Types +#ifdef mingw32_HOST_OS+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+#endif+ c_DEBUG_DUMP :: Bool c_DEBUG_DUMP = False @@ -155,11 +165,7 @@     let        oflags1 = case iomode of                   ReadMode      -> read_flags-#ifdef mingw32_HOST_OS-                  WriteMode     -> write_flags .|. o_TRUNC-#else                   WriteMode     -> write_flags-#endif                   ReadWriteMode -> rw_flags                   AppendMode    -> append_flags @@ -167,7 +173,7 @@       binary_flags = o_BINARY #else       binary_flags = 0-#endif      +#endif        oflags2 = oflags1 .|. binary_flags @@ -190,14 +196,11 @@             `catchAny` \e -> do _ <- c_close fd                                 throwIO e -#ifndef mingw32_HOST_OS-        -- we want to truncate() if this is an open in WriteMode, but only-        -- if the target is a RegularFile.  ftruncate() fails on special files-        -- like /dev/null.-    if iomode == WriteMode && fd_type == RegularFile-      then setSize fD 0-      else return ()-#endif+    -- we want to truncate() if this is an open in WriteMode, but only+    -- if the target is a RegularFile.  ftruncate() fails on special files+    -- like /dev/null.+    when (iomode == WriteMode && fd_type == RegularFile) $+      setSize fD 0      return (fD,fd_type) @@ -241,30 +244,27 @@                    ReadMode -> False                    _ -> True -#ifdef mingw32_HOST_OS-    _ <- setmode fd True -- unconditionally set binary mode-    let _ = (dev,ino,write) -- warning suppression-#endif-     case fd_type of         Directory ->             ioException (IOError Nothing InappropriateType "openFile"                            "is a directory" Nothing Nothing) -#ifndef mingw32_HOST_OS         -- regular files need to be locked         RegularFile -> do-           -- On Windows we use explicit exclusion via sopen() to implement-           -- this locking (see __hscore_open()); on Unix we have to-           -- implment it in the RTS.-           r <- lockFile fd dev ino (fromBool write)+           -- On Windows we need an additional call to get a unique device id+           -- and inode, since fstat just returns 0 for both.+           (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino+           r <- lockFile fd unique_dev unique_ino (fromBool write)            when (r == -1)  $                 ioException (IOError Nothing ResourceBusy "openFile"                                    "file is locked" Nothing Nothing)-#endif          _other_type -> return () +#ifdef mingw32_HOST_OS+    _ <- setmode fd True -- unconditionally set binary mode+#endif+     return (FD{ fdFD = fd, #ifndef mingw32_HOST_OS                 fdIsNonBlocking = fromEnum is_nonblock@@ -274,6 +274,17 @@               },             fd_type) +getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)+#ifndef mingw32_HOST_OS+getUniqueFileInfo _ dev ino = return (fromIntegral dev, fromIntegral ino)+#else+getUniqueFileInfo fd _ _ = do+  with 0 $ \devptr -> do+  with 0 $ \inoptr -> do+  c_getUniqueFileInfo fd devptr inoptr+  liftM2 (,) (peek devptr) (peek inoptr)+#endif+ #ifdef mingw32_HOST_OS foreign import ccall unsafe "__hscore_setmode"   setmode :: CInt -> Bool -> IO CInt@@ -304,9 +315,7 @@  close :: FD -> IO () close fd =-#ifndef mingw32_HOST_OS   (flip finally) (release fd) $-#endif   do let closer realFd =            throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $ #ifdef mingw32_HOST_OS@@ -318,15 +327,11 @@      closeFdWith closer (fromIntegral (fdFD fd))  release :: FD -> IO ()-#ifdef mingw32_HOST_OS-release _ = return ()-#else release fd = do _ <- unlockFile (fdFD fd)                 return ()-#endif  #ifdef mingw32_HOST_OS-foreign import stdcall unsafe "HsBase.h closesocket"+foreign import WINDOWS_CCONV unsafe "HsBase.h closesocket"    c_closesocket :: CInt -> IO CInt #endif @@ -625,10 +630,10 @@ -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. -foreign import stdcall safe "recv"+foreign import WINDOWS_CCONV safe "recv"    c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize -foreign import stdcall safe "send"+foreign import WINDOWS_CCONV safe "send"    c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize  #endif@@ -657,11 +662,13 @@ -- ----------------------------------------------------------------------------- -- Locking/unlocking -#ifndef mingw32_HOST_OS foreign import ccall unsafe "lockFile"-  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt+  lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt  foreign import ccall unsafe "unlockFile"   unlockFile :: CInt -> IO CInt-#endif +#ifdef mingw32_HOST_OS+foreign import ccall unsafe "get_unique_file_info"+  c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()+#endif

@@ -0,0 +1,14 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+module GHC.IP (IP(..)) where++import GHC.TypeLits++-- | The syntax @?x :: a@ is desugared into @IP "x" a@+class IP (x :: Symbol) a | x -> a where+  ip :: a++

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash,+{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, UnboxedTuples,              StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-} @@ -50,7 +50,7 @@ -- Int8 is represented in the same way as Int. Operations may assume -- and must ensure that it holds only values from its logical range. -data Int8 = I8# Int# deriving (Eq, Ord)+data {-# CTYPE "HsInt8" #-} Int8 = I8# Int# deriving (Eq, Ord) -- ^ 8-bit signed integer type  instance Show Int8 where@@ -105,14 +105,18 @@         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I8# (narrow8Int# (x# `quotInt#` y#)),-                                       I8# (narrow8Int# (x# `remInt#` y#)))+        | otherwise                  = case x# `quotRemInt#` y# of+                                       (# q, r #) ->+                                           (I8# (narrow8Int# q),+                                            I8# (narrow8Int# r))     divMod  x@(I8# x#) y@(I8# y#)         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I8# (narrow8Int# (x# `divInt#` y#)),-                                       I8# (narrow8Int# (x# `modInt#` y#)))+        | otherwise                  = case x# `divModInt#` y# of+                                       (# d, m #) ->+                                           (I8# (narrow8Int# d),+                                            I8# (narrow8Int# m))     toInteger (I8# x#)               = smallInteger x#  instance Bounded Int8 where@@ -129,6 +133,8 @@  instance Bits Int8 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (I8# x#) .&.   (I8# y#)   = I8# (word2Int# (int2Word# x# `and#` int2Word# y#))     (I8# x#) .|.   (I8# y#)   = I8# (word2Int# (int2Word# x# `or#`  int2Word# y#))@@ -149,10 +155,12 @@                                        (x'# `uncheckedShiftRL#` (8# -# i'#)))))         where         !x'# = narrow8Word# (int2Word# x#)-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)+        !i'# = word2Int# (int2Word# i# `and#` 7##)     bitSize  _                = 8     isSigned _                = True     popCount (I8# x#)         = I# (word2Int# (popCnt8# (int2Word# x#)))+    bit                       = bitDefault+    testBit                   = testBitDefault  {-# RULES "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8@@ -197,7 +205,7 @@ -- Int16 is represented in the same way as Int. Operations may assume -- and must ensure that it holds only values from its logical range. -data Int16 = I16# Int# deriving (Eq, Ord)+data {-# CTYPE "HsInt16" #-} Int16 = I16# Int# deriving (Eq, Ord) -- ^ 16-bit signed integer type  instance Show Int16 where@@ -252,14 +260,18 @@         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I16# (narrow16Int# (x# `quotInt#` y#)),-                                        I16# (narrow16Int# (x# `remInt#` y#)))+        | otherwise                  = case x# `quotRemInt#` y# of+                                       (# q, r #) ->+                                           (I16# (narrow16Int# q),+                                            I16# (narrow16Int# r))     divMod  x@(I16# x#) y@(I16# y#)         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I16# (narrow16Int# (x# `divInt#` y#)),-                                        I16# (narrow16Int# (x# `modInt#` y#)))+        | otherwise                  = case x# `divModInt#` y# of+                                       (# d, m #) ->+                                           (I16# (narrow16Int# d),+                                            I16# (narrow16Int# m))     toInteger (I16# x#)              = smallInteger x#  instance Bounded Int16 where@@ -276,6 +288,8 @@  instance Bits Int16 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (I16# x#) .&.   (I16# y#)  = I16# (word2Int# (int2Word# x# `and#` int2Word# y#))     (I16# x#) .|.   (I16# y#)  = I16# (word2Int# (int2Word# x# `or#`  int2Word# y#))@@ -296,11 +310,12 @@                                          (x'# `uncheckedShiftRL#` (16# -# i'#)))))         where         !x'# = narrow16Word# (int2Word# x#)-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)+        !i'# = word2Int# (int2Word# i# `and#` 15##)     bitSize  _                 = 16     isSigned _                 = True     popCount (I16# x#)         = I# (word2Int# (popCnt16# (int2Word# x#)))-+    bit                        = bitDefault+    testBit                    = testBitDefault  {-# RULES "fromIntegral/Word8->Int16"  fromIntegral = \(W8# x#) -> I16# (word2Int# x#)@@ -350,7 +365,7 @@ -- from its logical range. #endif -data Int32 = I32# Int# deriving (Eq, Ord)+data {-# CTYPE "HsInt32" #-} Int32 = I32# Int# deriving (Eq, Ord) -- ^ 32-bit signed integer type  instance Show Int32 where@@ -414,14 +429,18 @@         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I32# (narrow32Int# (x# `quotInt#` y#)),-                                     I32# (narrow32Int# (x# `remInt#` y#)))+        | otherwise                  = case x# `quotRemInt#` y# of+                                       (# q, r #) ->+                                           (I32# (narrow32Int# q),+                                            I32# (narrow32Int# r))     divMod  x@(I32# x#) y@(I32# y#)         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I32# (narrow32Int# (x# `divInt#` y#)),-                                     I32# (narrow32Int# (x# `modInt#` y#)))+        | otherwise                  = case x# `divModInt#` y# of+                                       (# d, m #) ->+                                           (I32# (narrow32Int# d),+                                            I32# (narrow32Int# m))     toInteger (I32# x#)              = smallInteger x#  instance Read Int32 where@@ -429,6 +448,8 @@  instance Bits Int32 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (I32# x#) .&.   (I32# y#)  = I32# (word2Int# (int2Word# x# `and#` int2Word# y#))     (I32# x#) .|.   (I32# y#)  = I32# (word2Int# (int2Word# x# `or#`  int2Word# y#))@@ -450,10 +471,12 @@                                          (x'# `uncheckedShiftRL#` (32# -# i'#)))))         where         !x'# = narrow32Word# (int2Word# x#)-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+        !i'# = word2Int# (int2Word# i# `and#` 31##)     bitSize  _                 = 32     isSigned _                 = True     popCount (I32# x#)         = I# (word2Int# (popCnt32# (int2Word# x#)))+    bit                        = bitDefault+    testBit                    = testBitDefault  {-# RULES "fromIntegral/Word8->Int32"  fromIntegral = \(W8# x#) -> I32# (word2Int# x#)@@ -513,7 +536,7 @@  #if WORD_SIZE_IN_BITS < 64 -data Int64 = I64# Int64#+data {-# CTYPE "HsInt64" #-} Int64 = I64# Int64# -- ^ 64-bit signed integer type  instance Eq Int64 where@@ -616,6 +639,8 @@  instance Bits Int64 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (I64# x#) .&.   (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#))     (I64# x#) .|.   (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `or64#`  int64ToWord64# y#))@@ -636,11 +661,13 @@                                 (x'# `uncheckedShiftRL64#` (64# -# i'#))))         where         !x'# = int64ToWord64# x#-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+        !i'# = word2Int# (int2Word# i# `and#` 63##)     bitSize  _                 = 64     isSigned _                 = True     popCount (I64# x#)         =         I# (word2Int# (popCnt64# (int64ToWord64# x#)))+    bit                        = bitDefault+    testBit                    = testBitDefault  -- 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@@ -675,7 +702,7 @@ -- Operations may assume and must ensure that it holds only values -- from its logical range. -data Int64 = I64# Int# deriving (Eq, Ord)+data {-# CTYPE "HsInt64" #-} Int64 = I64# Int# deriving (Eq, Ord) -- ^ 64-bit signed integer type  instance Show Int64 where@@ -732,12 +759,16 @@         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#))+        | otherwise                  = case x# `quotRemInt#` y# of+                                       (# q, r #) ->+                                           (I64# q, I64# r)     divMod  x@(I64# x#) y@(I64# y#)         | y == 0                     = divZeroError           -- Note [Order of tests]         | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#))+        | otherwise                  = case x# `divModInt#` y# of+                                       (# d, m #) ->+                                           (I64# d, I64# m)     toInteger (I64# x#)              = smallInteger x#  instance Read Int64 where@@ -745,6 +776,8 @@  instance Bits Int64 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (I64# x#) .&.   (I64# y#)  = I64# (word2Int# (int2Word# x# `and#` int2Word# y#))     (I64# x#) .|.   (I64# y#)  = I64# (word2Int# (int2Word# x# `or#`  int2Word# y#))@@ -765,10 +798,12 @@                            (x'# `uncheckedShiftRL#` (64# -# i'#))))         where         !x'# = int2Word# x#-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+        !i'# = word2Int# (int2Word# i# `and#` 63##)     bitSize  _                 = 64     isSigned _                 = True     popCount (I64# x#)         = I# (word2Int# (popCnt64# (int2Word# x#)))+    bit                        = bitDefault+    testBit                    = testBitDefault  {-# RULES "fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x#

@@ -31,7 +31,6 @@     ) where  import GHC.Base-import GHC.IO ()   -- instance Monad IO import Data.Maybe  data MVar a = MVar (MVar# RealWorld a)

@@ -83,26 +83,36 @@  \begin{code} instance  Num Int  where-    (+)    = plusInt-    (-)    = minusInt-    negate = negateInt-    (*)    = timesInt-    abs n  = if n `geInt` 0 then n else negateInt n+    I# x + I# y = I# (x +# y)+    I# x - I# y = I# (x -# y)+    negate (I# x) = I# (negateInt# x)+    I# x * I# y = I# (x *# y)+    abs n  = if n `geInt` 0 then n else negate n -    signum n | n `ltInt` 0 = negateInt 1+    signum n | n `ltInt` 0 = negate 1              | n `eqInt` 0 = 0              | otherwise   = 1      {-# INLINE fromInteger #-}	 -- Just to be sure!     fromInteger i = I# (integerToInt i)+\end{code} -quotRemInt :: Int -> Int -> (Int, Int)-quotRemInt a@(I# _) b@(I# _) = (a `quotInt` b, a `remInt` b)-    -- OK, so I made it a little stricter.  Shoot me.  (WDP 94/10)+%*********************************************************+%*                                                      *+\subsection{Instances for @Word@}+%*                                                      *+%********************************************************* -divModInt ::  Int -> Int -> (Int, Int)-divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y)-    -- Stricter.  Sorry if you don't like it.  (WDP 94/10)+\begin{code}+instance Num Word where+    (W# x#) + (W# y#)      = W# (x# `plusWord#` y#)+    (W# x#) - (W# y#)      = W# (x# `minusWord#` y#)+    (W# x#) * (W# y#)      = W# (x# `timesWord#` y#)+    negate (W# x#)         = W# (int2Word# (negateInt# (word2Int# x#)))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W# (integerToWord i) \end{code}  %*********************************************************

@@ -65,9 +65,7 @@  import Data.Maybe -#ifndef __HADDOCK__ import {-# SOURCE #-} GHC.Unicode       ( isDigit )-#endif import GHC.Num import GHC.Real import GHC.Float@@ -75,8 +73,6 @@ import GHC.Base import GHC.Err import GHC.Arr--- For defining instances for the generic deriving mechanism-import GHC.Generics (Arity(..), Associativity(..), Fixity(..)) \end{code}  @@ -278,10 +274,6 @@ -- ^ Parse a single lexeme lexP = lift L.lex -lexP' :: ReadPrec L.Lexeme'--- ^ Parse a single lexeme-lexP' = lift L.lex'- paren :: ReadPrec a -> ReadPrec a -- ^ @(paren p)@ parses \"(P0)\" --      where @p@ parses \"P0\" in precedence context zero@@ -461,28 +453,28 @@ %*********************************************************  \begin{code}-readNumber :: Num a => (L.Lexeme' -> ReadPrec a) -> ReadPrec a+readNumber :: Num a => (L.Lexeme -> ReadPrec a) -> ReadPrec a -- Read a signed number readNumber convert =   parens-  ( do x <- lexP'+  ( do x <- lexP        case x of-         L.Symbol' "-" -> do y <- lexP'-                             n <- convert y-                             return (negate n)+         L.Symbol "-" -> do y <- lexP+                            n <- convert y+                            return (negate n)           _   -> convert x   )  -convertInt :: Num a => L.Lexeme' -> ReadPrec a+convertInt :: Num a => L.Lexeme -> ReadPrec a convertInt (L.Number n)  | Just i <- L.numberToInteger n = return (fromInteger i) convertInt _ = pfail -convertFrac :: forall a . RealFloat a => L.Lexeme' -> ReadPrec a-convertFrac (L.Ident' "NaN")      = return (0 / 0)-convertFrac (L.Ident' "Infinity") = return (1 / 0)+convertFrac :: forall a . RealFloat a => L.Lexeme -> ReadPrec a+convertFrac (L.Ident "NaN")      = return (0 / 0)+convertFrac (L.Ident "Infinity") = return (1 / 0) convertFrac (L.Number n) = let resRange = floatRange (undefined :: a)                            in case L.numberToRangedRational resRange n of                               Nothing -> return (1 / 0)@@ -494,6 +486,9 @@   readListPrec = readListPrecDefault   readList     = readListDefault +instance Read Word where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]+ instance Read Integer where   readPrec     = readNumber convertInt   readListPrec = readListPrecDefault@@ -692,12 +687,4 @@  readp :: Read a => ReadP a readp = readPrec_to_P readPrec minPrec-\end{code}--Instances for types of the generic deriving mechanism.--\begin{code}-deriving instance Read Arity-deriving instance Read Associativity-deriving instance Read Fixity \end{code}

@@ -1,6 +1,7 @@ \begin{code} {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- |@@ -91,7 +92,7 @@ \begin{code} reduce ::  (Integral a) => a -> a -> Ratio a {-# SPECIALISE reduce :: Integer -> Integer -> Rational #-}-reduce _ 0              =  error "Ratio.%: zero denominator"+reduce _ 0              =  ratioZeroDenominatorError reduce x y              =  (x `quot` d) :% (y `quot` d)                            where d = gcd x y \end{code}@@ -292,6 +293,64 @@  %********************************************************* %*                                                      *+\subsection{Instances for @Word@}+%*                                                      *+%*********************************************************++\begin{code}+instance Real Word where+    toRational x = toInteger x % 1++instance Integral Word where+    quot    (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `quotWord#` y#)+        | otherwise             = divZeroError+    rem     (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `remWord#` y#)+        | otherwise             = divZeroError+    div     (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `quotWord#` y#)+        | otherwise             = divZeroError+    mod     (W# x#) y@(W# y#)+        | y /= 0                = W# (x# `remWord#` y#)+        | otherwise             = divZeroError+    quotRem (W# x#) y@(W# y#)+        | y /= 0                = case x# `quotRemWord#` y# of+                                  (# q, r #) ->+                                      (W# q, W# r)+        | otherwise             = divZeroError+    divMod  (W# x#) y@(W# y#)+        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))+        | otherwise             = divZeroError+    toInteger (W# x#)+        | i# >=# 0#             = smallInteger i#+        | otherwise             = wordToInteger x#+        where+        !i# = word2Int# x#++instance Enum Word where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Word"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Word"+    toEnum i@(I# i#)+        | i >= 0        = W# (int2Word# i#)+        | otherwise     = toEnumError "Word" i (minBound::Word, maxBound::Word)+    fromEnum x@(W# x#)+        | x <= fromIntegral (maxBound::Int)+                        = I# (word2Int# x#)+        | otherwise     = fromEnumError "Word" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo+\end{code}+++%*********************************************************+%*                                                      * \subsection{Instances for @Integer@} %*                                                      * %*********************************************************@@ -309,6 +368,12 @@     _ `rem` 0 = divZeroError     n `rem`  d = n `remInteger`  d +    _ `div` 0 = divZeroError+    n `div` d = n `divInteger` d++    _ `mod` 0 = divZeroError+    n `mod`  d = n `modInteger`  d+     _ `divMod` 0 = divZeroError     a `divMod` b = case a `divModInteger` b of                    (# x, y #) -> (x, y)@@ -347,7 +412,7 @@ instance  (Integral a)  => Fractional (Ratio a)  where     {-# SPECIALIZE instance Fractional Rational #-}     (x:%y) / (x':%y')   =  (x*y') % (y*x')-    recip (0:%_)        = error "Ratio.%: zero denominator"+    recip (0:%_)        = ratioZeroDenominatorError     recip (x:%y)         | x < 0         = negate y :% negate x         | otherwise     = y :% x@@ -403,6 +468,12 @@ "fromIntegral/Int->Int" fromIntegral = id :: Int -> Int     #-} +{-# RULES+"fromIntegral/Int->Word"  fromIntegral = \(I# x#) -> W# (int2Word# x#)+"fromIntegral/Word->Int"  fromIntegral = \(W# x#) -> I# (word2Int# x#)+"fromIntegral/Word->Word" fromIntegral = id :: Word -> Word+    #-}+ -- | general coercion to fractional types realToFrac :: (Real a, Fractional b) => a -> b realToFrac = fromRational . toRational@@ -557,7 +628,7 @@     | e > 0     = (n ^ e) :% (d ^ e)     | e == 0    = 1 :% 1     | n > 0     = (d ^ (negate e)) :% (n ^ (negate e))-    | n == 0    = error "Ratio.%: zero denominator"+    | n == 0    = ratioZeroDenominatorError     | otherwise = let nn = d ^ (negate e)                       dd = (negate n) ^ (negate e)                   in if even e then (nn :% dd) else (negate nn :% dd)

@@ -27,7 +27,6 @@  import GHC.Base import GHC.Show-import Control.Monad( forever )  default () \end{code}@@ -81,9 +80,6 @@         (k2 new_s) }})  data STret s a = STret (State# s) a--{-# SPECIALISE forever :: ST s a -> ST s b #-}--- See Note [Make forever INLINABLE] in Control.Monad  -- liftST is useful when we want a lifted result from an ST computation.  See -- fixST below.

@@ -55,8 +55,6 @@ import GHC.Num import Data.Maybe import GHC.List ((!!), foldr1, break)--- For defining instances for the generic deriving mechanism-import GHC.Generics (Arity(..), Associativity(..), Fixity(..)) \end{code}  @@ -206,6 +204,16 @@ instance Show Int where     showsPrec = showSignedInt +instance Show Word where+    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 Show a => Show (Maybe a) where     showsPrec _p Nothing s = showString "Nothing" s     showsPrec p (Just x) s@@ -315,7 +323,7 @@ \begin{code} -- | equivalent to 'showsPrec' with a precedence of 0. shows           :: (Show a) => a -> ShowS-shows           =  showsPrec zeroInt+shows           =  showsPrec 0  -- | utility function converting a 'Char' to a show function that -- simply prepends the character unchanged.@@ -416,13 +424,10 @@ -- lower-case hexadecimal digits. intToDigit :: Int -> Char intToDigit (I# i)-    | i >=# 0#  && i <=#  9# =  unsafeChr (ord '0' `plusInt` I# i)-    | i >=# 10# && i <=# 15# =  unsafeChr (ord 'a' `minusInt` ten `plusInt` I# i)+    | i >=# 0#  && i <=#  9# =  unsafeChr (ord '0' + I# i)+    | i >=# 10# && i <=# 15# =  unsafeChr (ord 'a' + I# i - 10)     | otherwise           =  error ("Char.intToDigit: not a digit " ++ show (I# i)) -ten :: Int-ten = I# 10#- showSignedInt :: Int -> Int -> ShowS showSignedInt (I# p) (I# n) r     | n <# 0# && p ># 6# = '(' : itos n (')' : r)@@ -434,24 +439,20 @@         let !(I# minInt#) = minInt in         if n# ==# minInt#                 -- negateInt# minInt overflows, so we can't do that:-           then '-' : itos' (negateInt# (n# `quotInt#` 10#))-                             (itos' (negateInt# (n# `remInt#` 10#)) cs)+           then '-' : (case n# `quotRemInt#` 10# of+                       (# q, r #) ->+                           itos' (negateInt# q) (itos' (negateInt# r) cs))            else '-' : itos' (negateInt# n#) cs     | otherwise = itos' n# cs     where     itos' :: Int# -> String -> String     itos' x# cs'         | x# <# 10#  = C# (chr# (ord# '0'# +# x#)) : cs'-        | otherwise = case chr# (ord# '0'# +# (x# `remInt#` 10#)) of { c# ->-                      itos' (x# `quotInt#` 10#) (C# c# : cs') }-\end{code}--Instances for types of the generic deriving mechanism.--\begin{code}-deriving instance Show Arity-deriving instance Show Associativity-deriving instance Show Fixity+        | otherwise = case x# `quotRemInt#` 10# of+                      (# q, r #) ->+                          case chr# (ord# '0'# +# r) of+                          c# ->+                              itos' q (C# c# : cs') \end{code}  

@@ -48,7 +48,7 @@ A value of type @StablePtr a@ is a stable pointer to a Haskell expression of type @a@. -}-data StablePtr a = StablePtr (StablePtr# a)+data {-# CTYPE "HsStablePtr" #-} StablePtr a = StablePtr (StablePtr# a)  -- | -- Create a stable pointer referring to the given Haskell value.

@@ -15,16 +15,20 @@ module GHC.Stats     ( GCStats(..)     , getGCStats+    , getGCStatsEnabled ) where +import Control.Monad+import Data.Int+import GHC.IO.Exception import Foreign.Marshal.Alloc import Foreign.Storable import Foreign.Ptr-import Data.Int  #include "Rts.h" -foreign import ccall "getGCStats"    getGCStats_    :: Ptr () -> IO ()+foreign import ccall "getGCStats"        getGCStats_       :: Ptr () -> IO ()+foreign import ccall "getGCStatsEnabled" getGCStatsEnabled :: IO Bool  -- I'm probably violating a bucket of constraints here... oops. @@ -58,9 +62,9 @@     -- lists held by the capabilities.  Can be used with     -- 'parMaxBytesCopied' to determine how well parallel GC utilized     -- all cores.-    , parAvgBytesCopied :: !Int64+    , parTotBytesCopied :: !Int64     -- | Sum of number of bytes copied each GC by the most active GC-    -- thread each GC.  The ratio of 'parAvgBytesCopied' divided by+    -- thread each GC.  The ratio of 'parTotBytesCopied' 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.@@ -76,7 +80,16 @@ -- 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 = do+  statsEnabled <- getGCStatsEnabled+  unless statsEnabled .  ioError $ IOError+    Nothing+    UnsupportedOperation+    ""+    "getGCStats: GC stats not enabled. Use `+RTS -T -RTS' to enable them."+    Nothing+    Nothing+  allocaBytes (#size GCStats) $ \p -> do     getGCStats_ p     bytesAllocated <- (# peek GCStats, bytes_allocated) p     numGcs <- (# peek GCStats, num_gcs ) p@@ -98,7 +111,7 @@     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+    parTotBytesCopied <- (# peek GCStats, par_tot_bytes_copied) p     parMaxBytesCopied <- (# peek GCStats, par_max_bytes_copied) p     return GCStats { .. } 

@@ -104,14 +104,6 @@ 	-> IO CInt			-- (ret) old action code #endif --- make a weak pointer to a ThreadId: holding the weak pointer doesn't--- keep the thread alive and prevent it from being identified as--- deadlocked.  Vitally important for the main thread.-mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)-mkWeakThreadId t@(ThreadId t#) = IO $ \s ->-   case mkWeak# t# t (unsafeCoerce# 0#) s of -      (# s1, w #) -> (# s1, Weak w #)- -- | 'runIO' is wrapped around every @foreign export@ and @foreign -- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the -- result of running 'System.Exit.exitWith' in a foreign-exported

@@ -0,0 +1,187 @@+{-# LANGUAGE DataKinds #-}              -- to declare the kinds+{-# LANGUAGE KindSignatures #-}         -- (used all over)+{-# LANGUAGE TypeFamilies #-}           -- for declaring operators + sing family+{-# LANGUAGE TypeOperators #-}          -- for declaring operator+{-# LANGUAGE EmptyDataDecls #-}         -- for declaring the kinds+{-# LANGUAGE GADTs #-}                  -- for examining type nats+{-# LANGUAGE PolyKinds #-}              -- for Sing family+{-# LANGUAGE UndecidableInstances #-}   -- for a bunch of the instances+{-# LANGUAGE FlexibleInstances #-}      -- for kind parameters+{-# LANGUAGE FlexibleContexts #-}       -- for kind parameters+{-# LANGUAGE ScopedTypeVariables #-}    -- for kind parameters+{-# LANGUAGE MultiParamTypeClasses #-}  -- for <=, singRep, SingE+{-# LANGUAGE FunctionalDependencies #-} -- for SingRep and SingE+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-| This module is an internal GHC module.  It declares the constants used+in the implementation of type-level natural numbers.  The programmer interface+for workin with type-level naturals should be defined in a separate library. -}++module GHC.TypeLits+  ( -- * Kinds+    Nat, Symbol++    -- * Linking type and value level+  , Sing, SingI, SingE, SingRep, sing, fromSing+  , unsafeSingNat, unsafeSingSymbol+  , Kind++    -- * Working with singletons+  , withSing, singThat++    -- * Functions on type nats+  , type (<=), type (<=?), type (+), type (*), type (^)++    -- * Destructing type-nats.+  , isZero, IsZero(..)+  , isEven, IsEven(..)+  ) where++import GHC.Base(Eq((==)), Bool(..), ($), otherwise, (.))+import GHC.Num(Integer, (-))+import GHC.Base(String)+import GHC.Read(Read(..))+import GHC.Show(Show(..))+import GHC.Prim(Any)+import Unsafe.Coerce(unsafeCoerce)+import Data.Bits(testBit,shiftR)+import Data.Maybe(Maybe(..))+import Data.List((++))++-- | A type synonym useful for passing kinds as parameters.+type Kind = Any+++-- | This is the *kind* of type-level natural numbers.+data Nat++-- | This is the *kind* of type-level symbols.+data Symbol+++--------------------------------------------------------------------------------+data family Sing (n :: k)++newtype instance Sing (n :: Nat)    = SNat Integer++newtype instance Sing (n :: Symbol) = SSym String++unsafeSingNat :: Integer -> Sing (n :: Nat)+unsafeSingNat = SNat++unsafeSingSymbol :: String -> Sing (n :: Symbol)+unsafeSingSymbol = SSym++--------------------------------------------------------------------------------++-- | The class 'SingI' provides a \"smart\" constructor for singleton types.+-- There are built-in instances for the singleton types corresponding+-- to type literals.++class SingI a where++  -- | The only value of type @Sing a@+  sing :: Sing a++--------------------------------------------------------------------------------+-- | Comparsion of type-level naturals.+class (m :: Nat) <= (n :: Nat)++type family (m :: Nat) <=? (n :: Nat) :: Bool++-- | Addition of type-level naturals.+type family (m :: Nat) + (n :: Nat) :: Nat++-- | Multiplication of type-level naturals.+type family (m :: Nat) * (n :: Nat) :: Nat++-- | Exponentiation of type-level naturals.+type family (m :: Nat) ^ (n :: Nat) :: Nat+++--------------------------------------------------------------------------------++{- | A class that converts singletons of a given kind into values of some+representation type (i.e., we "forget" the extra information carried+by the singletons, and convert them to ordinary values).++Note that 'fromSing' is overloaded based on the /kind/ of the values+and not their type---all types of a given kind are processed by the+same instances.+-}++class (kparam ~ Kind) => SingE (kparam :: k) rep | kparam -> rep where+  fromSing :: Sing (a :: k) -> rep++instance SingE (Kind :: Nat) Integer where+  fromSing (SNat n) = n++instance SingE (Kind :: Symbol) String where+  fromSing (SSym s) = s+++{- | A convenience class, useful when we need to both introduce and eliminate+a given singleton value. Users should never need to define instances of+this classes. -}+class    (SingI a, SingE (Kind :: k) rep) => SingRep (a :: k) rep | a -> rep+instance (SingI a, SingE (Kind :: k) rep) => SingRep (a :: k) rep+++{- | A convenience function useful when we need to name a singleton value+multiple times.  Without this function, each use of 'sing' could potentially+refer to a different singleton, and one has to use type signatures to+ensure that they are the same. -}++withSing :: SingI a => (Sing a -> b) -> b+withSing f = f sing+++{- | A convenience function that names a singleton satisfying a certain+property.  If the singleton does not satisfy the property, then the function+returns 'Nothing'. The property is expressed in terms of the underlying+representation of the singleton. -}++singThat :: (SingRep a rep) => (rep -> Bool) -> Maybe (Sing a)+singThat p = withSing $ \x -> if p (fromSing x) then Just x else Nothing++++instance (SingE (Kind :: k) rep, Show rep) => Show (Sing (a :: k)) where+  showsPrec p = showsPrec p . fromSing++instance (SingRep a rep, Read rep, Eq rep) => Read (Sing a) where+  readsPrec p cs = do (x,ys) <- readsPrec p cs+                      case singThat (== x) of+                        Just y  -> [(y,ys)]+                        Nothing -> []++++--------------------------------------------------------------------------------+data IsZero :: Nat -> * where+  IsZero :: IsZero 0+  IsSucc :: !(Sing n) -> IsZero (n + 1)++isZero :: Sing n -> IsZero n+isZero (SNat n) | n == 0    = unsafeCoerce IsZero+                | otherwise = unsafeCoerce (IsSucc (SNat (n-1)))++instance Show (IsZero n) where+  show IsZero     = "0"+  show (IsSucc n) = "(" ++ show n ++ " + 1)"++data IsEven :: Nat -> * where+  IsEvenZero :: IsEven 0+  IsEven     :: !(Sing (n+1)) -> IsEven (2 * n + 2)+  IsOdd      :: !(Sing n)     -> IsEven (2 * n + 1)++isEven :: Sing n -> IsEven n+isEven (SNat n) | n == 0      = unsafeCoerce IsEvenZero+                | testBit n 0 = unsafeCoerce (IsOdd  (SNat (n `shiftR` 1)))+                | otherwise   = unsafeCoerce (IsEven (SNat (n `shiftR` 1)))++instance Show (IsEven n) where+  show IsEvenZero = "0"+  show (IsEven x) = "(2 * " ++ show x ++ ")"+  show (IsOdd  x) = "(2 * " ++ show x ++ " + 1)"++

@@ -31,6 +31,7 @@     ) where  import GHC.Base+import GHC.Char import GHC.Real        (fromIntegral) import Foreign.C.Types (CInt(..)) @@ -129,9 +130,7 @@  -- ----------------------------------------------------------------------------- -- Implementation with the supplied auto-generated Unicode character properties--- table (default)--#if 1+-- table  -- Regardless of the O/S and Library, use the functions contained in WCsubst.c @@ -179,46 +178,4 @@  foreign import ccall unsafe "u_gencat"   wgencat :: CInt -> CInt---- -------------------------------------------------------------------------------- No libunicode, so fall back to the ASCII-only implementation (never used, indeed)--#else--isControl c             =  c < ' ' || c >= '\DEL' && c <= '\x9f'-isPrint c               =  not (isControl c)---- The upper case ISO characters have the multiplication sign dumped--- randomly in the middle of the range.  Go figure.-isUpper c               =  c >= 'A' && c <= 'Z' ||-                           c >= '\xC0' && c <= '\xD6' ||-                           c >= '\xD8' && c <= '\xDE'--- The lower case ISO characters have the division sign dumped--- randomly in the middle of the range.  Go figure.-isLower c               =  c >= 'a' && c <= 'z' ||-                           c >= '\xDF' && c <= '\xF6' ||-                           c >= '\xF8' && c <= '\xFF'--isAlpha c               =  isLower c || isUpper c-isAlphaNum c            =  isAlpha c || isDigit c---- Case-changing operations--toUpper c@(C# c#)-  | isAsciiLower c    = C# (chr# (ord# c# -# 32#))-  | isAscii c         = c-    -- fall-through to the slower stuff.-  | isLower c   && c /= '\xDF' && c /= '\xFF'-  = unsafeChr (ord c `minusInt` ord 'a' `plusInt` ord 'A')-  | otherwise-  = c---toLower c@(C# c#)-  | isAsciiUpper c = C# (chr# (ord# c# +# 32#))-  | isAscii c      = c-  | isUpper c      = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a')-  | otherwise      =  c--#endif 

@@ -94,7 +94,7 @@ mkWeak key val (Just finalizer) = IO $ \s ->    case mkWeak# key val finalizer s of { (# s1, w #) -> (# s1, Weak w #) } mkWeak key val Nothing = IO $ \s ->-   case mkWeak# key val (unsafeCoerce# 0#) s of { (# s1, w #) -> (# s1, Weak w #) }+   case mkWeakNoFinalizer# key val s of { (# s1, w #) -> (# s1, Weak w #) }  {-| Dereferences a weak pointer.  If the key is still alive, then

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash #-}+{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------@@ -43,141 +43,13 @@ import GHC.Float ()     -- for RealFrac methods  --------------------------------------------------------------------------- type Word----------------------------------------------------------------------------- |A 'Word' is an unsigned integral type, with the same size as 'Int'.-data Word = W# Word# deriving (Eq, Ord)--instance Show Word where-    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#)-    (W# x#) * (W# y#)      = W# (x# `timesWord#` y#)-    negate (W# x#)         = W# (int2Word# (negateInt# (word2Int# x#)))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger i          = W# (integerToWord i)--instance Real Word where-    toRational x = toInteger x % 1--instance Enum Word where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word"-    toEnum i@(I# i#)-        | i >= 0        = W# (int2Word# i#)-        | otherwise     = toEnumError "Word" i (minBound::Word, maxBound::Word)-    fromEnum x@(W# x#)-        | x <= fromIntegral (maxBound::Int)-                        = I# (word2Int# x#)-        | otherwise     = fromEnumError "Word" x-    enumFrom            = integralEnumFrom-    enumFromThen        = integralEnumFromThen-    enumFromTo          = integralEnumFromTo-    enumFromThenTo      = integralEnumFromThenTo--instance Integral Word where-    quot    (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `quotWord#` y#)-        | otherwise             = divZeroError-    rem     (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `remWord#` y#)-        | otherwise             = divZeroError-    div     (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `quotWord#` y#)-        | otherwise             = divZeroError-    mod     (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `remWord#` y#)-        | otherwise             = divZeroError-    quotRem (W# x#) y@(W# y#)-        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))-        | otherwise             = divZeroError-    divMod  (W# x#) y@(W# y#)-        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))-        | otherwise             = divZeroError-    toInteger (W# x#)-        | i# >=# 0#             = smallInteger i#-        | otherwise             = wordToInteger x#-        where-        !i# = word2Int# x#--instance Bounded Word where-    minBound = 0--    -- use unboxed literals for maxBound, because GHC doesn't optimise-    -- (fromInteger 0xffffffff :: Word).-#if WORD_SIZE_IN_BITS == 32-    maxBound = W# (int2Word# 0xFFFFFFFF#)-#else-    maxBound = W# (int2Word# 0xFFFFFFFFFFFFFFFF#)-#endif--instance Ix Word where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral (i - m)-    inRange (m,n) i     = m <= i && i <= n--instance Read Word where-    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]--instance Bits Word where-    {-# INLINE shift #-}--    (W# x#) .&.   (W# y#)    = W# (x# `and#` y#)-    (W# x#) .|.   (W# y#)    = W# (x# `or#`  y#)-    (W# x#) `xor` (W# y#)    = W# (x# `xor#` y#)-    complement (W# x#)       = W# (x# `xor#` mb#)-        where !(W# mb#) = maxBound-    (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'#)))-        where-        !i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))-        !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#)-"fromIntegral/Word->Int"  fromIntegral = \(W# x#) -> I# (word2Int# x#)-"fromIntegral/Word->Word" fromIntegral = id :: Word -> Word-  #-}---- No RULES for RealFrac unfortunately.--- Going through Int isn't possible because Word's range is not--- included in Int's, going through Integer may or may not be slower.-------------------------------------------------------------------------- -- type Word8 ------------------------------------------------------------------------  -- Word8 is represented in the same way as Word. Operations may assume -- and must ensure that it holds only values from its logical range. -data Word8 = W8# Word# deriving (Eq, Ord)+data {-# CTYPE "HsWord8" #-} Word8 = W8# Word# deriving (Eq, Ord) -- ^ 8-bit unsigned integer type  instance Show Word8 where@@ -225,7 +97,9 @@         | y /= 0                  = W8# (x# `remWord#` y#)         | otherwise               = divZeroError     quotRem (W8# x#) y@(W8# y#)-        | y /= 0                  = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))+        | y /= 0                  = case x# `quotRemWord#` y# of+                                    (# q, r #) ->+                                        (W8# q, W8# r)         | otherwise               = divZeroError     divMod  (W8# x#) y@(W8# y#)         | y /= 0                  = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))@@ -246,6 +120,8 @@  instance Bits Word8 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (W8# x#) .&.   (W8# y#)   = W8# (x# `and#` y#)     (W8# x#) .|.   (W8# y#)   = W8# (x# `or#`  y#)@@ -265,10 +141,12 @@         | otherwise  = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#`                                           (x# `uncheckedShiftRL#` (8# -# i'#))))         where-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)+        !i'# = word2Int# (int2Word# i# `and#` 7##)     bitSize  _                = 8     isSigned _                = False     popCount (W8# x#)         = I# (word2Int# (popCnt8# x#))+    bit                       = bitDefault+    testBit                   = testBitDefault  {-# RULES "fromIntegral/Word8->Word8"   fromIntegral = id :: Word8 -> Word8@@ -314,7 +192,7 @@ -- Word16 is represented in the same way as Word. Operations may assume -- and must ensure that it holds only values from its logical range. -data Word16 = W16# Word# deriving (Eq, Ord)+data {-# CTYPE "HsWord16" #-} Word16 = W16# Word# deriving (Eq, Ord) -- ^ 16-bit unsigned integer type  instance Show Word16 where@@ -362,7 +240,9 @@         | y /= 0                    = W16# (x# `remWord#` y#)         | otherwise                 = divZeroError     quotRem (W16# x#) y@(W16# y#)-        | y /= 0                    = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))+        | y /= 0                  = case x# `quotRemWord#` y# of+                                    (# q, r #) ->+                                        (W16# q, W16# r)         | otherwise                 = divZeroError     divMod  (W16# x#) y@(W16# y#)         | y /= 0                    = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))@@ -383,6 +263,8 @@  instance Bits Word16 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (W16# x#) .&.   (W16# y#)  = W16# (x# `and#` y#)     (W16# x#) .|.   (W16# y#)  = W16# (x# `or#`  y#)@@ -402,10 +284,12 @@         | otherwise  = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#`                                             (x# `uncheckedShiftRL#` (16# -# i'#))))         where-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)+        !i'# = word2Int# (int2Word# i# `and#` 15##)     bitSize  _                = 16     isSigned _                = False     popCount (W16# x#)        = I# (word2Int# (popCnt16# x#))+    bit                       = bitDefault+    testBit                   = testBitDefault  {-# RULES "fromIntegral/Word8->Word16"   fromIntegral = \(W8# x#) -> W16# x#@@ -488,7 +372,7 @@  #endif -data Word32 = W32# Word# deriving (Eq, Ord)+data {-# CTYPE "HsWord32" #-} Word32 = W32# Word# deriving (Eq, Ord) -- ^ 32-bit unsigned integer type  instance Num Word32 where@@ -544,7 +428,9 @@         | y /= 0                    = W32# (x# `remWord#` y#)         | otherwise                 = divZeroError     quotRem (W32# x#) y@(W32# y#)-        | y /= 0                    = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))+        | y /= 0                  = case x# `quotRemWord#` y# of+                                    (# q, r #) ->+                                        (W32# q, W32# r)         | otherwise                 = divZeroError     divMod  (W32# x#) y@(W32# y#)         | y /= 0                    = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))@@ -561,6 +447,8 @@  instance Bits Word32 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (W32# x#) .&.   (W32# y#)  = W32# (x# `and#` y#)     (W32# x#) .|.   (W32# y#)  = W32# (x# `or#`  y#)@@ -580,10 +468,12 @@         | otherwise  = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#`                                             (x# `uncheckedShiftRL#` (32# -# i'#))))         where-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+        !i'# = word2Int# (int2Word# i# `and#` 31##)     bitSize  _                = 32     isSigned _                = False     popCount (W32# x#)        = I# (word2Int# (popCnt32# x#))+    bit                       = bitDefault+    testBit                   = testBitDefault  {-# RULES "fromIntegral/Word8->Word32"   fromIntegral = \(W8# x#) -> W32# x#@@ -627,7 +517,7 @@  #if WORD_SIZE_IN_BITS < 64 -data Word64 = W64# Word64#+data {-# CTYPE "HsWord64" #-} Word64 = W64# Word64# -- ^ 64-bit unsigned integer type  instance Eq Word64 where@@ -692,6 +582,8 @@  instance Bits Word64 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (W64# x#) .&.   (W64# y#)  = W64# (x# `and64#` y#)     (W64# x#) .|.   (W64# y#)  = W64# (x# `or64#`  y#)@@ -709,10 +601,12 @@         | otherwise  = W64# ((x# `uncheckedShiftL64#` i'#) `or64#`                              (x# `uncheckedShiftRL64#` (64# -# i'#)))         where-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+        !i'# = word2Int# (int2Word# i# `and#` 63##)     bitSize  _                = 64     isSigned _                = False     popCount (W64# x#)        = I# (word2Int# (popCnt64# x#))+    bit                       = bitDefault+    testBit                   = testBitDefault  -- 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@@ -721,10 +615,10 @@  shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64# -a `shiftL64#` b  | b >=# 64#  = wordToWord64# (int2Word# 0#)+a `shiftL64#` b  | b >=# 64#  = wordToWord64# 0##                  | otherwise  = a `uncheckedShiftL64#` b -a `shiftRL64#` b | b >=# 64#  = wordToWord64# (int2Word# 0#)+a `shiftRL64#` b | b >=# 64#  = wordToWord64# 0##                  | otherwise  = a `uncheckedShiftRL64#` b  {-# RULES@@ -741,7 +635,7 @@ -- Operations may assume and must ensure that it holds only values -- from its logical range. -data Word64 = W64# Word# deriving (Eq, Ord)+data {-# CTYPE "HsWord64" #-} Word64 = W64# Word# deriving (Eq, Ord) -- ^ 64-bit unsigned integer type  instance Num Word64 where@@ -787,7 +681,9 @@         | y /= 0                    = W64# (x# `remWord#` y#)         | otherwise                 = divZeroError     quotRem (W64# x#) y@(W64# y#)-        | y /= 0                    = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))+        | y /= 0                  = case x# `quotRemWord#` y# of+                                    (# q, r #) ->+                                        (W64# q, W64# r)         | otherwise                 = divZeroError     divMod  (W64# x#) y@(W64# y#)         | y /= 0                    = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))@@ -800,6 +696,8 @@  instance Bits Word64 where     {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}      (W64# x#) .&.   (W64# y#)  = W64# (x# `and#` y#)     (W64# x#) .|.   (W64# y#)  = W64# (x# `or#`  y#)@@ -818,10 +716,12 @@         | otherwise  = W64# ((x# `uncheckedShiftL#` i'#) `or#`                              (x# `uncheckedShiftRL#` (64# -# i'#)))         where-        !i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+        !i'# = word2Int# (int2Word# i# `and#` 63##)     bitSize  _                = 64     isSigned _                = False     popCount (W64# x#)        = I# (word2Int# (popCnt64# x#))+    bit                       = bitDefault+    testBit                   = testBitDefault  {-# RULES "fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x#

@@ -111,9 +111,8 @@ readFloatP =   do tok <- L.lex      case tok of-       L.Rat y  -> return (fromRational y)-       L.Int i  -> return (fromInteger i)-       _        -> pfail+       L.Number n -> return $ fromRational $ L.numberToRational n+       _          -> pfail  -- It's turgid to have readSigned work using list comprehensions, -- but it's specified as a ReadS to ReadS transformer

@@ -141,7 +141,7 @@     FilePath,     readFile, writeFile, appendFile, readIO, readLn,     -- ** Exception handling in the I\/O monad-    IOError, ioError, userError, catch+    IOError, ioError, userError,    ) where 

@@ -72,6 +72,17 @@  #endif +##ifdef mingw32_HOST_OS+## if defined(i386_HOST_ARCH)+##  define WINDOWS_CCONV stdcall+## elif defined(x86_64_HOST_ARCH)+##  define WINDOWS_CCONV ccall+## else+##  error Unknown mingw32 arch+## endif+##else+##endif+ #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) realToInteger :: Real a => a -> Integer realToInteger ct = round (realToFrac ct :: Double)@@ -158,8 +169,8 @@ type FILETIME = () type HANDLE = () -- need proper Haskell names (initial lower-case character)-foreign import stdcall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)-foreign import stdcall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt+foreign import WINDOWS_CCONV unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)+foreign import WINDOWS_CCONV unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt  #endif /* not _WIN32 */ #endif /* __GLASGOW_HASKELL__ */

@@ -6,7 +6,7 @@ -- Module      :  System.Environment -- Copyright   :  (c) The University of Glasgow 2001 -- License     :  BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer  :  libraries@haskell.org -- Stability   :  provisional -- Portability :  portable@@ -17,9 +17,11 @@  module System.Environment     (-      getArgs,       -- :: IO [String]-      getProgName,   -- :: IO String-      getEnv,        -- :: String -> IO String+      getArgs,            -- :: IO [String]+      getProgName,        -- :: IO String+      getExecutablePath,  -- :: IO FilePath+      getEnv,             -- :: String -> IO String+      lookupEnv,          -- :: String -> IO (Maybe String) #ifndef __NHC__       withArgs,       withProgName,@@ -60,6 +62,18 @@   ) #endif +import System.Environment.ExecutablePath++#ifdef mingw32_HOST_OS+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+#endif+ #ifdef __GLASGOW_HASKELL__ -- --------------------------------------------------------------------------- -- getArgs, getProgName, getEnv@@ -70,34 +84,34 @@  getWin32ProgArgv_certainly :: IO [String] getWin32ProgArgv_certainly = do-	mb_argv <- getWin32ProgArgv-	case mb_argv of-	  Nothing   -> fmap dropRTSArgs getFullArgs-	  Just argv -> return argv+        mb_argv <- getWin32ProgArgv+        case mb_argv of+          Nothing   -> fmap dropRTSArgs getFullArgs+          Just argv -> return argv  withWin32ProgArgv :: [String] -> IO a -> IO a withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act)   where     begin = do-	  mb_old_argv <- getWin32ProgArgv-	  setWin32ProgArgv (Just argv)-	  return mb_old_argv+          mb_old_argv <- getWin32ProgArgv+          setWin32ProgArgv (Just argv)+          return mb_old_argv  getWin32ProgArgv :: IO (Maybe [String]) getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do-	c_getWin32ProgArgv p_argc p_argv-	argc <- peek p_argc-	argv_p <- peek p_argv-	if argv_p == nullPtr-	 then return Nothing-	 else do-	  argv_ps <- peekArray (fromIntegral argc) argv_p-	  fmap Just $ mapM peekCWString argv_ps+        c_getWin32ProgArgv p_argc p_argv+        argc <- peek p_argc+        argv_p <- peek p_argv+        if argv_p == nullPtr+         then return Nothing+         else do+          argv_ps <- peekArray (fromIntegral argc) argv_p+          fmap Just $ mapM peekCWString argv_ps  setWin32ProgArgv :: Maybe [String] -> IO () setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do-	c_setWin32ProgArgv (fromIntegral argc) argv_p+        c_setWin32ProgArgv (fromIntegral argc) argv_p  foreign import ccall unsafe "getWin32ProgArgv"   c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO ()@@ -180,7 +194,8 @@   -- | Computation 'getEnv' @var@ returns the value--- of the environment variable @var@.  +-- of the environment variable @var@. For the inverse, POSIX users+-- can use 'System.Posix.Env.putEnv'. -- -- This computation may fail with: --@@ -188,35 +203,51 @@ --    does not exist.  getEnv :: String -> IO String-#ifdef mingw32_HOST_OS-getEnv name = withCWString name $ \s -> try_size s 256+getEnv name = lookupEnv name >>= maybe handleError return   where-    try_size s size = allocaArray (fromIntegral size) $ \p_value -> do-      res <- c_GetEnvironmentVariable s p_value size-      case res of-        0 -> do-		  err <- c_GetLastError-		  if err == eRROR_ENVVAR_NOT_FOUND-		   then ioe_missingEnvVar name-		   else throwGetLastError "getEnv"-        _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable-          | otherwise  -> peekCWString p_value+#ifdef mingw32_HOST_OS+    handleError = do+        err <- c_GetLastError+        if err == eRROR_ENVVAR_NOT_FOUND+            then ioe_missingEnvVar name+            else throwGetLastError "getEnv"  eRROR_ENVVAR_NOT_FOUND :: DWORD eRROR_ENVVAR_NOT_FOUND = 203 -foreign import stdcall unsafe "windows.h GetLastError"+foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"   c_GetLastError:: IO DWORD -foreign import stdcall unsafe "windows.h GetEnvironmentVariableW"+#else+    handleError = ioe_missingEnvVar name+#endif++-- | Return the value of the environment variable @var@, or @Nothing@ if+-- there is no such value.+--+-- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.+lookupEnv :: String -> IO (Maybe String)+#ifdef mingw32_HOST_OS+lookupEnv name = withCWString name $ \s -> try_size s 256+  where+    try_size s size = allocaArray (fromIntegral size) $ \p_value -> do+      res <- c_GetEnvironmentVariable s p_value size+      case res of+        0 -> return Nothing+        _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable+          | otherwise  -> peekCWString p_value >>= return . Just++foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"   c_GetEnvironmentVariable :: LPTSTR -> LPTSTR -> DWORD -> IO DWORD #else-getEnv name =+lookupEnv name =     withCString name $ \s -> do       litstring <- c_getenv s       if litstring /= nullPtr-        then getFileSystemEncoding >>= \enc -> GHC.peekCString enc litstring-        else ioe_missingEnvVar name+        then do enc <- getFileSystemEncoding+                result <- GHC.peekCString enc litstring+                return $ Just result+        else return Nothing  foreign import ccall unsafe "getenv"    c_getenv :: CString -> IO (Ptr CChar)@@ -224,7 +255,7 @@  ioe_missingEnvVar :: String -> IO a ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"-											  "no environment variable" Nothing (Just name))+    "no environment variable" Nothing (Just name))  {-| 'withArgs' @args act@ - while executing action @act@, have 'getArgs'@@ -270,7 +301,8 @@ freeProgArgv :: Ptr CString -> IO () freeProgArgv argv = do   size <- lengthArray0 nullPtr argv-  sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]+  sequence_ [ peek (argv `advancePtr` i) >>= free+            | i <- [size - 1, size - 2 .. 0]]   free argv  setProgArgv :: [String] -> IO (Ptr CString)@@ -280,7 +312,7 @@   c_setProgArgv (genericLength argv) vs   return vs -foreign import ccall unsafe "setProgArgv" +foreign import ccall unsafe "setProgArgv"   c_setProgArgv  :: CInt -> Ptr CString -> IO ()  -- |'getEnvironment' retrieves the entire environment as a@@ -307,7 +339,7 @@           -- getting the actual String:           str <- peekCWString pBlock           fmap (divvy str :) $ go pBlock'-    +     -- Returns pointer to the byte *after* the next null     seekNull pBlock done = do         let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)@@ -316,10 +348,10 @@            c <- peek pBlock'            seekNull pBlock' (c == (0 :: Word8 )) -foreign import stdcall unsafe "windows.h GetEnvironmentStringsW"+foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"   c_GetEnvironmentStrings :: IO (Ptr CWchar) -foreign import stdcall unsafe "windows.h FreeEnvironmentStringsW"+foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"   c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool #else getEnvironment = do@@ -330,7 +362,7 @@       stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)       return (map divvy stuff) -foreign import ccall unsafe "__hscore_environ" +foreign import ccall unsafe "__hscore_environ"   getEnvBlock :: IO (Ptr CString) #endif @@ -340,4 +372,3 @@     (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)     (name,_:value) -> (name,value) #endif  /* __GLASGOW_HASKELL__ */-

@@ -0,0 +1,172 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Environment.ExecutablePath+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Function to retrieve the absolute filepath of the current executable.+--+-----------------------------------------------------------------------------++module System.Environment.ExecutablePath ( getExecutablePath ) where++-- The imports are purposely kept completely disjoint to prevent edits+-- to one OS implementation from breaking another.++#if defined(darwin_HOST_OS)+import Data.Word+import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import System.Posix.Internals+#elif defined(linux_HOST_OS)+import Foreign.C+import Foreign.Marshal.Array+import System.Posix.Internals+#elif defined(mingw32_HOST_OS)+import Data.Word+import Foreign.C+import Foreign.Marshal.Array+import Foreign.Ptr+import System.Posix.Internals+#else+import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import System.Posix.Internals+#endif++-- The exported function is defined outside any if-guard to make sure+-- every OS implements it with the same type.++-- | Returns the absolute pathname of the current executable.+--+-- Note that for scripts and interactive sessions, this is the path to+-- the interpreter (e.g. ghci.)+getExecutablePath :: IO FilePath++--------------------------------------------------------------------------------+-- Mac OS X++#if defined(darwin_HOST_OS)++type UInt32 = Word32++foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"+    c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt++-- | Returns the path of the main executable. The path may be a+-- symbolic link and not the real file.+--+-- See dyld(3)+_NSGetExecutablePath :: IO FilePath+_NSGetExecutablePath =+    allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X+    alloca $ \ bufsize -> do+        poke bufsize 1024+        status <- c__NSGetExecutablePath buf bufsize+        if status == 0+            then peekFilePath buf+            else do reqBufsize <- fromIntegral `fmap` peek bufsize+                    allocaBytes reqBufsize $ \ newBuf -> do+                        status2 <- c__NSGetExecutablePath newBuf bufsize+                        if status2 == 0+                             then peekFilePath newBuf+                             else error "_NSGetExecutablePath: buffer too small"++foreign import ccall unsafe "stdlib.h realpath"+    c_realpath :: CString -> CString -> IO CString++-- | Resolves all symbolic links, extra \/ characters, and references+-- to \/.\/ and \/..\/. Returns an absolute pathname.+--+-- See realpath(3)+realpath :: FilePath -> IO FilePath+realpath path =+    withFilePath path $ \ fileName ->+    allocaBytes 1024 $ \ resolvedName -> do+        _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName+        peekFilePath resolvedName++getExecutablePath = _NSGetExecutablePath >>= realpath++--------------------------------------------------------------------------------+-- Linux++#elif defined(linux_HOST_OS)++foreign import ccall unsafe "readlink"+    c_readlink :: CString -> CString -> CSize -> IO CInt++-- | Reads the @FilePath@ pointed to by the symbolic link and returns+-- it.+--+-- See readlink(2)+readSymbolicLink :: FilePath -> IO FilePath+readSymbolicLink file =+    allocaArray0 4096 $ \buf -> do+        withFilePath file $ \s -> do+            len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $+                   c_readlink s buf 4096+            peekFilePathLen (buf,fromIntegral len)++getExecutablePath = readSymbolicLink $ "/proc/self/exe"++--------------------------------------------------------------------------------+-- Windows++#elif defined(mingw32_HOST_OS)++# if defined(i386_HOST_ARCH)+##  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+##  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif++foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"+    c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32++getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32+  where+    go size = allocaArray (fromIntegral size) $ \ buf -> do+        ret <- c_GetModuleFileName nullPtr buf size+        case ret of+            0 -> error "getExecutablePath: GetModuleFileNameW returned an error"+            _ | ret < size -> peekFilePath buf+              | otherwise  -> go (size * 2)++--------------------------------------------------------------------------------+-- Fallback to argv[0]++#else++foreign import ccall unsafe "getFullProgArgv"+    c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()++getExecutablePath =+    alloca $ \ p_argc ->+    alloca $ \ p_argv -> do+        c_getFullProgArgv p_argc p_argv+        argc <- peek p_argc+        if argc > 0+            -- If argc > 0 then argv[0] is guaranteed by the standard+            -- to be a pointer to a null-terminated string.+            then peek p_argv >>= peek >>= peekFilePath+            else error $ "getExecutablePath: " ++ msg+  where msg = "no OS specific implementation and program name couldn't be " +++              "found in argv"++--------------------------------------------------------------------------------++#endif

@@ -78,15 +78,13 @@     ioError,                    -- :: IOError -> IO a      catchIOError,               -- :: IO a -> (IOError -> IO a) -> IO a-    catch,                      -- :: IO a -> (IOError -> IO a) -> IO a     tryIOError,                 -- :: IO a -> IO (Either IOError a)-    try,                        -- :: IO a -> IO (Either IOError a)      modifyIOError,              -- :: (IOError -> IOError) -> IO a -> IO a   ) where  #ifndef __HUGS__-import qualified Control.Exception.Base as New (catch)+import Control.Exception.Base #endif  #ifndef __HUGS__@@ -141,16 +139,6 @@                             return (Right r))                         (return . Left) -#ifndef __NHC__-{-# DEPRECATED try "Please use the new exceptions variant, Control.Exception.try" #-}--- | The 'try' function is deprecated. Please use the new exceptions--- variant, 'Control.Exception.try' from "Control.Exception", instead.-try            :: IO a -> IO (Either IOError a)-try f          =  catch (do r <- f-                            return (Right r))-                        (return . Left)-#endif- #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -- ----------------------------------------------------------------------------- -- Constructing an IOError@@ -467,12 +455,6 @@ -- Non-I\/O exceptions are not caught by this variant; to catch all -- exceptions, use 'Control.Exception.catch' from "Control.Exception". catchIOError :: IO a -> (IOError -> IO a) -> IO a-catchIOError = New.catch--{-# DEPRECATED catch "Please use the new exceptions variant, Control.Exception.catch" #-}--- | The 'catch' function is deprecated. Please use the new exceptions--- variant, 'Control.Exception.catch' from "Control.Exception", instead.-catch :: IO a -> (IOError -> IO a) -> IO a-catch = New.catch+catchIOError = catch #endif /* !__HUGS__ */ 

@@ -139,9 +139,10 @@ This behaviour depends on what it means for a key to be reachable. Informally, something is reachable if it can be reached by following ordinary pointers from the root set, but not following weak pointers.-We define reachability more precisely as follows A heap object is-reachable if:+We define reachability more precisely as follows. +A heap object is /reachable/ if:+  * It is a member of the /root set/.   * It is directly pointed to by a reachable object, other than@@ -149,6 +150,6 @@   * It is a weak pointer object whose key is reachable. - * It is the value or finalizer of an object whose key is reachable.+ * It is the value or finalizer of a weak pointer object whose key is reachable. -} 

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface, CApiFFI #-}+{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface, CApiFFI,+             EmptyDataDecls #-} {-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------@@ -90,7 +91,7 @@ type CLconv     = () type CPasswd    = () type CSigaction = ()-type CSigset    = ()+data {-# CTYPE "sigset_t" #-} CSigset type CStat      = () type CTermios   = () type CTm        = ()@@ -415,10 +416,13 @@    c_isatty :: CInt -> IO CInt  #if defined(mingw32_HOST_OS) || defined(__MINGW32__)-foreign import ccall unsafe "HsBase.h __hscore_lseek"+foreign import ccall unsafe "io.h _lseeki64"    c_lseek :: CInt -> Int64 -> CInt -> IO Int64 #else-foreign import ccall unsafe "HsBase.h __hscore_lseek"+-- We use CAPI as on some OSs (eg. Linux) this is wrapped by a macro+-- which redirects to the 64-bit-off_t versions when large file+-- support is enabled.+foreign import capi unsafe "unistd.h lseek"    c_lseek :: CInt -> COff -> CInt -> IO COff #endif @@ -431,10 +435,12 @@ foreign import ccall safe "HsBase.h __hscore_open"    c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt -foreign import ccall unsafe "HsBase.h read" +-- See Note: CSsize+foreign import capi unsafe "HsBase.h read"    c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall safe "HsBase.h read"+-- See Note: CSsize+foreign import capi safe "HsBase.h read"    c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize  foreign import ccall unsafe "HsBase.h __hscore_stat"@@ -443,10 +449,12 @@ foreign import ccall unsafe "HsBase.h umask"    c_umask :: CMode -> IO CMode -foreign import ccall unsafe "HsBase.h write" +-- See Note: CSsize+foreign import capi unsafe "HsBase.h write"    c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall safe "HsBase.h write"+-- See Note: CSsize+foreign import capi safe "HsBase.h write"    c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize  foreign import ccall unsafe "HsBase.h __hscore_ftruncate"@@ -480,13 +488,13 @@ foreign import ccall unsafe "HsBase.h pipe"    c_pipe :: Ptr CInt -> IO CInt -foreign import ccall unsafe "HsBase.h __hscore_sigemptyset"+foreign import capi unsafe "signal.h sigemptyset"    c_sigemptyset :: Ptr CSigset -> IO CInt -foreign import ccall unsafe "HsBase.h __hscore_sigaddset"+foreign import capi unsafe "signal.h sigaddset"    c_sigaddset :: Ptr CSigset -> CInt -> IO CInt -foreign import ccall unsafe "HsBase.h sigprocmask"+foreign import capi unsafe "signal.h sigprocmask"    c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt  foreign import ccall unsafe "HsBase.h tcgetattr"@@ -516,11 +524,11 @@ foreign import ccall unsafe "HsBase.h __hscore_o_nonblock" o_NONBLOCK :: CInt foreign import ccall unsafe "HsBase.h __hscore_o_binary"   o_BINARY   :: CInt -foreign import ccall unsafe "HsBase.h __hscore_s_isreg"  c_s_isreg  :: CMode -> CInt-foreign import ccall unsafe "HsBase.h __hscore_s_ischr"  c_s_ischr  :: CMode -> CInt-foreign import ccall unsafe "HsBase.h __hscore_s_isblk"  c_s_isblk  :: CMode -> CInt-foreign import ccall unsafe "HsBase.h __hscore_s_isdir"  c_s_isdir  :: CMode -> CInt-foreign import ccall unsafe "HsBase.h __hscore_s_isfifo" c_s_isfifo :: CMode -> CInt+foreign import capi unsafe "sys/stat.h S_ISREG"  c_s_isreg  :: CMode -> CInt+foreign import capi unsafe "sys/stat.h S_ISCHR"  c_s_ischr  :: CMode -> CInt+foreign import capi unsafe "sys/stat.h S_ISBLK"  c_s_isblk  :: CMode -> CInt+foreign import capi unsafe "sys/stat.h S_ISDIR"  c_s_isdir  :: CMode -> CInt+foreign import capi unsafe "sys/stat.h S_ISFIFO" c_s_isfifo :: CMode -> CInt  s_isreg  :: CMode -> Bool s_isreg cm = c_s_isreg cm /= 0@@ -569,13 +577,25 @@ s_issock :: CMode -> Bool #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) s_issock cmode = c_s_issock cmode /= 0-foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt+foreign import capi unsafe "sys/stat.h S_ISSOCK" c_s_issock :: CMode -> CInt #else s_issock _ = False #endif -foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int-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+foreign import ccall unsafe "__hscore_bufsiz"  dEFAULT_BUFFER_SIZE :: Int+foreign import capi  unsafe "stdio.h value SEEK_CUR" sEEK_CUR :: CInt+foreign import capi  unsafe "stdio.h value SEEK_SET" sEEK_SET :: CInt+foreign import capi  unsafe "stdio.h value SEEK_END" sEEK_END :: CInt++{-+Note: CSsize++On Win64, ssize_t is 64 bit, but functions like read return 32 bit+ints. The CAPI wrapper means the C compiler takes care of doing all+the necessary casting.++When using ccall instead, when the functions failed with -1, we thought+they were returning with 4294967295, and so didn't throw an exception.+This lead to a segfault in echo001(ghci).+-} 

@@ -136,13 +136,13 @@ #include "CTypes.h"  #if defined(HTYPE_DEV_T)-ARITHMETIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T)+INTEGRAL_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T) #endif #if defined(HTYPE_INO_T) INTEGRAL_TYPE(CIno,tyConCIno,"CIno",HTYPE_INO_T) #endif #if defined(HTYPE_MODE_T)-INTEGRAL_TYPE(CMode,tyConCMode,"CMode",HTYPE_MODE_T)+INTEGRAL_TYPE_WITH_CTYPE(CMode,mode_t,tyConCMode,"CMode",HTYPE_MODE_T) #endif #if defined(HTYPE_OFF_T) INTEGRAL_TYPE(COff,tyConCOff,"COff",HTYPE_OFF_T)

@@ -25,12 +25,8 @@ module System.Timeout ( timeout ) where  #ifdef __GLASGOW_HASKELL__-import Prelude             (Show(show), IO, Ord((<)), Eq((==)), Int,-                            otherwise, fmap)-import Data.Maybe          (Maybe(..))-import Control.Monad       (Monad(..))-import Control.Concurrent  (forkIO, threadDelay, myThreadId, killThread)-import Control.Exception   (Exception, handleJust, throwTo, bracket)+import Control.Concurrent+import Control.Exception   (Exception, handleJust, bracket) import Data.Typeable import Data.Unique         (Unique, newUnique) @@ -86,7 +82,8 @@         ex  <- fmap Timeout newUnique         handleJust (\e -> if e == ex then Just () else Nothing)                    (\_ -> return Nothing)-                   (bracket (forkIO (threadDelay n >> throwTo pid ex))+                   (bracket (forkIOWithUnmask $ \unmask ->+                                 unmask $ threadDelay n >> throwTo pid ex)                             (killThread)                             (\_ -> fmap Just f)) #else

@@ -82,9 +82,7 @@ import Control.Monad( MonadPlus(..), sequence, liftM2 )  #ifdef __GLASGOW_HASKELL__-#ifndef __HADDOCK__ import {-# SOURCE #-} GHC.Unicode ( isSpace  )-#endif import GHC.List ( replicate, null ) import GHC.Base #else

@@ -42,6 +42,8 @@ #ifdef __GLASGOW_HASKELL__    readListDefault,     -- :: Read a => ReadS [a]    readListPrecDefault, -- :: Read a => ReadPrec [a]+   readEither,          -- :: Read a => String -> Either String a+   readMaybe            -- :: Read a => String -> Maybe a #endif   ) where@@ -50,6 +52,7 @@ import GHC.Base import GHC.Read import Data.Either+import Data.Maybe import Text.ParserCombinators.ReadP as P #endif #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)@@ -82,6 +85,9 @@ reads :: Read a => ReadS a reads = readsPrec minPrec +-- | Parse a string using the 'Read' instance.+-- Succeeds if there is exactly one valid result.+-- A 'Left' value indicates a parse error. readEither :: Read a => String -> Either String a readEither s =   case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of@@ -93,6 +99,13 @@     do x <- readPrec        lift P.skipSpaces        return x++-- | Parse a string using the 'Read' instance.+-- Succeeds if there is exactly one valid result.+readMaybe :: Read a => String -> Maybe a+readMaybe s = case readEither s of+                Left _  -> Nothing+                Right a -> Just a  -- | The 'read' function reads input from a string, which must be -- completely consumed by the input process.

@@ -18,13 +18,11 @@ module Text.Read.Lex   -- lexing types   ( Lexeme(..)  -- :: *; Show, Eq-  , Lexeme'(..) -  , numberToInteger, numberToRangedRational+  , numberToInteger, numberToRational, numberToRangedRational    -- lexer   , lex         -- :: ReadP Lexeme      Skips leading spaces-  , lex'        -- :: ReadP Lexeme      Skips leading spaces   , hsLex       -- :: ReadP String   , lexChar     -- :: ReadP Char        Reads just one char, with H98 escapes @@ -39,15 +37,14 @@  #ifdef __GLASGOW_HASKELL__ import GHC.Base+import GHC.Char import GHC.Num( Num(..), Integer ) import GHC.Show( Show(..) )-#ifndef __HADDOCK__ import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum )-#endif import GHC.Real( Integral, Rational, (%), fromIntegral,-                 toInteger, (^), infinity, notANumber )+                 toInteger, (^) ) import GHC.List-import GHC.Enum( maxBound )+import GHC.Enum( minBound, maxBound ) #else import Prelude hiding ( lex ) import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )@@ -69,17 +66,10 @@   | Punc   String       -- ^ Punctuation or reserved symbol, e.g. @(@, @::@   | Ident  String       -- ^ Haskell identifier, e.g. @foo@, @Baz@   | Symbol String       -- ^ Haskell symbol, e.g. @>>@, @:%@-  | Int Integer         -- ^ Integer literal-  | Rat Rational        -- ^ Floating point literal+  | Number Number   | EOF  deriving (Eq, Show) -data Lexeme' = Ident' String-             | Punc'   String-             | Symbol' String-             | Number Number- deriving (Eq, Show)- data Number = MkNumber Int              -- Base                        Digits           -- Integral part             | MkDecimal Digits          -- Integral part@@ -92,9 +82,26 @@ numberToInteger (MkDecimal iPart Nothing Nothing) = Just (val 10 0 iPart) numberToInteger _ = Nothing +-- This takes a floatRange, and if the Rational would be outside of+-- the floatRange then it may return Nothing. Not that it will not+-- /necessarily/ return Nothing, but it is good enough to fix the+-- space problems in #5688+-- Ways this is conservative:+-- * the floatRange is in base 2, but we pretend it is in base 10+-- * we pad the floateRange a bit, just in case it is very small+--   and we would otherwise hit an edge case+-- * We only worry about numbers that have an exponent. If they don't+--   have an exponent then the Rational won't be much larger than the+--   Number, so there is no problem numberToRangedRational :: (Int, Int) -> Number                        -> Maybe Rational -- Nothing = Inf numberToRangedRational (neg, pos) n@(MkDecimal iPart mFPart (Just exp))+    -- if exp is out of integer bounds,+    -- then the number is definitely out of range+    | exp > fromIntegral (maxBound :: Int) ||+      exp < fromIntegral (minBound :: Int)+    = Nothing+    | otherwise     = let mFirstDigit = case dropWhile (0 ==) iPart of                         iPart'@(_ : _) -> Just (length iPart')                         [] -> case mFPart of@@ -126,6 +133,10 @@        | otherwise           -> i % (10 ^ (- exp))       (Just fPart, Nothing)  -> fracExp 0   i fPart       (Just fPart, Just exp) -> fracExp exp i fPart+      -- fracExp is 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.  -- ----------------------------------------------------------------------------- -- Lexing@@ -133,9 +144,6 @@ lex :: ReadP Lexeme lex = skipSpaces >> lexToken -lex' :: ReadP Lexeme'-lex' = skipSpaces >> lexToken'- hsLex :: ReadP String -- ^ Haskell lexer: returns the lexed string, rather than the lexeme hsLex = do skipSpaces@@ -151,12 +159,7 @@            lexId      +++            lexNumber -lexToken' :: ReadP Lexeme'-lexToken' = lexSymbol' +++-            lexId'     +++-            fmap Number lexNumber' - -- ---------------------------------------------------------------------- -- End of file lexEOF :: ReadP Lexeme@@ -188,51 +191,18 @@   isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"   reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"] -lexSymbol' :: ReadP Lexeme'-lexSymbol' =-  do s <- munch1 isSymbolChar-     if s `elem` reserved_ops then-        return (Punc' s)         -- Reserved-ops count as punctuation-      else-        return (Symbol' s)- where-  isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"-  reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]- -- ---------------------------------------------------------------------- -- identifiers  lexId :: ReadP Lexeme-lexId = lex_nan <++ lex_id-  where-        -- NaN and Infinity look like identifiers, so-        -- 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))--          -- Identifiers can start with a '_'-    isIdsChar c = isAlpha c || c == '_'-    isIdfChar c = isAlphaNum c || c `elem` "_'"--lexId' :: ReadP Lexeme'-lexId' = do c <- satisfy isIdsChar-            s <- munch isIdfChar-            return (Ident' (c:s))+lexId = do c <- satisfy isIdsChar+           s <- munch isIdfChar+           return (Ident (c:s))   where           -- Identifiers can start with a '_'     isIdsChar c = isAlpha c || c == '_'     isIdfChar c = isAlphaNum c || c `elem` "_'" -#ifndef __GLASGOW_HASKELL__-infinity, notANumber :: Rational-infinity   = 1 :% 0-notANumber = 0 :% 0-#endif- -- --------------------------------------------------------------------------- -- Lexing character literals @@ -399,25 +369,12 @@                         -- If that fails, try for a decimal number     lexDecNumber        -- Start with ordinary digits -lexNumber' :: ReadP Number-lexNumber'-  = lexHexOct'  <++      -- First try for hex or octal 0x, 0o etc-                         -- If that fails, try for a decimal number-    lexDecNumber'- lexHexOct :: ReadP Lexeme lexHexOct   = do  _ <- char '0'         base <- lexBaseChar         digits <- lexDigits base-        return (Int (val (fromIntegral base) 0 digits))--lexHexOct' :: ReadP Number-lexHexOct'-  = do  _ <- char '0'-        base <- lexBaseChar-        digits <- lexDigits base-        return (MkNumber base digits)+        return (Number (MkNumber base digits))  lexBaseChar :: ReadP Int -- Lex a single character indicating the base; fail if not there@@ -434,30 +391,7 @@   do xs    <- lexDigits 10      mFrac <- lexFrac <++ return Nothing      mExp  <- lexExp  <++ return Nothing-     return (value xs mFrac mExp)- where-  value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp--  valueFracExp :: Integer -> Maybe Digits -> Maybe Integer-               -> Lexeme-  valueFracExp a Nothing Nothing-    = Int a                                             -- 43-  valueFracExp a Nothing (Just exp)-    | exp >= 0  = Int (a * (10 ^ exp))                  -- 43e7-    | 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.--lexDecNumber' :: ReadP Number-lexDecNumber' =-  do xs    <- lexDigits 10-     mFrac <- lexFrac <++ return Nothing-     mExp  <- lexExp  <++ return Nothing-     return (MkDecimal xs mFrac mExp)+     return (Number (MkDecimal xs mFrac mExp))  lexFrac :: ReadP (Maybe Digits) -- Read the fractional part; fail if it doesn't

@@ -34,7 +34,10 @@ #if defined(__GLASGOW_HASKELL__) import GHC.Prim (unsafeCoerce#) unsafeCoerce :: a -> b-unsafeCoerce = unsafeCoerce#+unsafeCoerce x = unsafeCoerce# x+  -- See Note [Unsafe coerce magic] in basicTypes/MkId+  -- NB: Do not eta-reduce this definition, else the type checker +  -- give usafeCoerce the same (dangerous) type as unsafeCoerce# #endif  #if defined(__NHC__)

@@ -1,5 +1,5 @@ name:           base-version:        4.5.1.0+version:        4.6.0.0 license:        BSD3 license-file:   LICENSE maintainer:     libraries@haskell.org@@ -38,6 +38,7 @@             Foreign.Concurrent,             GHC.Arr,             GHC.Base,+            GHC.Char,             GHC.Conc,             GHC.Conc.IO,             GHC.Conc.Signal,@@ -57,6 +58,8 @@             GHC.Float.RealFracMethods,             GHC.Foreign,             GHC.ForeignPtr,+            GHC.Generics,+            GHC.GHCi,             GHC.Handle,             GHC.IO,             GHC.IO.Buffer,@@ -82,6 +85,7 @@             GHC.IOArray,             GHC.IOBase,             GHC.IORef,+            GHC.IP,             GHC.Int,             GHC.List,             GHC.MVar,@@ -98,6 +102,7 @@             GHC.Stable,             GHC.Storable,             GHC.STRef,+            GHC.TypeLits,             GHC.TopHandler,             GHC.Unicode,             GHC.Weak,@@ -120,7 +125,6 @@         Control.Concurrent.SampleVar,         Control.Exception,         Control.Exception.Base-        Control.OldException,         Control.Monad,         Control.Monad.Fix,         Control.Monad.Instances,@@ -212,14 +216,15 @@         Control.Monad.ST.Imp         Control.Monad.ST.Lazy.Imp         Foreign.ForeignPtr.Imp+        System.Environment.ExecutablePath     c-sources:         cbits/PrelIOUtils.c         cbits/WCsubst.c         cbits/Win32Utils.c+        cbits/DarwinUtils.c         cbits/consUtils.c         cbits/iconv.c         cbits/inputReady.c-        cbits/selectUtils.c         cbits/primFloat.c         cbits/md5.c     include-dirs: include

@@ -0,0 +1,21 @@+#include "HsBase.h"++#ifdef darwin_HOST_OS++static double scaling_factor = 0.0;++void initialize_timer()+{+    mach_timebase_info_data_t info;+    (void) mach_timebase_info(&info);+    scaling_factor = (double)info.numer / (double)info.denom;+    scaling_factor *= 1e-9;+}++void absolute_time(double *result)+{+    uint64_t time = mach_absolute_time();+    *result = (double)time * scaling_factor;+}++#endif

@@ -110,16 +110,21 @@ 			errno = EINVAL; } -HsWord64 getUSecOfDay(void)+int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino) {-    HsWord64 t;-    FILETIME ft;-    GetSystemTimeAsFileTime(&ft);-    t = ((HsWord64)ft.dwHighDateTime << 32) | ft.dwLowDateTime;-    t = t / 10LL;-    /* FILETIMES are in units of 100ns,-       so we divide by 10 to get microseconds */-    return t;+    HANDLE h = (HANDLE)_get_osfhandle(fd);+    BY_HANDLE_FILE_INFORMATION info;++    if (GetFileInformationByHandle(h, &info))+    {+        *dev = info.dwVolumeSerialNumber;+        *ino = info.nFileIndexLow+             | ((HsWord64)info.nFileIndexHigh << 32);++        return 0;+    }++    return -1; }  BOOL file_exists(LPCTSTR path)@@ -129,4 +134,3 @@ }  #endif-

@@ -1,3 +0,0 @@--#include "HsBase.h"-void hsFD_ZERO(fd_set *fds) { FD_ZERO(fds); }

@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.68 for Haskell base package 1.0.+# Generated by GNU Autoconf 2.67 for Haskell base package 1.0. # # Report bugs to <libraries@haskell.org>. #@@ -91,7 +91,6 @@ IFS=" ""	$as_nl"  # Find who we are.  Look in the path if we contain no directory separator.-as_myself= case $0 in #((   *[\\/]* ) as_myself=$0 ;;   *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR@@ -217,18 +216,11 @@   # We cannot yet assume a decent shell, so we have to provide a 	# neutralization value for shells without unset; and this also 	# works around shells that cannot unset nonexistent variables.-	# Preserve -v and -x to the replacement shell. 	BASH_ENV=/dev/null 	ENV=/dev/null 	(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV 	export CONFIG_SHELL-	case $- in # ((((-	  *v*x* | *x*v* ) as_opts=-vx ;;-	  *v* ) as_opts=-v ;;-	  *x* ) as_opts=-x ;;-	  * ) as_opts= ;;-	esac-	exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"}+	exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} fi      if test x$as_have_required = xno; then :@@ -1076,7 +1068,7 @@     $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2     expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&       $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2-    : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"+    : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}     ;;    esac@@ -1369,7 +1361,7 @@ if $ac_init_version; then   cat <<\_ACEOF Haskell base package configure 1.0-generated by GNU Autoconf 2.68+generated by GNU Autoconf 2.67  Copyright (C) 2010 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation@@ -1415,7 +1407,7 @@  	ac_retval=1 fi-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}   as_fn_set_status $ac_retval  } # ac_fn_c_try_compile@@ -1429,7 +1421,7 @@   as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack   { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; }-if eval \${$3+:} false; then :+if eval "test \"\${$3+set}\"" = set; then :   $as_echo_n "(cached) " >&6 else   eval "$3=no"@@ -1470,7 +1462,7 @@ eval ac_res=\$$3 	       { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; }-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}  } # ac_fn_c_check_type @@ -1506,7 +1498,7 @@      ac_retval=1 fi-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}   as_fn_set_status $ac_retval  } # ac_fn_c_try_cpp@@ -1548,7 +1540,7 @@        ac_retval=$ac_status fi   rm -rf conftest.dSYM conftest_ipa8_conftest.oo-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}   as_fn_set_status $ac_retval  } # ac_fn_c_try_run@@ -1562,7 +1554,7 @@   as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack   { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; }-if eval \${$3+:} false; then :+if eval "test \"\${$3+set}\"" = set; then :   $as_echo_n "(cached) " >&6 else   cat confdefs.h - <<_ACEOF >conftest.$ac_ext@@ -1580,7 +1572,7 @@ eval ac_res=\$$3 	       { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; }-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}  } # ac_fn_c_check_header_compile @@ -1592,10 +1584,10 @@ ac_fn_c_check_header_mongrel () {   as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  if eval \${$3+:} false; then :+  if eval "test \"\${$3+set}\"" = set; then :   { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; }-if eval \${$3+:} false; then :+if eval "test \"\${$3+set}\"" = set; then :   $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3@@ -1662,7 +1654,7 @@ esac   { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; }-if eval \${$3+:} false; then :+if eval "test \"\${$3+set}\"" = set; then :   $as_echo_n "(cached) " >&6 else   eval "$3=\$ac_header_compiler"@@ -1671,7 +1663,7 @@ 	       { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}  } # ac_fn_c_check_header_mongrel @@ -1716,7 +1708,7 @@   # interfere with the next link command; also delete a directory that is   # left behind by Apple's compiler.  We do this before executing the actions.   rm -rf conftest.dSYM conftest_ipa8_conftest.oo-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}   as_fn_set_status $ac_retval  } # ac_fn_c_try_link@@ -1729,7 +1721,7 @@   as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack   { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; }-if eval \${$3+:} false; then :+if eval "test \"\${$3+set}\"" = set; then :   $as_echo_n "(cached) " >&6 else   cat confdefs.h - <<_ACEOF >conftest.$ac_ext@@ -1784,7 +1776,7 @@ eval ac_res=\$$3 	       { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; }-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}  } # ac_fn_c_check_func @@ -1961,7 +1953,7 @@ rm -f conftest.val    fi-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+  eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;}   as_fn_set_status $ac_retval  } # ac_fn_c_compute_int@@ -1970,7 +1962,7 @@ running configure, to aid debugging if configure makes a mistake.  It was created by Haskell base package $as_me 1.0, which was-generated by GNU Autoconf 2.68.  Invocation command line was+generated by GNU Autoconf 2.67.  Invocation command line was    $ $0 $@ @@ -2228,7 +2220,7 @@       || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; }   fi done @@ -2340,7 +2332,7 @@ set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_CC+:} false; then :+if test "${ac_cv_prog_CC+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if test -n "$CC"; then@@ -2380,7 +2372,7 @@ set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_ac_ct_CC+:} false; then :+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if test -n "$ac_ct_CC"; then@@ -2433,7 +2425,7 @@ set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_CC+:} false; then :+if test "${ac_cv_prog_CC+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if test -n "$CC"; then@@ -2473,7 +2465,7 @@ set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_CC+:} false; then :+if test "${ac_cv_prog_CC+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if test -n "$CC"; then@@ -2532,7 +2524,7 @@ set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_CC+:} false; then :+if test "${ac_cv_prog_CC+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if test -n "$CC"; then@@ -2576,7 +2568,7 @@ set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; }-if ${ac_cv_prog_ac_ct_CC+:} false; then :+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if test -n "$ac_ct_CC"; then@@ -2631,7 +2623,7 @@ test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; }  # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5@@ -2746,7 +2738,7 @@ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; } else   { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; }@@ -2789,7 +2781,7 @@   { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5@@ -2848,7 +2840,7 @@ $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'.-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; }     fi   fi fi@@ -2859,7 +2851,7 @@ ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; }-if ${ac_cv_objext+:} false; then :+if test "${ac_cv_objext+set}" = set; then :   $as_echo_n "(cached) " >&6 else   cat confdefs.h - <<_ACEOF >conftest.$ac_ext@@ -2900,7 +2892,7 @@ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi@@ -2910,7 +2902,7 @@ ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; }-if ${ac_cv_c_compiler_gnu+:} false; then :+if test "${ac_cv_c_compiler_gnu+set}" = set; then :   $as_echo_n "(cached) " >&6 else   cat confdefs.h - <<_ACEOF >conftest.$ac_ext@@ -2947,7 +2939,7 @@ ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; }-if ${ac_cv_prog_cc_g+:} false; then :+if test "${ac_cv_prog_cc_g+set}" = set; then :   $as_echo_n "(cached) " >&6 else   ac_save_c_werror_flag=$ac_c_werror_flag@@ -3025,7 +3017,7 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; }-if ${ac_cv_prog_cc_c89+:} false; then :+if test "${ac_cv_prog_cc_c89+set}" = set; then :   $as_echo_n "(cached) " >&6 else   ac_cv_prog_cc_c89=no@@ -3142,7 +3134,7 @@   CPP= fi if test -z "$CPP"; then-  if ${ac_cv_prog_CPP+:} false; then :+  if test "${ac_cv_prog_CPP+set}" = set; then :   $as_echo_n "(cached) " >&6 else       # Double quotes because CPP needs to be expanded@@ -3258,7 +3250,7 @@   { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; } fi  ac_ext=c@@ -3270,7 +3262,7 @@  { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; }-if ${ac_cv_path_GREP+:} false; then :+if test "${ac_cv_path_GREP+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if test -z "$GREP"; then@@ -3333,7 +3325,7 @@  { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; }-if ${ac_cv_path_EGREP+:} false; then :+if test "${ac_cv_path_EGREP+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if echo a | $GREP -E '(a|b)' >/dev/null 2>&1@@ -3400,7 +3392,7 @@  { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; }-if ${ac_cv_header_stdc+:} false; then :+if test "${ac_cv_header_stdc+set}" = set; then :   $as_echo_n "(cached) " >&6 else   cat confdefs.h - <<_ACEOF >conftest.$ac_ext@@ -3528,7 +3520,7 @@   ac_fn_c_check_type "$LINENO" "long long" "ac_cv_type_long_long" "$ac_includes_default"-if test "x$ac_cv_type_long_long" = xyes; then :+if test "x$ac_cv_type_long_long" = x""yes; then :  cat >>confdefs.h <<_ACEOF #define HAVE_LONG_LONG 1@@ -3540,7 +3532,7 @@  { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; }-if ${ac_cv_header_stdc+:} false; then :+if test "${ac_cv_header_stdc+set}" = set; then :   $as_echo_n "(cached) " >&6 else   cat confdefs.h - <<_ACEOF >conftest.$ac_ext@@ -3677,7 +3669,7 @@    { $as_echo "$as_me:${as_lineno-$LINENO}: checking for special C compiler options needed for large files" >&5 $as_echo_n "checking for special C compiler options needed for large files... " >&6; }-if ${ac_cv_sys_largefile_CC+:} false; then :+if test "${ac_cv_sys_largefile_CC+set}" = set; then :   $as_echo_n "(cached) " >&6 else   ac_cv_sys_largefile_CC=no@@ -3728,7 +3720,7 @@    { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _FILE_OFFSET_BITS value needed for large files" >&5 $as_echo_n "checking for _FILE_OFFSET_BITS value needed for large files... " >&6; }-if ${ac_cv_sys_file_offset_bits+:} false; then :+if test "${ac_cv_sys_file_offset_bits+set}" = set; then :   $as_echo_n "(cached) " >&6 else   while :; do@@ -3797,7 +3789,7 @@   if test $ac_cv_sys_file_offset_bits = unknown; then     { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _LARGE_FILES value needed for large files" >&5 $as_echo_n "checking for _LARGE_FILES value needed for large files... " >&6; }-if ${ac_cv_sys_large_files+:} false; then :+if test "${ac_cv_sys_large_files+set}" = set; then :   $as_echo_n "(cached) " >&6 else   while :; do@@ -3870,14 +3862,14 @@ for ac_header in wctype.h do :   ac_fn_c_check_header_mongrel "$LINENO" "wctype.h" "ac_cv_header_wctype_h" "$ac_includes_default"-if test "x$ac_cv_header_wctype_h" = xyes; then :+if test "x$ac_cv_header_wctype_h" = x""yes; then :   cat >>confdefs.h <<_ACEOF #define HAVE_WCTYPE_H 1 _ACEOF  for ac_func in iswspace do :   ac_fn_c_check_func "$LINENO" "iswspace" "ac_cv_func_iswspace"-if test "x$ac_cv_func_iswspace" = xyes; then :+if test "x$ac_cv_func_iswspace" = x""yes; then :   cat >>confdefs.h <<_ACEOF #define HAVE_ISWSPACE 1 _ACEOF@@ -3893,7 +3885,7 @@ for ac_func in lstat do :   ac_fn_c_check_func "$LINENO" "lstat" "ac_cv_func_lstat"-if test "x$ac_cv_func_lstat" = xyes; then :+if test "x$ac_cv_func_lstat" = x""yes; then :   cat >>confdefs.h <<_ACEOF #define HAVE_LSTAT 1 _ACEOF@@ -3901,6 +3893,62 @@ fi done +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in -lrt" >&5+$as_echo_n "checking for clock_gettime in -lrt... " >&6; }+if test "${ac_cv_lib_rt_clock_gettime+set}" = set; then :+  $as_echo_n "(cached) " >&6+else+  ac_check_lib_save_LIBS=$LIBS+LIBS="-lrt  $LIBS"+cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h.  */++/* Override any GCC internal prototype to avoid an error.+   Use char because int might match the return type of a GCC+   builtin and then its argument prototype would still apply.  */+#ifdef __cplusplus+extern "C"+#endif+char clock_gettime ();+int+main ()+{+return clock_gettime ();+  ;+  return 0;+}+_ACEOF+if ac_fn_c_try_link "$LINENO"; then :+  ac_cv_lib_rt_clock_gettime=yes+else+  ac_cv_lib_rt_clock_gettime=no+fi+rm -f core conftest.err conftest.$ac_objext \+    conftest$ac_exeext conftest.$ac_ext+LIBS=$ac_check_lib_save_LIBS+fi+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rt_clock_gettime" >&5+$as_echo "$ac_cv_lib_rt_clock_gettime" >&6; }+if test "x$ac_cv_lib_rt_clock_gettime" = x""yes; then :+  cat >>confdefs.h <<_ACEOF+#define HAVE_LIBRT 1+_ACEOF++  LIBS="-lrt $LIBS"++fi++for ac_func in clock_gettime+do :+  ac_fn_c_check_func "$LINENO" "clock_gettime" "ac_cv_func_clock_gettime"+if test "x$ac_cv_func_clock_gettime" = x""yes; then :+  cat >>confdefs.h <<_ACEOF+#define HAVE_CLOCK_GETTIME 1+_ACEOF++fi+done+ for ac_func in getclock getrusage times do :   as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`@@ -3992,7 +4040,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for char" >&5 $as_echo_n "checking Haskell type for char... " >&6; }-    if ${fptools_cv_htype_char+:} false; then :+    if test "${fptools_cv_htype_char+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -4415,7 +4463,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for signed char" >&5 $as_echo_n "checking Haskell type for signed char... " >&6; }-    if ${fptools_cv_htype_signed_char+:} false; then :+    if test "${fptools_cv_htype_signed_char+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -4838,7 +4886,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned char" >&5 $as_echo_n "checking Haskell type for unsigned char... " >&6; }-    if ${fptools_cv_htype_unsigned_char+:} false; then :+    if test "${fptools_cv_htype_unsigned_char+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -5261,7 +5309,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for short" >&5 $as_echo_n "checking Haskell type for short... " >&6; }-    if ${fptools_cv_htype_short+:} false; then :+    if test "${fptools_cv_htype_short+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -5684,7 +5732,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned short" >&5 $as_echo_n "checking Haskell type for unsigned short... " >&6; }-    if ${fptools_cv_htype_unsigned_short+:} false; then :+    if test "${fptools_cv_htype_unsigned_short+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -6107,7 +6155,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for int" >&5 $as_echo_n "checking Haskell type for int... " >&6; }-    if ${fptools_cv_htype_int+:} false; then :+    if test "${fptools_cv_htype_int+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -6530,7 +6578,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned int" >&5 $as_echo_n "checking Haskell type for unsigned int... " >&6; }-    if ${fptools_cv_htype_unsigned_int+:} false; then :+    if test "${fptools_cv_htype_unsigned_int+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -6953,7 +7001,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for long" >&5 $as_echo_n "checking Haskell type for long... " >&6; }-    if ${fptools_cv_htype_long+:} false; then :+    if test "${fptools_cv_htype_long+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -7376,7 +7424,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned long" >&5 $as_echo_n "checking Haskell type for unsigned long... " >&6; }-    if ${fptools_cv_htype_unsigned_long+:} false; then :+    if test "${fptools_cv_htype_unsigned_long+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -7800,7 +7848,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for long long" >&5 $as_echo_n "checking Haskell type for long long... " >&6; }-    if ${fptools_cv_htype_long_long+:} false; then :+    if test "${fptools_cv_htype_long_long+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -8223,7 +8271,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned long long" >&5 $as_echo_n "checking Haskell type for unsigned long long... " >&6; }-    if ${fptools_cv_htype_unsigned_long_long+:} false; then :+    if test "${fptools_cv_htype_unsigned_long_long+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -8647,7 +8695,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for float" >&5 $as_echo_n "checking Haskell type for float... " >&6; }-    if ${fptools_cv_htype_float+:} false; then :+    if test "${fptools_cv_htype_float+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -9070,7 +9118,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for double" >&5 $as_echo_n "checking Haskell type for double... " >&6; }-    if ${fptools_cv_htype_double+:} false; then :+    if test "${fptools_cv_htype_double+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -9493,7 +9541,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for ptrdiff_t" >&5 $as_echo_n "checking Haskell type for ptrdiff_t... " >&6; }-    if ${fptools_cv_htype_ptrdiff_t+:} false; then :+    if test "${fptools_cv_htype_ptrdiff_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -9916,7 +9964,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for size_t" >&5 $as_echo_n "checking Haskell type for size_t... " >&6; }-    if ${fptools_cv_htype_size_t+:} false; then :+    if test "${fptools_cv_htype_size_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -10339,7 +10387,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for wchar_t" >&5 $as_echo_n "checking Haskell type for wchar_t... " >&6; }-    if ${fptools_cv_htype_wchar_t+:} false; then :+    if test "${fptools_cv_htype_wchar_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -10762,7 +10810,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for sig_atomic_t" >&5 $as_echo_n "checking Haskell type for sig_atomic_t... " >&6; }-    if ${fptools_cv_htype_sig_atomic_t+:} false; then :+    if test "${fptools_cv_htype_sig_atomic_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -11185,7 +11233,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for clock_t" >&5 $as_echo_n "checking Haskell type for clock_t... " >&6; }-    if ${fptools_cv_htype_clock_t+:} false; then :+    if test "${fptools_cv_htype_clock_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -11608,7 +11656,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for time_t" >&5 $as_echo_n "checking Haskell type for time_t... " >&6; }-    if ${fptools_cv_htype_time_t+:} false; then :+    if test "${fptools_cv_htype_time_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -12031,7 +12079,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for useconds_t" >&5 $as_echo_n "checking Haskell type for useconds_t... " >&6; }-    if ${fptools_cv_htype_useconds_t+:} false; then :+    if test "${fptools_cv_htype_useconds_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -12453,7 +12501,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for suseconds_t" >&5 $as_echo_n "checking Haskell type for suseconds_t... " >&6; }-    if ${fptools_cv_htype_suseconds_t+:} false; then :+    if test "${fptools_cv_htype_suseconds_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -12877,7 +12925,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for dev_t" >&5 $as_echo_n "checking Haskell type for dev_t... " >&6; }-    if ${fptools_cv_htype_dev_t+:} false; then :+    if test "${fptools_cv_htype_dev_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -13300,7 +13348,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for ino_t" >&5 $as_echo_n "checking Haskell type for ino_t... " >&6; }-    if ${fptools_cv_htype_ino_t+:} false; then :+    if test "${fptools_cv_htype_ino_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -13723,7 +13771,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for mode_t" >&5 $as_echo_n "checking Haskell type for mode_t... " >&6; }-    if ${fptools_cv_htype_mode_t+:} false; then :+    if test "${fptools_cv_htype_mode_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -14146,7 +14194,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for off_t" >&5 $as_echo_n "checking Haskell type for off_t... " >&6; }-    if ${fptools_cv_htype_off_t+:} false; then :+    if test "${fptools_cv_htype_off_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -14569,7 +14617,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for pid_t" >&5 $as_echo_n "checking Haskell type for pid_t... " >&6; }-    if ${fptools_cv_htype_pid_t+:} false; then :+    if test "${fptools_cv_htype_pid_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -14992,7 +15040,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for gid_t" >&5 $as_echo_n "checking Haskell type for gid_t... " >&6; }-    if ${fptools_cv_htype_gid_t+:} false; then :+    if test "${fptools_cv_htype_gid_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -15415,7 +15463,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for uid_t" >&5 $as_echo_n "checking Haskell type for uid_t... " >&6; }-    if ${fptools_cv_htype_uid_t+:} false; then :+    if test "${fptools_cv_htype_uid_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -15838,7 +15886,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for cc_t" >&5 $as_echo_n "checking Haskell type for cc_t... " >&6; }-    if ${fptools_cv_htype_cc_t+:} false; then :+    if test "${fptools_cv_htype_cc_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -16261,7 +16309,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for speed_t" >&5 $as_echo_n "checking Haskell type for speed_t... " >&6; }-    if ${fptools_cv_htype_speed_t+:} false; then :+    if test "${fptools_cv_htype_speed_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -16684,7 +16732,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for tcflag_t" >&5 $as_echo_n "checking Haskell type for tcflag_t... " >&6; }-    if ${fptools_cv_htype_tcflag_t+:} false; then :+    if test "${fptools_cv_htype_tcflag_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -17107,7 +17155,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for nlink_t" >&5 $as_echo_n "checking Haskell type for nlink_t... " >&6; }-    if ${fptools_cv_htype_nlink_t+:} false; then :+    if test "${fptools_cv_htype_nlink_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -17530,7 +17578,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for ssize_t" >&5 $as_echo_n "checking Haskell type for ssize_t... " >&6; }-    if ${fptools_cv_htype_ssize_t+:} false; then :+    if test "${fptools_cv_htype_ssize_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -17953,7 +18001,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for rlim_t" >&5 $as_echo_n "checking Haskell type for rlim_t... " >&6; }-    if ${fptools_cv_htype_rlim_t+:} false; then :+    if test "${fptools_cv_htype_rlim_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -18377,7 +18425,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for intptr_t" >&5 $as_echo_n "checking Haskell type for intptr_t... " >&6; }-    if ${fptools_cv_htype_intptr_t+:} false; then :+    if test "${fptools_cv_htype_intptr_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -18800,7 +18848,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for uintptr_t" >&5 $as_echo_n "checking Haskell type for uintptr_t... " >&6; }-    if ${fptools_cv_htype_uintptr_t+:} false; then :+    if test "${fptools_cv_htype_uintptr_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -19223,7 +19271,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for intmax_t" >&5 $as_echo_n "checking Haskell type for intmax_t... " >&6; }-    if ${fptools_cv_htype_intmax_t+:} false; then :+    if test "${fptools_cv_htype_intmax_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -19646,7 +19694,7 @@      { $as_echo "$as_me:${as_lineno-$LINENO}: checking Haskell type for uintmax_t" >&5 $as_echo_n "checking Haskell type for uintmax_t... " >&6; }-    if ${fptools_cv_htype_uintmax_t+:} false; then :+    if test "${fptools_cv_htype_uintmax_t+set}" = set; then :   $as_echo_n "(cached) " >&6 else @@ -20066,7 +20114,7 @@ as_fp_Cache=`$as_echo "fp_cv_const_$fp_const_name" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking value of $fp_const_name" >&5 $as_echo_n "checking value of $fp_const_name... " >&6; }-if eval \${$as_fp_Cache+:} false; then :+if eval "test \"\${$as_fp_Cache+set}\"" = set; then :   $as_echo_n "(cached) " >&6 else   if ac_fn_c_compute_int "$LINENO" "$fp_const_name" "fp_check_const_result"        "#include <stdio.h>@@ -20096,7 +20144,7 @@ as_fp_Cache=`$as_echo "fp_cv_const_$fp_const_name" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking value of $fp_const_name" >&5 $as_echo_n "checking value of $fp_const_name... " >&6; }-if eval \${$as_fp_Cache+:} false; then :+if eval "test \"\${$as_fp_Cache+set}\"" = set; then :   $as_echo_n "(cached) " >&6 else   if ac_fn_c_compute_int "$LINENO" "$fp_const_name" "fp_check_const_result"        "@@ -20124,7 +20172,7 @@  { $as_echo "$as_me:${as_lineno-$LINENO}: checking value of O_BINARY" >&5 $as_echo_n "checking value of O_BINARY... " >&6; }-if ${fp_cv_const_O_BINARY+:} false; then :+if test "${fp_cv_const_O_BINARY+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if ac_fn_c_compute_int "$LINENO" "O_BINARY" "fp_check_const_result"        "#include <fcntl.h>@@ -20157,7 +20205,7 @@ # to give prototype text. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing iconv" >&5 $as_echo_n "checking for library containing iconv... " >&6; }-if ${ac_cv_search_iconv+:} false; then :+if test "${ac_cv_search_iconv+set}" = set; then :   $as_echo_n "(cached) " >&6 else   ac_func_search_save_LIBS=$LIBS@@ -20190,11 +20238,11 @@ fi rm -f core conftest.err conftest.$ac_objext \     conftest$ac_exeext-  if ${ac_cv_search_iconv+:} false; then :+  if test "${ac_cv_search_iconv+set}" = set; then :   break fi done-if ${ac_cv_search_iconv+:} false; then :+if test "${ac_cv_search_iconv+set}" = set; then :  else   ac_cv_search_iconv=no@@ -20216,7 +20264,7 @@ # determine the current locale's character encoding. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing locale_charset" >&5 $as_echo_n "checking for library containing locale_charset... " >&6; }-if ${ac_cv_search_locale_charset+:} false; then :+if test "${ac_cv_search_locale_charset+set}" = set; then :   $as_echo_n "(cached) " >&6 else   ac_func_search_save_LIBS=$LIBS@@ -20243,11 +20291,11 @@ fi rm -f core conftest.err conftest.$ac_objext \     conftest$ac_exeext-  if ${ac_cv_search_locale_charset+:} false; then :+  if test "${ac_cv_search_locale_charset+set}" = set; then :   break fi done-if ${ac_cv_search_locale_charset+:} false; then :+if test "${ac_cv_search_locale_charset+set}" = set; then :  else   ac_cv_search_locale_charset=no@@ -20276,7 +20324,7 @@ # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of struct MD5Context" >&5 $as_echo_n "checking size of struct MD5Context... " >&6; }-if ${ac_cv_sizeof_struct_MD5Context+:} false; then :+if test "${ac_cv_sizeof_struct_MD5Context+set}" = set; then :   $as_echo_n "(cached) " >&6 else   if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (struct MD5Context))" "ac_cv_sizeof_struct_MD5Context"        "#include \"include/md5.h\"@@ -20287,7 +20335,7 @@      { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (struct MD5Context)-See \`config.log' for more details" "$LINENO" 5; }+See \`config.log' for more details" "$LINENO" 5 ; }    else      ac_cv_sizeof_struct_MD5Context=0    fi@@ -20373,21 +20421,10 @@      :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else   if test -w "$cache_file"; then-    if test "x$cache_file" != "x/dev/null"; then+    test "x$cache_file" != "x/dev/null" &&       { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;}-      if test ! -f "$cache_file" || test -h "$cache_file"; then-	cat confcache >"$cache_file"-      else-        case $cache_file in #(-        */* | ?:*)-	  mv -f confcache "$cache_file"$$ &&-	  mv -f "$cache_file"$$ "$cache_file" ;; #(-        *)-	  mv -f confcache "$cache_file" ;;-	esac-      fi-    fi+    cat confcache >$cache_file   else     { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}@@ -20419,7 +20456,7 @@   -: "${CONFIG_STATUS=./config.status}"+: ${CONFIG_STATUS=./config.status} ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS"@@ -20520,7 +20557,6 @@ IFS=" ""	$as_nl"  # Find who we are.  Look in the path if we contain no directory separator.-as_myself= case $0 in #((   *[\\/]* ) as_myself=$0 ;;   *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR@@ -20828,7 +20864,7 @@ # values after options handling. ac_log=" This file was extended by Haskell base package $as_me 1.0, which was-generated by GNU Autoconf 2.68.  Invocation command line was+generated by GNU Autoconf 2.67.  Invocation command line was    CONFIG_FILES    = $CONFIG_FILES   CONFIG_HEADERS  = $CONFIG_HEADERS@@ -20890,7 +20926,7 @@ ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ Haskell base package config.status 1.0-configured by $0, generated by GNU Autoconf 2.68,+configured by $0, generated by GNU Autoconf 2.67,   with options \\"\$ac_cs_config\\"  Copyright (C) 2010 Free Software Foundation, Inc.@@ -21014,7 +21050,7 @@     "include/EventConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/EventConfig.h" ;;     "base.buildinfo") CONFIG_FILES="$CONFIG_FILES base.buildinfo" ;; -  *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;+  *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5 ;;   esac done @@ -21036,10 +21072,9 @@ # after its creation but before its name has been assigned to `$tmp'. $debug || {-  tmp= ac_tmp=+  tmp=   trap 'exit_status=$?-  : "${ac_tmp:=$tmp}"-  { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status+  { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status ' 0   trap 'as_fn_exit 1' 1 2 13 15 }@@ -21047,13 +21082,12 @@  {   tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&-  test -d "$tmp"+  test -n "$tmp" && test -d "$tmp" }  || {   tmp=./conf$$-$RANDOM   (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5-ac_tmp=$tmp  # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES.@@ -21075,7 +21109,7 @@   ac_cs_awk_cr=$ac_cr fi -echo 'BEGIN {' >"$ac_tmp/subs1.awk" &&+echo 'BEGIN {' >"$tmp/subs1.awk" && _ACEOF  @@ -21103,7 +21137,7 @@ rm -f conf$$subs.sh  cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK &&+cat >>"\$tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h@@ -21151,7 +21185,7 @@ rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK-cat >>"\$ac_tmp/subs1.awk" <<_ACAWK &&+cat >>"\$tmp/subs1.awk" <<_ACAWK &&   for (key in S) S_is_set[key] = 1   FS = "" @@ -21183,7 +21217,7 @@   sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else   cat-fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \+fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \   || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF @@ -21217,7 +21251,7 @@ # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then-cat >"$ac_tmp/defines.awk" <<\_ACAWK ||+cat >"$tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF @@ -21229,8 +21263,8 @@ # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do-  ac_tt=`sed -n "/$ac_delim/p" confdefs.h`-  if test -z "$ac_tt"; then+  ac_t=`sed -n "/$ac_delim/p" confdefs.h`+  if test -z "$ac_t"; then     break   elif $ac_last_try; then     as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5@@ -21331,7 +21365,7 @@   esac   case $ac_mode$ac_tag in   :[FHL]*:*);;-  :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;;+  :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5 ;;   :[FH]-) ac_tag=-:-;;   :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;   esac@@ -21350,7 +21384,7 @@     for ac_f     do       case $ac_f in-      -) ac_f="$ac_tmp/stdin";;+      -) ac_f="$tmp/stdin";;       *) # Look for the file first in the build tree, then in the source tree 	 # (if the path is not absolute).  The absolute path cannot be DOS-style, 	 # because $ac_f cannot contain `:'.@@ -21359,7 +21393,7 @@ 	   [\\/$]*) false;; 	   *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; 	   esac ||-	   as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;+	   as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5 ;;       esac       case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac       as_fn_append ac_file_inputs " '$ac_f'"@@ -21385,8 +21419,8 @@     esac      case $ac_tag in-    *:-:* | *:-) cat >"$ac_tmp/stdin" \-      || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;+    *:-:* | *:-) cat >"$tmp/stdin" \+      || as_fn_error $? "could not create $ac_file" "$LINENO" 5  ;;     esac     ;;   esac@@ -21511,22 +21545,21 @@ s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack "-eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \-  >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5+eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \+  || as_fn_error $? "could not create $ac_file" "$LINENO" 5  test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&-  { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&-  { ac_out=`sed -n '/^[	 ]*datarootdir[	 ]*:*=/p' \-      "$ac_tmp/out"`; test -z "$ac_out"; } &&+  { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&+  { ac_out=`sed -n '/^[	 ]*datarootdir[	 ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&   { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined.  Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined.  Please make sure it is defined" >&2;} -  rm -f "$ac_tmp/stdin"+  rm -f "$tmp/stdin"   case $ac_file in-  -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;-  *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;+  -) cat "$tmp/out" && rm -f "$tmp/out";;+  *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";;   esac \   || as_fn_error $? "could not create $ac_file" "$LINENO" 5  ;;@@ -21537,20 +21570,20 @@   if test x"$ac_file" != x-; then     {       $as_echo "/* $configure_input  */" \-      && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs"-    } >"$ac_tmp/config.h" \+      && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs"+    } >"$tmp/config.h" \       || as_fn_error $? "could not create $ac_file" "$LINENO" 5-    if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then+    if diff "$ac_file" "$tmp/config.h" >/dev/null 2>&1; then       { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;}     else       rm -f "$ac_file"-      mv "$ac_tmp/config.h" "$ac_file" \+      mv "$tmp/config.h" "$ac_file" \ 	|| as_fn_error $? "could not create $ac_file" "$LINENO" 5     fi   else     $as_echo "/* $configure_input  */" \-      && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \+      && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" \       || as_fn_error $? "could not create -" "$LINENO" 5   fi  ;;

@@ -36,6 +36,8 @@ AC_CHECK_HEADERS([wctype.h], [AC_CHECK_FUNCS(iswspace)])  AC_CHECK_FUNCS([lstat])+AC_CHECK_LIB([rt], [clock_gettime])+AC_CHECK_FUNCS([clock_gettime]) AC_CHECK_FUNCS([getclock getrusage times]) AC_CHECK_FUNCS([_chsize ftruncate]) 

@@ -192,6 +192,12 @@ INSTANCE_SHOW(T,B); \ INSTANCE_TYPEABLE0(T,C,S) ; +#define INTEGRAL_TYPE_WITH_CTYPE(T,THE_CTYPE,C,S,B) \+newtype {-# CTYPE "THE_CTYPE" #-} T = T B deriving (ARITHMETIC_CLASSES, INTEGRAL_CLASSES); \+INSTANCE_READ(T,B); \+INSTANCE_SHOW(T,B); \+INSTANCE_TYPEABLE0(T,C,S) ;+ #define FLOATING_TYPE(T,C,S,B) \ newtype T = T B deriving (ARITHMETIC_CLASSES, FLOATING_CLASSES); \ INSTANCE_READ(T,B); \

@@ -81,7 +81,7 @@ #if HAVE_TIME_H #include <time.h> #endif-#if HAVE_SYS_TIMEB_H+#if HAVE_SYS_TIMEB_H && !defined(__FreeBSD__) #include <sys/timeb.h> #endif #if HAVE_WINDOWS_H@@ -104,6 +104,16 @@ #elif HAVE_STDINT_H # include <stdint.h> #endif+#if HAVE_CLOCK_GETTIME+# ifdef _POSIX_MONOTONIC_CLOCK+#  define CLOCK_ID CLOCK_MONOTONIC+# else+#  define CLOCK_ID CLOCK_REALTIME+# endif+#elif defined(darwin_HOST_OS)+# include <mach/mach.h>+# include <mach/mach_time.h>+#endif  #if !defined(__MINGW32__) && !defined(irix_HOST_OS) # if HAVE_SYS_RESOURCE_H@@ -131,7 +141,7 @@ #if defined(__MINGW32__) /* in Win32Utils.c */ extern void maperrno (void);-extern HsWord64 getUSecOfDay(void);+extern HsWord64 getMonotonicUSec(void); #endif  #if defined(__MINGW32__)@@ -148,9 +158,6 @@ /* in inputReady.c */ extern int fdReady(int fd, int write, int msecs, int isSock); -/* in Signals.c */-extern HsInt nocldstop;- /* -----------------------------------------------------------------------------    INLINE functions. @@ -170,43 +177,6 @@ INLINE int __hscore_get_errno(void) { return errno; } INLINE void __hscore_set_errno(int e) { errno = e; } -#if !defined(_MSC_VER)-INLINE int __hscore_s_isreg(mode_t m)  { return S_ISREG(m);  }-INLINE int __hscore_s_isdir(mode_t m)  { return S_ISDIR(m);  }-INLINE int __hscore_s_isfifo(mode_t m) { return S_ISFIFO(m); }-INLINE int __hscore_s_isblk(mode_t m)  { return S_ISBLK(m);  }-INLINE int __hscore_s_ischr(mode_t m)  { return S_ISCHR(m);  }-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)-INLINE int __hscore_s_issock(mode_t m) { return S_ISSOCK(m); }-#endif-#endif--#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32)-INLINE int-__hscore_sigemptyset( sigset_t *set )-{ return sigemptyset(set); }--INLINE int-__hscore_sigfillset( sigset_t *set )-{ return sigfillset(set); }--INLINE int-__hscore_sigaddset( sigset_t * set, int s )-{ return sigaddset(set,s); }--INLINE int-__hscore_sigdelset( sigset_t * set, int s )-{ return sigdelset(set,s); }--INLINE int-__hscore_sigismember( sigset_t * set, int s )-{ return sigismember(set,s); }-#endif--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(void) {@@ -214,12 +184,6 @@ }  INLINE int-__hscore_seek_cur(void)-{-  return SEEK_CUR;-}--INLINE int __hscore_o_binary(void) { #if defined(_MSC_VER)@@ -320,18 +284,6 @@ }  INLINE int-__hscore_seek_set( void )-{-  return SEEK_SET;-}--INLINE int-__hscore_seek_end( void )-{-  return SEEK_END;-}--INLINE int __hscore_ftruncate( int fd, off_t where ) { #if defined(HAVE_FTRUNCATE)@@ -574,15 +526,13 @@ extern void* __hscore_get_saved_termios(int fd); extern void __hscore_set_saved_termios(int fd, void* ts); -INLINE int __hscore_hs_fileno (FILE *f) { return fileno (f); }- #ifdef __MINGW32__ INLINE int __hscore_open(wchar_t *file, int how, mode_t mode) { 	if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND))-	  return _wsopen(file,how | _O_NOINHERIT,_SH_DENYRW,mode);+	  return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode);           // _O_NOINHERIT: see #2650 	else-	  return _wsopen(file,how | _O_NOINHERIT,_SH_DENYWR,mode);+	  return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode);           // _O_NOINHERIT: see #2650 } #else@@ -590,35 +540,6 @@ 	return open(file,how,mode); } #endif--// These are wrapped because on some OSs (eg. Linux) they are-// macros which redirect to the 64-bit-off_t versions when large file-// support is enabled.-//-#if defined(__MINGW32__)-INLINE off64_t __hscore_lseek(int fd, off64_t off, int whence) {-	return (_lseeki64(fd,off,whence));-}-#else-INLINE off_t __hscore_lseek(int fd, off_t off, int whence) {-	return (lseek(fd,off,whence));-}-#endif--// select-related stuff--#if !defined(__MINGW32__)-INLINE int  hsFD_SETSIZE(void) { return FD_SETSIZE; }-INLINE int  hsFD_ISSET(int fd, fd_set *fds) { return FD_ISSET(fd, fds); }-INLINE void hsFD_SET(int fd, fd_set *fds) { FD_SET(fd, fds); }-INLINE HsInt sizeof_fd_set(void) { return sizeof(fd_set); }-extern void hsFD_ZERO(fd_set *fds);-#endif--INLINE int __hscore_select(int nfds, fd_set *readfds, fd_set *writefds,-                           fd_set *exceptfds, struct timeval *timeout) {-	return (select(nfds,readfds,writefds,exceptfds,timeout));-}  #if darwin_HOST_OS // You should not access _environ directly on Darwin in a bundle/shared library.