Commit 0f5eae02 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Constant-fold `__GLASGOW_HASKELL__` CPP conditionals

Now that HUGS and NHC specific code has been removed, this commit "folds"
the now redundant `#if((n)def)`s containing `__GLASGOW_HASKELL__`.  This
renders `base` officially GHC only.

This commit also removes redundant `{-# LANGUAGE CPP #-}`.
Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parent 43ece172
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
......@@ -59,9 +58,7 @@ import Data.Proxy
import Text.ParserCombinators.ReadP (ReadP)
import Text.ParserCombinators.ReadPrec (ReadPrec)
#ifdef __GLASGOW_HASKELL__
import GHC.Conc (STM, retry, orElse)
#endif
infixl 3 <|>
infixl 4 <*>, <*, *>, <**>
......@@ -181,7 +178,6 @@ instance Applicative (Lazy.ST s) where
pure = return
(<*>) = ap
#ifdef __GLASGOW_HASKELL__
instance Applicative STM where
pure = return
(<*>) = ap
......@@ -189,7 +185,6 @@ instance Applicative STM where
instance Alternative STM where
empty = retry
(<|>) = orElse
#endif
instance Applicative ((->) a) where
pure = const
......
......@@ -20,10 +20,7 @@
module Control.Category where
import qualified Prelude
#ifdef __GLASGOW_HASKELL__
import Data.Type.Equality
#endif
infixr 9 .
infixr 1 >>>, <<<
......@@ -50,11 +47,9 @@ instance Category (->) where
id = Prelude.id
(.) = (Prelude..)
#ifdef __GLASGOW_HASKELL__
instance Category (:=:) where
id = Refl
Refl . Refl = Refl
#endif
-- | Right-to-left composition
(<<<) :: Category cat => cat b c -> cat a b -> cat a c
......
......@@ -33,17 +33,13 @@ module Control.Concurrent (
-- * Basic concurrency operations
ThreadId,
#ifdef __GLASGOW_HASKELL__
myThreadId,
#endif
forkIO,
#ifdef __GLASGOW_HASKELL__
forkFinally,
forkIOWithUnmask,
killThread,
throwTo,
#endif
-- ** Threads with affinity
forkOn,
......@@ -61,14 +57,12 @@ module Control.Concurrent (
-- $blocking
#ifdef __GLASGOW_HASKELL__
-- ** Waiting
threadDelay,
threadWaitRead,
threadWaitWrite,
threadWaitReadSTM,
threadWaitWriteSTM,
#endif
-- * Communication abstractions
......@@ -77,7 +71,6 @@ module Control.Concurrent (
module Control.Concurrent.QSem,
module Control.Concurrent.QSemN,
#ifdef __GLASGOW_HASKELL__
-- * Bound Threads
-- $boundthreads
rtsSupportsBoundThreads,
......@@ -85,7 +78,6 @@ module Control.Concurrent (
isCurrentThreadBound,
runInBoundThread,
runInUnboundThread,
#endif
-- * Weak references to ThreadIds
mkWeakThreadId,
......@@ -117,7 +109,6 @@ import Prelude
import Control.Exception.Base as Exception
#ifdef __GLASGOW_HASKELL__
import GHC.Exception
import GHC.Conc hiding (threadWaitRead, threadWaitWrite,
threadWaitReadSTM, threadWaitWriteSTM)
......@@ -136,7 +127,6 @@ import Foreign.C
import System.IO
import Data.Maybe (Maybe(..))
#endif
#endif
import Control.Concurrent.MVar
import Control.Concurrent.Chan
......@@ -211,7 +201,6 @@ forkFinally action and_then =
mask $ \restore ->
forkIO $ try (restore action) >>= and_then
#ifdef __GLASGOW_HASKELL__
-- ---------------------------------------------------------------------------
-- Bound Threads
......@@ -396,9 +385,7 @@ runInUnboundThread action = do
unsafeResult :: Either SomeException a -> IO a
unsafeResult = either Exception.throwIO return
#endif /* __GLASGOW_HASKELL__ */
#ifdef __GLASGOW_HASKELL__
-- ---------------------------------------------------------------------------
-- threadWaitRead/threadWaitWrite
......@@ -672,5 +659,3 @@ alternative then it is possible to prevent the thread from being
considered deadlocked by making a 'StablePtr' pointing to it. Don't
forget to release the 'StablePtr' later with 'freeStablePtr'.
-}
#endif /* __GLASGOW_HASKELL__ */
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
#endif
-----------------------------------------------------------------------------
-- |
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, UnboxedTuples, MagicHash #-}
{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, MagicHash #-}
-----------------------------------------------------------------------------
-- |
......@@ -146,20 +146,13 @@ module Control.Concurrent.MVar
, addMVarFinalizer
) where
#ifdef __GLASGOW_HASKELL__
import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,
tryTakeMVar, tryPutMVar, isEmptyMVar, readMVar,
tryReadMVar
)
import qualified GHC.MVar
import GHC.Weak
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Base
#else
import Prelude
#endif
import Control.Exception.Base
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
#endif
{-# OPTIONS_GHC -funbox-strict-fields #-}
-----------------------------------------------------------------------------
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
#endif
{-# OPTIONS_GHC -funbox-strict-fields #-}
-----------------------------------------------------------------------------
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}
-----------------------------------------------------------------------------
-- |
......@@ -44,11 +44,8 @@ module Control.Exception (
AsyncException(..), -- instance Eq, Ord, Show, Typeable, Exception
asyncExceptionToException, asyncExceptionFromException,
#if __GLASGOW_HASKELL__
NonTermination(..),
NestedAtomically(..),
#endif
BlockedIndefinitelyOnMVar(..),
BlockedIndefinitelyOnSTM(..),
Deadlock(..),
......@@ -63,9 +60,7 @@ module Control.Exception (
throw,
throwIO,
ioError,
#ifdef __GLASGOW_HASKELL__
throwTo,
#endif
-- * Catching Exceptions
......@@ -136,13 +131,9 @@ module Control.Exception (
import Control.Exception.Base
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IO (unsafeUnmask)
import Data.Maybe
#else
import Prelude hiding (catch)
#endif
-- | You need this when using 'catches'.
data Handler a = forall e . Exception e => Handler (e -> IO a)
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
#endif
#include "Typeable.h"
......@@ -31,12 +29,8 @@ module Control.Exception.Base (
AssertionFailed(..),
SomeAsyncException(..), AsyncException(..),
asyncExceptionToException, asyncExceptionFromException,
#ifdef __GLASGOW_HASKELL__
NonTermination(..),
NestedAtomically(..),
#endif
BlockedIndefinitelyOnMVar(..),
BlockedIndefinitelyOnSTM(..),
Deadlock(..),
......@@ -51,9 +45,7 @@ module Control.Exception.Base (
throwIO,
throw,
ioError,
#ifdef __GLASGOW_HASKELL__
throwTo,
#endif
-- * Catching Exceptions
......@@ -98,16 +90,13 @@ module Control.Exception.Base (
finally,
#ifdef __GLASGOW_HASKELL__
-- * Calls for GHC runtime
recSelError, recConError, irrefutPatError, runtimeError,
nonExhaustiveGuardsError, patError, noMethodBindingError,
absentError,
nonTermination, nestedAtomically,
#endif
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IO hiding (bracket,finally,onException)
import GHC.IO.Exception
......@@ -115,7 +104,6 @@ import GHC.Exception
import GHC.Show
-- import GHC.Exception hiding ( Exception )
import GHC.Conc.Sync
#endif
import Data.Dynamic
import Data.Either
......@@ -161,9 +149,7 @@ catch :: Exception e
=> IO a -- ^ The computation to run
-> (e -> IO a) -- ^ Handler to invoke if an exception is raised
-> IO a
#if __GLASGOW_HASKELL__
catch = catchException
#endif
-- | The function 'catchJust' is like 'catch', but it takes an extra
-- argument which is an /exception predicate/, a function which
......@@ -309,15 +295,8 @@ bracketOnError before after thing =
a <- before
restore (thing a) `onException` after a
#if !__GLASGOW_HASKELL__
assert :: Bool -> a -> a
assert True x = x
assert False _ = throw (AssertionFailed "")
#endif
-----
#if __GLASGOW_HASKELL__
-- |A pattern match failed. The @String@ gives information about the
-- source location of the pattern.
data PatternMatchFail = PatternMatchFail String
......@@ -412,9 +391,6 @@ instance Exception NestedAtomically
-----
#endif /* __GLASGOW_HASKELL__ */
#ifdef __GLASGOW_HASKELL__
recSelError, recConError, irrefutPatError, runtimeError,
nonExhaustiveGuardsError, patError, noMethodBindingError,
absentError
......@@ -438,4 +414,3 @@ nonTermination = toException NonTermination
-- GHC's RTS calls this
nestedAtomically :: SomeException
nestedAtomically = toException NestedAtomically
#endif
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
......@@ -78,12 +78,9 @@ module Control.Monad
import Data.Maybe
#ifdef __GLASGOW_HASKELL__
import GHC.List
import GHC.Base
#endif
#ifdef __GLASGOW_HASKELL__
infixr 1 =<<
-- -----------------------------------------------------------------------------
......@@ -118,8 +115,6 @@ mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
{-# INLINE mapM_ #-}
mapM_ f as = sequence_ (map f as)
#endif /* __GLASGOW_HASKELL__ */
-- -----------------------------------------------------------------------------
-- The MonadPlus class definition
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
......@@ -26,9 +25,7 @@ module Control.Monad.Fix (
import Prelude
import System.IO
import Data.Function (fix)
#if defined(__GLASGOW_HASKELL__)
import GHC.ST
#endif
-- | Monads having fixed points with a \'knot-tying\' semantics.
-- Instances of 'MonadFix' should satisfy the following laws:
......@@ -78,8 +75,5 @@ instance MonadFix (Either e) where
where unRight (Right x) = x
unRight (Left _) = error "mfix Either: Left"
#if defined(__GLASGOW_HASKELL__)
instance MonadFix (ST s) where
mfix = fixST
#endif
......@@ -35,21 +35,8 @@ module Control.Monad.ST.Imp (
unsafeSTToIO
) where
#if !defined(__GLASGOW_HASKELL__)
import Control.Monad.Fix
#endif
#include "Typeable.h"
#if defined(__GLASGOW_HASKELL__)
import GHC.ST ( ST, runST, fixST, unsafeInterleaveST )
import GHC.Base ( RealWorld )
import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO )
#endif
#if !defined(__GLASGOW_HASKELL__)
instance MonadFix (ST s) where
mfix = fixST
#endif
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes #-}
{-# LANGUAGE MagicHash, UnboxedTuples, RankNTypes #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
......@@ -44,12 +44,9 @@ import Control.Monad.Fix
import qualified Control.Monad.ST.Safe as ST
import qualified Control.Monad.ST.Unsafe as ST
#ifdef __GLASGOW_HASKELL__
import qualified GHC.ST as GHC.ST
import GHC.Base
#endif
#ifdef __GLASGOW_HASKELL__
-- | The lazy state-transformer monad.
-- A computation of type @'ST' s a@ transforms an internal state indexed
-- by @s@, and returns a value of type @a@.
......@@ -107,7 +104,6 @@ fixST m = ST (\ s ->
(r,s') = m_r s
in
(r,s'))
#endif
instance MonadFix (ST s) where
mfix = fixST
......@@ -115,7 +111,6 @@ instance MonadFix (ST s) where
-- ---------------------------------------------------------------------------
-- Strict <--> Lazy
#ifdef __GLASGOW_HASKELL__
{-|
Convert a strict 'ST' computation into a lazy one. The strict state
thread passed to 'strictToLazyST' is not performed until the result of
......@@ -136,7 +131,6 @@ Convert a lazy 'ST' computation into a strict one.
lazyToStrictST :: ST s a -> ST.ST s a
lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
case (m (S# s)) of (a, S# s') -> (# s', a #)
#endif
-- | A monad transformer embedding lazy state transformers in the 'IO'
-- monad. The 'RealWorld' parameter indicates that the internal state
......@@ -148,10 +142,8 @@ stToIO = ST.stToIO . lazyToStrictST
-- ---------------------------------------------------------------------------
-- Strict <--> Lazy
#ifdef __GLASGOW_HASKELL__
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
#endif
unsafeIOToST :: IO a -> ST s a
unsafeIOToST = strictToLazyST . ST.unsafeIOToST
......
......@@ -49,16 +49,12 @@ module Data.Bits (
-- See library document for details on the semantics of the
-- individual operations.
#ifdef __GLASGOW_HASKELL__
#include "MachDeps.h"
#endif
#ifdef __GLASGOW_HASKELL__
import Data.Maybe
import GHC.Enum
import GHC.Num
import GHC.Base
#endif
infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
infixl 7 .&.
......@@ -280,7 +276,6 @@ instance Bits Int where
{-# INLINE bit #-}
{-# INLINE testBit #-}
#ifdef __GLASGOW_HASKELL__
bit = bitDefault
testBit = testBitDefault
......@@ -314,26 +309,11 @@ instance Bits Int where
popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#)))
#else /* !__GLASGOW_HASKELL__ */
popCount = popCountDefault
x `rotate` i
| i<0 && x<0 = let left = i+bitSize x in
((x `shift` i) .&. complement ((-1) `shift` left))
.|. (x `shift` left)
| i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
| i==0 = x
| i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
#endif /* !__GLASGOW_HASKELL__ */
isSigned _ = True
instance FiniteBits Int where
finiteBitSize _ = WORD_SIZE_IN_BITS
#if defined(__GLASGOW_HASKELL__)
instance Bits Word where
{-# INLINE shift #-}
{-# INLINE bit #-}
......@@ -366,10 +346,8 @@ instance Bits Word where
instance FiniteBits Word where
finiteBitSize _ = WORD_SIZE_IN_BITS
#endif
instance Bits Integer where
#if defined(__GLASGOW_HASKELL__)
(.&.) = andInteger
(.|.) = orInteger
xor = xorInteger
......@@ -377,26 +355,6 @@ instance Bits Integer where
shift x i@(I# i#) | i >= 0 = shiftLInteger x i#
| otherwise = shiftRInteger x (negateInt# i#)
testBit x (I# i) = testBitInteger x i
#else
-- reduce bitwise binary operations to special cases we can handle
x .&. y | x<0 && y<0 = complement (complement x `posOr` complement y)
| otherwise = x `posAnd` y
x .|. y | x<0 || y<0 = complement (complement x `posAnd` complement y)
| otherwise = x `posOr` y
x `xor` y | x<0 && y<0 = complement x `posXOr` complement y
| x<0 = complement (complement x `posXOr` y)
| y<0 = complement (x `posXOr` complement y)
| otherwise = x `posXOr` y
-- assuming infinite 2's-complement arithmetic
complement a = -1 - a
shift x i | i >= 0 = x * 2^i
| otherwise = x `div` 2^(-i)
testBit = testBitDefault
#endif
bit = bitDefault
popCount = popCountDefault
......@@ -407,38 +365,6 @@ instance Bits Integer where
bitSize _ = error "Data.Bits.bitSize(Integer)"
isSigned _ = True
#if !defined(__GLASGOW_HASKELL__)
-- Crude implementation of bitwise operations on Integers: convert them
-- to finite lists of Ints (least significant first), zip and convert
-- back again.
-- posAnd requires at least one argument non-negative
-- posOr and posXOr require both arguments non-negative
posAnd, posOr, posXOr :: Integer -> Integer -> Integer
posAnd x y = fromInts $ zipWith (.&.) (toInts x) (toInts y)
posOr x y = fromInts $ longZipWith (.|.) (toInts x) (toInts y)
posXOr x y = fromInts $ longZipWith xor (toInts x) (toInts y)
longZipWith :: (a -> a -> a) -> [a] -> [a] -> [a]
longZipWith f xs [] = xs
longZipWith f [] ys = ys
longZipWith f (x:xs) (y:ys) = f x y:longZipWith f xs ys
toInts :: Integer -> [Int]
toInts n
| n == 0 = []
| otherwise = mkInt (n `mod` numInts):toInts (n `div` numInts)
where mkInt n | n > toInteger(maxBound::Int) = fromInteger (n-numInts)
| otherwise = fromInteger n
fromInts :: [Int] -> Integer
fromInts = foldr catInt 0
where catInt d n = (if d<0 then n+1 else n)*numInts + toInteger d
numInts = toInteger (maxBound::Int) - toInteger (minBound::Int) + 1
#endif /* !__GLASGOW_HASKELL__ */
{- Note [Constant folding for rotate]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The INLINE on the Int instance of rotate enables it to be constant
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
......@@ -26,9 +26,7 @@ module Data.Bool (
bool,
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Base
#endif
-- | Case analysis for the 'Bool' type.
-- @bool a b p@ evaluates to @a@ when @p@ is @False@, and evaluates to @b@
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
......@@ -52,7 +52,6 @@ module Data.Char
, readLitChar
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.Arr (Ix)
import GHC.Char
......@@ -62,7 +61,6 @@ import GHC.Read (Read, readLitChar, lexLitChar)
import GHC.Unicode