diff --git a/Control/Applicative.hs b/Control/Applicative.hs --- a/Control/Applicative.hs +++ b/Control/Applicative.hs @@ -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 diff --git a/Control/Arrow.hs b/Control/Arrow.hs --- a/Control/Arrow.hs +++ b/Control/Arrow.hs @@ -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'. diff --git a/Control/Category.hs b/Control/Category.hs --- a/Control/Category.hs +++ b/Control/Category.hs @@ -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 diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -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 $ diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs --- a/Control/Concurrent/Chan.hs +++ b/Control/Concurrent/Chan.hs @@ -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 diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs --- a/Control/Concurrent/MVar.hs +++ b/Control/Concurrent/MVar.hs @@ -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 #) diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs --- a/Control/Concurrent/QSem.hs +++ b/Control/Concurrent/QSem.hs @@ -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 diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs --- a/Control/Concurrent/QSemN.hs +++ b/Control/Concurrent/QSemN.hs @@ -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 diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs --- a/Control/Concurrent/SampleVar.hs +++ b/Control/Concurrent/SampleVar.hs @@ -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 _ = diff --git a/Control/Exception.hs b/Control/Exception.hs --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -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 diff --git a/Control/Monad.hs b/Control/Monad.hs --- a/Control/Monad.hs +++ b/Control/Monad.hs @@ -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 () diff --git a/Control/Monad/Fix.hs b/Control/Monad/Fix.hs --- a/Control/Monad/Fix.hs +++ b/Control/Monad/Fix.hs @@ -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 diff --git a/Control/Monad/Instances.hs b/Control/Monad/Instances.hs --- a/Control/Monad/Instances.hs +++ b/Control/Monad/Instances.hs @@ -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 - diff --git a/Control/Monad/ST/Imp.hs b/Control/Monad/ST/Imp.hs --- a/Control/Monad/ST/Imp.hs +++ b/Control/Monad/ST/Imp.hs @@ -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 diff --git a/Control/OldException.hs b/Control/OldException.hs deleted file mode 100644 --- a/Control/OldException.hs +++ /dev/null @@ -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 - diff --git a/Data/Bits.hs b/Data/Bits.hs --- a/Data/Bits.hs +++ b/Data/Bits.hs @@ -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 diff --git a/Data/Char.hs b/Data/Char.hs --- a/Data/Char.hs +++ b/Data/Char.hs @@ -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) diff --git a/Data/Either.hs b/Data/Either.hs --- a/Data/Either.hs +++ b/Data/Either.hs @@ -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@; diff --git a/Data/Foldable.hs b/Data/Foldable.hs --- a/Data/Foldable.hs +++ b/Data/Foldable.hs @@ -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. diff --git a/Data/HashTable.hs b/Data/HashTable.hs --- a/Data/HashTable.hs +++ b/Data/HashTable.hs @@ -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 diff --git a/Data/IORef.hs b/Data/IORef.hs --- a/Data/IORef.hs +++ b/Data/IORef.hs @@ -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 diff --git a/Data/List.hs b/Data/List.hs --- a/Data/List.hs +++ b/Data/List.hs @@ -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 (==) diff --git a/Data/Maybe.hs b/Data/Maybe.hs --- a/Data/Maybe.hs +++ b/Data/Maybe.hs @@ -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 diff --git a/Data/Monoid.hs b/Data/Monoid.hs --- a/Data/Monoid.hs +++ b/Data/Monoid.hs @@ -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 diff --git a/Data/Ord.hs b/Data/Ord.hs --- a/Data/Ord.hs +++ b/Data/Ord.hs @@ -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 diff --git a/Data/STRef.hs b/Data/STRef.hs --- a/Data/STRef.hs +++ b/Data/STRef.hs @@ -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' diff --git a/Data/Typeable.hs b/Data/Typeable.hs --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -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 diff --git a/Data/Typeable/Internal.hs b/Data/Typeable/Internal.hs --- a/Data/Typeable/Internal.hs +++ b/Data/Typeable/Internal.hs @@ -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: diff --git a/Data/Unique.hs b/Data/Unique.hs --- a/Data/Unique.hs +++ b/Data/Unique.hs @@ -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' diff --git a/Foreign/C/Error.hs b/Foreign/C/Error.hs --- a/Foreign/C/Error.hs +++ b/Foreign/C/Error.hs @@ -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__ diff --git a/Foreign/C/String.hs b/Foreign/C/String.hs --- a/Foreign/C/String.hs +++ b/Foreign/C/String.hs @@ -110,6 +110,7 @@ #ifdef __GLASGOW_HASKELL__ import Control.Monad +import GHC.Char import GHC.List import GHC.Real import GHC.Num diff --git a/Foreign/Marshal/Error.hs b/Foreign/Marshal/Error.hs --- a/Foreign/Marshal/Error.hs +++ b/Foreign/Marshal/Error.hs @@ -83,4 +83,4 @@ -- void :: IO a -> IO () void act = act >> return () - +{-# DEPRECATED void "use Control.Monad.void instead" #-} diff --git a/Foreign/Ptr.hs b/Foreign/Ptr.hs --- a/Foreign/Ptr.hs +++ b/Foreign/Ptr.hs @@ -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 diff --git a/Foreign/Storable.hs b/Foreign/Storable.hs --- a/Foreign/Storable.hs +++ b/Foreign/Storable.hs @@ -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 diff --git a/GHC/Arr.lhs b/GHC/Arr.lhs --- a/GHC/Arr.lhs +++ b/GHC/Arr.lhs @@ -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 diff --git a/GHC/Base.lhs b/GHC/Base.lhs --- a/GHC/Base.lhs +++ b/GHC/Base.lhs @@ -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 diff --git a/GHC/Char.hs b/GHC/Char.hs new file mode 100644 --- /dev/null +++ b/GHC/Char.hs @@ -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 "") + diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -51,6 +51,7 @@ , runSparks , yield -- :: IO () , labelThread -- :: ThreadId -> String -> IO () + , mkWeakThreadId -- :: ThreadId -> IO (Weak ThreadId) , ThreadStatus(..), BlockReason(..) , threadStatus -- :: ThreadId -> IO ThreadStatus diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs --- a/GHC/Conc/Sync.lhs +++ b/GHC/Conc/Sync.lhs @@ -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} diff --git a/GHC/Conc/Windows.hs b/GHC/Conc/Windows.hs --- a/GHC/Conc/Windows.hs +++ b/GHC/Conc/Windows.hs @@ -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 diff --git a/GHC/Desugar.hs b/GHC/Desugar.hs --- a/GHC/Desugar.hs +++ b/GHC/Desugar.hs @@ -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 diff --git a/GHC/Enum.lhs b/GHC/Enum.lhs --- a/GHC/Enum.lhs +++ b/GHC/Enum.lhs @@ -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} diff --git a/GHC/Environment.hs b/GHC/Environment.hs --- a/GHC/Environment.hs +++ b/GHC/Environment.hs @@ -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 diff --git a/GHC/Err.lhs b/GHC/Err.lhs --- a/GHC/Err.lhs +++ b/GHC/Err.lhs @@ -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 diff --git a/GHC/Event/Clock.hsc b/GHC/Event/Clock.hsc --- a/GHC/Event/Clock.hsc +++ b/GHC/Event/Clock.hsc @@ -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 +#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 diff --git a/GHC/Event/IntMap.hs b/GHC/Event/IntMap.hs --- a/GHC/Event/IntMap.hs +++ b/GHC/Event/IntMap.hs @@ -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 diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs --- a/GHC/Event/Manager.hs +++ b/GHC/Event/Manager.hs @@ -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 -> diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs --- a/GHC/Event/Thread.hs +++ b/GHC/Event/Thread.hs @@ -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 diff --git a/GHC/Exception.lhs b/GHC/Exception.lhs --- a/GHC/Exception.lhs +++ b/GHC/Exception.lhs @@ -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} diff --git a/GHC/Exts.hs b/GHC/Exts.hs --- a/GHC/Exts.hs +++ b/GHC/Exts.hs @@ -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]] diff --git a/GHC/Float.lhs b/GHC/Float.lhs --- a/GHC/Float.lhs +++ b/GHC/Float.lhs @@ -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" diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs --- a/GHC/ForeignPtr.hs +++ b/GHC/ForeignPtr.hs @@ -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 diff --git a/GHC/GHCi.hs b/GHC/GHCi.hs new file mode 100644 --- /dev/null +++ b/GHC/GHCi.hs @@ -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 + diff --git a/GHC/Generics.hs b/GHC/Generics.hs new file mode 100644 --- /dev/null +++ b/GHC/Generics.hs @@ -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 diff --git a/GHC/IO/Encoding/CodePage.hs b/GHC/IO/Encoding/CodePage.hs --- a/GHC/IO/Encoding/CodePage.hs +++ b/GHC/IO/Encoding/CodePage.hs @@ -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 #-} diff --git a/GHC/IO/Encoding/Failure.hs b/GHC/IO/Encoding/Failure.hs --- a/GHC/IO/Encoding/Failure.hs +++ b/GHC/IO/Encoding/Failure.hs @@ -26,6 +26,7 @@ import GHC.IO.Exception import GHC.Base +import GHC.Char import GHC.Word import GHC.Show import GHC.Num diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs --- a/GHC/IO/FD.hs +++ b/GHC/IO/FD.hs @@ -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 diff --git a/GHC/IP.hs b/GHC/IP.hs new file mode 100644 --- /dev/null +++ b/GHC/IP.hs @@ -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 + + diff --git a/GHC/Int.hs b/GHC/Int.hs --- a/GHC/Int.hs +++ b/GHC/Int.hs @@ -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# diff --git a/GHC/MVar.hs b/GHC/MVar.hs --- a/GHC/MVar.hs +++ b/GHC/MVar.hs @@ -31,7 +31,6 @@ ) where import GHC.Base -import GHC.IO () -- instance Monad IO import Data.Maybe data MVar a = MVar (MVar# RealWorld a) diff --git a/GHC/Num.lhs b/GHC/Num.lhs --- a/GHC/Num.lhs +++ b/GHC/Num.lhs @@ -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} %********************************************************* diff --git a/GHC/Read.lhs b/GHC/Read.lhs --- a/GHC/Read.lhs +++ b/GHC/Read.lhs @@ -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} diff --git a/GHC/Real.lhs b/GHC/Real.lhs --- a/GHC/Real.lhs +++ b/GHC/Real.lhs @@ -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) diff --git a/GHC/ST.lhs b/GHC/ST.lhs --- a/GHC/ST.lhs +++ b/GHC/ST.lhs @@ -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. diff --git a/GHC/Show.lhs b/GHC/Show.lhs --- a/GHC/Show.lhs +++ b/GHC/Show.lhs @@ -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} diff --git a/GHC/Stable.lhs b/GHC/Stable.lhs --- a/GHC/Stable.lhs +++ b/GHC/Stable.lhs @@ -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. diff --git a/GHC/Stats.hsc b/GHC/Stats.hsc --- a/GHC/Stats.hsc +++ b/GHC/Stats.hsc @@ -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 { .. } diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs --- a/GHC/TopHandler.lhs +++ b/GHC/TopHandler.lhs @@ -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 diff --git a/GHC/TypeLits.hs b/GHC/TypeLits.hs new file mode 100644 --- /dev/null +++ b/GHC/TypeLits.hs @@ -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)" + + diff --git a/GHC/Unicode.hs b/GHC/Unicode.hs --- a/GHC/Unicode.hs +++ b/GHC/Unicode.hs @@ -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 diff --git a/GHC/Weak.lhs b/GHC/Weak.lhs --- a/GHC/Weak.lhs +++ b/GHC/Weak.lhs @@ -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 diff --git a/GHC/Word.hs b/GHC/Word.hs --- a/GHC/Word.hs +++ b/GHC/Word.hs @@ -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# diff --git a/Numeric.hs b/Numeric.hs --- a/Numeric.hs +++ b/Numeric.hs @@ -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 diff --git a/Prelude.hs b/Prelude.hs --- a/Prelude.hs +++ b/Prelude.hs @@ -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 diff --git a/System/CPUTime.hsc b/System/CPUTime.hsc --- a/System/CPUTime.hsc +++ b/System/CPUTime.hsc @@ -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__ */ diff --git a/System/Environment.hs b/System/Environment.hs --- a/System/Environment.hs +++ b/System/Environment.hs @@ -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__ */ - diff --git a/System/Environment/ExecutablePath.hsc b/System/Environment/ExecutablePath.hsc new file mode 100644 --- /dev/null +++ b/System/Environment/ExecutablePath.hsc @@ -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 diff --git a/System/IO/Error.hs b/System/IO/Error.hs --- a/System/IO/Error.hs +++ b/System/IO/Error.hs @@ -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__ */ diff --git a/System/Mem/Weak.hs b/System/Mem/Weak.hs --- a/System/Mem/Weak.hs +++ b/System/Mem/Weak.hs @@ -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. -} diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs --- a/System/Posix/Internals.hs +++ b/System/Posix/Internals.hs @@ -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). +-} diff --git a/System/Posix/Types.hs b/System/Posix/Types.hs --- a/System/Posix/Types.hs +++ b/System/Posix/Types.hs @@ -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) diff --git a/System/Timeout.hs b/System/Timeout.hs --- a/System/Timeout.hs +++ b/System/Timeout.hs @@ -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 diff --git a/Text/ParserCombinators/ReadP.hs b/Text/ParserCombinators/ReadP.hs --- a/Text/ParserCombinators/ReadP.hs +++ b/Text/ParserCombinators/ReadP.hs @@ -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 diff --git a/Text/Read.hs b/Text/Read.hs --- a/Text/Read.hs +++ b/Text/Read.hs @@ -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. diff --git a/Text/Read/Lex.hs b/Text/Read/Lex.hs --- a/Text/Read/Lex.hs +++ b/Text/Read/Lex.hs @@ -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 diff --git a/Unsafe/Coerce.hs b/Unsafe/Coerce.hs --- a/Unsafe/Coerce.hs +++ b/Unsafe/Coerce.hs @@ -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__) diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -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 diff --git a/cbits/DarwinUtils.c b/cbits/DarwinUtils.c new file mode 100644 --- /dev/null +++ b/cbits/DarwinUtils.c @@ -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 diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c --- a/cbits/Win32Utils.c +++ b/cbits/Win32Utils.c @@ -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 - diff --git a/cbits/selectUtils.c b/cbits/selectUtils.c deleted file mode 100644 --- a/cbits/selectUtils.c +++ /dev/null @@ -1,3 +0,0 @@ - -#include "HsBase.h" -void hsFD_ZERO(fd_set *fds) { FD_ZERO(fds); } diff --git a/configure b/configure --- a/configure +++ b/configure @@ -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 . # @@ -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 @@ -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 @@ -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 ;; diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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]) diff --git a/include/CTypes.h b/include/CTypes.h --- a/include/CTypes.h +++ b/include/CTypes.h @@ -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); \ diff --git a/include/HsBase.h b/include/HsBase.h --- a/include/HsBase.h +++ b/include/HsBase.h @@ -81,7 +81,7 @@ #if HAVE_TIME_H #include #endif -#if HAVE_SYS_TIMEB_H +#if HAVE_SYS_TIMEB_H && !defined(__FreeBSD__) #include #endif #if HAVE_WINDOWS_H @@ -104,6 +104,16 @@ #elif HAVE_STDINT_H # include #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 +# include +#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. diff --git a/include/HsBaseConfig.h b/include/HsBaseConfig.h --- a/include/HsBaseConfig.h +++ b/include/HsBaseConfig.h @@ -304,6 +304,9 @@ /* The value of SIGINT. */ #define CONST_SIGINT 2 +/* Define to 1 if you have the `clock_gettime' function. */ +#define HAVE_CLOCK_GETTIME 1 + /* Define to 1 if you have the header file. */ #define HAVE_CTYPE_H 1 @@ -352,6 +355,9 @@ /* Define to 1 if you have libcharset. */ /* #undef HAVE_LIBCHARSET */ +/* Define to 1 if you have the `rt' library (-lrt). */ +#define HAVE_LIBRT 1 + /* Define to 1 if you have the header file. */ #define HAVE_LIMITS_H 1 @@ -461,7 +467,7 @@ #define HTYPE_CHAR Int8 /* Define to Haskell type for clock_t */ -#define HTYPE_CLOCK_T Int32 +#define HTYPE_CLOCK_T Int64 /* Define to Haskell type for dev_t */ #define HTYPE_DEV_T Word64 @@ -485,10 +491,10 @@ #define HTYPE_INTMAX_T Int64 /* Define to Haskell type for intptr_t */ -#define HTYPE_INTPTR_T Int32 +#define HTYPE_INTPTR_T Int64 /* Define to Haskell type for long */ -#define HTYPE_LONG Int32 +#define HTYPE_LONG Int64 /* Define to Haskell type for long long */ #define HTYPE_LONG_LONG Int64 @@ -497,7 +503,7 @@ #define HTYPE_MODE_T Word32 /* Define to Haskell type for nlink_t */ -#define HTYPE_NLINK_T Word32 +#define HTYPE_NLINK_T Word64 /* Define to Haskell type for off_t */ #define HTYPE_OFF_T Int64 @@ -506,7 +512,7 @@ #define HTYPE_PID_T Int32 /* Define to Haskell type for ptrdiff_t */ -#define HTYPE_PTRDIFF_T Int32 +#define HTYPE_PTRDIFF_T Int64 /* Define to Haskell type for rlim_t */ #define HTYPE_RLIM_T Word64 @@ -521,22 +527,22 @@ #define HTYPE_SIG_ATOMIC_T Int32 /* Define to Haskell type for size_t */ -#define HTYPE_SIZE_T Word32 +#define HTYPE_SIZE_T Word64 /* Define to Haskell type for speed_t */ #define HTYPE_SPEED_T Word32 /* Define to Haskell type for ssize_t */ -#define HTYPE_SSIZE_T Int32 +#define HTYPE_SSIZE_T Int64 /* Define to Haskell type for suseconds_t */ -#define HTYPE_SUSECONDS_T Int32 +#define HTYPE_SUSECONDS_T Int64 /* Define to Haskell type for tcflag_t */ #define HTYPE_TCFLAG_T Word32 /* Define to Haskell type for time_t */ -#define HTYPE_TIME_T Int32 +#define HTYPE_TIME_T Int64 /* Define to Haskell type for uid_t */ #define HTYPE_UID_T Word32 @@ -545,7 +551,7 @@ #define HTYPE_UINTMAX_T Word64 /* Define to Haskell type for uintptr_t */ -#define HTYPE_UINTPTR_T Word32 +#define HTYPE_UINTPTR_T Word64 /* Define to Haskell type for unsigned char */ #define HTYPE_UNSIGNED_CHAR Word8 @@ -554,7 +560,7 @@ #define HTYPE_UNSIGNED_INT Word32 /* Define to Haskell type for unsigned long */ -#define HTYPE_UNSIGNED_LONG Word32 +#define HTYPE_UNSIGNED_LONG Word64 /* Define to Haskell type for unsigned long long */ #define HTYPE_UNSIGNED_LONG_LONG Word64 @@ -593,7 +599,7 @@ #define STDC_HEADERS 1 /* Number of bits in a file offset, on hosts where this is settable. */ -#define _FILE_OFFSET_BITS 64 +/* #undef _FILE_OFFSET_BITS */ /* Define for large files, on AIX-style hosts. */ /* #undef _LARGE_FILES */