diff options
| author | Kavon Farvardin <kavon@farvard.in> | 2018-09-23 15:29:37 -0500 |
|---|---|---|
| committer | Kavon Farvardin <kavon@farvard.in> | 2018-09-23 15:29:37 -0500 |
| commit | 84c2ad99582391005b5e873198b15e9e9eb4f78d (patch) | |
| tree | caa8c2f2ec7e97fbb4977263c6817c9af5025cf4 /libraries/base/GHC | |
| parent | 8ddb47cfcf5776e9a3c55fd37947c8a95e00fa12 (diff) | |
| parent | e68b439fe5de61b9a2ca51af472185c62ccb8b46 (diff) | |
| download | haskell-wip/T13904.tar.gz | |
update to current master againwip/T13904
Diffstat (limited to 'libraries/base/GHC')
79 files changed, 3199 insertions, 1472 deletions
diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs index adfd602d9d..003d706f88 100644 --- a/libraries/base/GHC/Arr.hs +++ b/libraries/base/GHC/Arr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, RoleAnnotations #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -239,6 +240,15 @@ instance Ix Integer where inRange (m,n) i = m <= i && i <= n ---------------------------------------------------------------------- +-- | @since 4.8.0.0 +instance Ix Natural where + range (m,n) = [m..n] + inRange (m,n) i = m <= i && i <= n + unsafeIndex (m,_) i = fromIntegral (i-m) + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Natural" + +---------------------------------------------------------------------- -- | @since 2.01 instance Ix Bool where -- as derived {-# INLINE range #-} @@ -443,13 +453,13 @@ array :: Ix i -- of the array. These bounds are the lowest and -- highest indices in the array, in that order. -- For example, a one-origin vector of length - -- '10' has bounds '(1,10)', and a one-origin '10' - -- by '10' matrix has bounds '((1,1),(10,10))'. + -- @10@ has bounds @(1,10)@, and a one-origin @10@ + -- by @10@ matrix has bounds @((1,1),(10,10))@. -> [(i, e)] -- ^ a list of /associations/ of the form -- (/index/, /value/). Typically, this list will -- be expressed as a comprehension. An - -- association '(i, x)' defines the value of - -- the array at index 'i' to be 'x'. + -- association @(i, x)@ defines the value of + -- the array at index @i@ to be @x@. -> Array i e array (l,u) ies = let n = safeRangeSize (l,u) @@ -505,7 +515,11 @@ listArray (l,u) es = runST (ST $ \s1# -> -- | The value at the given index in an array. {-# INLINE (!) #-} (!) :: Ix i => Array i e -> i -> e -arr@(Array l u n _) ! i = unsafeAt arr $ safeIndex (l,u) n i +(!) arr@(Array l u n _) i = unsafeAt arr $ safeIndex (l,u) n i + +{-# INLINE (!#) #-} +(!#) :: Ix i => Array i e -> i -> (# e #) +(!#) arr@(Array l u n _) i = unsafeAt# arr $ safeIndex (l,u) n i {-# INLINE safeRangeSize #-} safeRangeSize :: Ix i => (i, i) -> Int @@ -550,6 +564,15 @@ unsafeAt :: Array i e -> Int -> e unsafeAt (Array _ _ _ arr#) (I# i#) = case indexArray# arr# i# of (# e #) -> e +-- | Look up an element in an array without forcing it +unsafeAt# :: Array i e -> Int -> (# e #) +unsafeAt# (Array _ _ _ arr#) (I# i#) = indexArray# arr# i# + +-- | A convenient version of unsafeAt# +unsafeAtA :: Applicative f + => Array i e -> Int -> f e +unsafeAtA ary i = case unsafeAt# ary i of (# e #) -> pure e + -- | The bounds with which an array was constructed. {-# INLINE bounds #-} bounds :: Array i e -> (i,i) @@ -569,7 +592,7 @@ indices (Array l u _ _) = range (l,u) {-# INLINE elems #-} elems :: Array i e -> [e] elems arr@(Array _ _ n _) = - [unsafeAt arr i | i <- [0 .. n - 1]] + [e | i <- [0 .. n - 1], e <- unsafeAtA arr i] -- | A right fold over the elements {-# INLINABLE foldrElems #-} @@ -577,7 +600,8 @@ foldrElems :: (a -> b -> b) -> b -> Array i a -> b foldrElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == n = b0 - | otherwise = f (unsafeAt arr i) (go (i+1)) + | (# e #) <- unsafeAt# arr i + = f e (go (i+1)) in go 0 -- | A left fold over the elements @@ -586,7 +610,8 @@ foldlElems :: (b -> a -> b) -> b -> Array i a -> b foldlElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == (-1) = b0 - | otherwise = f (go (i-1)) (unsafeAt arr i) + | (# e #) <- unsafeAt# arr i + = f (go (i-1)) e in go (n-1) -- | A strict right fold over the elements @@ -595,7 +620,8 @@ foldrElems' :: (a -> b -> b) -> b -> Array i a -> b foldrElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == (-1) = a - | otherwise = go (i-1) (f (unsafeAt arr i) $! a) + | (# e #) <- unsafeAt# arr i + = go (i-1) (f e $! a) in go (n-1) b0 -- | A strict left fold over the elements @@ -604,7 +630,8 @@ foldlElems' :: (b -> a -> b) -> b -> Array i a -> b foldlElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == n = a - | otherwise = go (i+1) (a `seq` f a (unsafeAt arr i)) + | (# e #) <- unsafeAt# arr i + = go (i+1) (a `seq` f a e) in go 0 b0 -- | A left fold over the elements with no starting value @@ -613,7 +640,8 @@ foldl1Elems :: (a -> a -> a) -> Array i a -> a foldl1Elems f = \ arr@(Array _ _ n _) -> let go i | i == 0 = unsafeAt arr 0 - | otherwise = f (go (i-1)) (unsafeAt arr i) + | (# e #) <- unsafeAt# arr i + = f (go (i-1)) e in if n == 0 then errorWithoutStackTrace "foldl1: empty Array" else go (n-1) @@ -623,7 +651,8 @@ foldr1Elems :: (a -> a -> a) -> Array i a -> a foldr1Elems f = \ arr@(Array _ _ n _) -> let go i | i == n-1 = unsafeAt arr i - | otherwise = f (unsafeAt arr i) (go (i + 1)) + | (# e #) <- unsafeAt# arr i + = f e (go (i + 1)) in if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0 @@ -631,11 +660,12 @@ foldr1Elems f = \ arr@(Array _ _ n _) -> {-# INLINE assocs #-} assocs :: Ix i => Array i e -> [(i, e)] assocs arr@(Array l u _ _) = - [(i, arr ! i) | i <- range (l,u)] + [(i, e) | i <- range (l,u), let !(# e #) = arr !# i] -- | The 'accumArray' function deals with repeated indices in the association -- list using an /accumulating function/ which combines the values of -- associations with the same index. +-- -- For example, given a list of values of some index type, @hist@ -- produces a histogram of the number of occurrences of each index within -- a specified range: @@ -643,10 +673,10 @@ assocs arr@(Array l u _ _) = -- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b -- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i] -- --- If the accumulating function is strict, then 'accumArray' is strict in --- the values, as well as the indices, in the association list. Thus, --- unlike ordinary arrays built with 'array', accumulated arrays should --- not in general be recursive. +-- @accumArray@ is strict in each result of applying the accumulating +-- function, although it is lazy in the initial value. Thus, unlike +-- arrays built with 'array', accumulated arrays should not in general +-- be recursive. {-# INLINE accumArray #-} accumArray :: Ix i => (e -> a -> e) -- ^ accumulating function @@ -667,7 +697,7 @@ unsafeAccumArray f initial b ies = unsafeAccumArray' f initial b (rangeSize b) i unsafeAccumArray' :: (e -> a -> e) -> e -> (i,i) -> Int -> [(Int, a)] -> Array i e unsafeAccumArray' f initial (l,u) n@(I# n#) ies = runST (ST $ \s1# -> case newArray# n# initial s1# of { (# s2#, marr# #) -> - foldr (adjust f marr#) (done l u n marr#) ies s2# }) + foldr (adjust' f marr#) (done l u n marr#) ies s2# }) {-# INLINE adjust #-} adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b @@ -678,6 +708,18 @@ adjust f marr# (I# i#, new) next case writeArray# marr# i# (f old new) s2# of s3# -> next s3# +{-# INLINE adjust' #-} +adjust' :: (e -> a -> e) + -> MutableArray# s e + -> (Int, a) + -> STRep s b -> STRep s b +adjust' f marr# (I# i#, new) next + = \s1# -> case readArray# marr# i# s1# of + (# s2#, old #) -> + let !combined = f old new + in next (writeArray# marr# i# combined s2#) + + -- | Constructs an array identical to the first argument except that it has -- been updated by the associations in the right argument. -- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then @@ -706,6 +748,8 @@ unsafeReplace arr ies = runST (do -- -- > accumArray f z b = accum f (array b [(i, z) | i <- range b]) -- +-- @accum@ is strict in all the results of applying the accumulation. +-- However, it is lazy in the initial values of the array. {-# INLINE accum #-} accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e accum f arr@(Array l u n _) ies = @@ -715,7 +759,7 @@ accum f arr@(Array l u n _) ies = unsafeAccum :: (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e unsafeAccum f arr ies = runST (do STArray l u n marr# <- thawSTArray arr - ST (foldr (adjust f marr#) (done l u n marr#) ies)) + ST (foldr (adjust' f marr#) (done l u n marr#) ies)) {-# INLINE [1] amap #-} -- See Note [amap] amap :: (a -> b) -> Array i a -> Array i b @@ -724,7 +768,8 @@ amap f arr@(Array l u n@(I# n#) _) = runST (ST $ \s1# -> (# s2#, marr# #) -> let go i s# | i == n = done l u n marr# s# - | otherwise = fill marr# (i, f (unsafeAt arr i)) (go (i+1)) s# + | (# e #) <- unsafeAt# arr i + = fill marr# (i, f e) (go (i+1)) s# in go 0 s2# ) {- Note [amap] diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index ffcd7ff2a0..1c927405ce 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -83,6 +83,9 @@ Other Prelude modules are much easier with fewer complex dependencies. , UnboxedTuples , ExistentialQuantification , RankNTypes + , KindSignatures + , PolyKinds + , DataKinds #-} -- -Wno-orphans is needed for things like: -- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 @@ -114,7 +117,8 @@ module GHC.Base module GHC.Types, module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, -- to avoid lots of people having to - module GHC.Err -- import it explicitly + module GHC.Err, -- import it explicitly + module GHC.Maybe ) where @@ -124,10 +128,20 @@ import GHC.CString import GHC.Magic import GHC.Prim import GHC.Err +import GHC.Maybe import {-# SOURCE #-} GHC.IO (failIO,mplusIO) -import GHC.Tuple () -- Note [Depend on GHC.Tuple] -import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Tuple () -- Note [Depend on GHC.Tuple] +import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Natural () -- Note [Depend on GHC.Natural] + +-- for 'class Semigroup' +import {-# SOURCE #-} GHC.Real (Integral) +import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault + , stimesMaybe + , stimesList + , stimesIdempotentMonoid + ) infixr 9 . infixr 5 ++ @@ -171,6 +185,10 @@ Similarly, tuple syntax (or ()) creates an implicit dependency on GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on GHC.Integer] --- to explain this to the build system. We make GHC.Base depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude. + +Note [Depend on GHC.Natural] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similar to GHC.Integer. -} #if 0 @@ -191,29 +209,53 @@ build = errorWithoutStackTrace "urk" foldr = errorWithoutStackTrace "urk" #endif --- | The 'Maybe' type encapsulates an optional value. A value of type --- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), --- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to --- deal with errors or exceptional cases without resorting to drastic --- measures such as 'error'. +infixr 6 <> + +-- | The class of semigroups (types with an associative binary operation). +-- +-- Instances should satisfy the associativity law: -- --- The 'Maybe' type is also a monad. It is a simple kind of error --- monad, where all errors are represented by 'Nothing'. A richer --- error monad can be built using the 'Data.Either.Either' type. +-- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ -- -data Maybe a = Nothing | Just a - deriving (Eq, Ord) +-- @since 4.9.0.0 +class Semigroup a where + -- | An associative operation. + (<>) :: a -> a -> a + + -- | Reduce a non-empty list with '<>' + -- + -- The default definition should be sufficient, but this can be + -- overridden for efficiency. + -- + sconcat :: NonEmpty a -> a + sconcat (a :| as) = go a as where + go b (c:cs) = b <> go c cs + go b [] = b + + -- | Repeat a value @n@ times. + -- + -- Given that this works on a 'Semigroup' it is allowed to fail if + -- you request 0 or fewer repetitions, and the default definition + -- will do so. + -- + -- By making this a member of the class, idempotent semigroups + -- and monoids can upgrade this to execute in /O(1)/ by + -- picking @stimes = 'Data.Semigroup.stimesIdempotent'@ or @stimes = + -- 'stimesIdempotentMonoid'@ respectively. + stimes :: Integral b => b -> a -> a + stimes = stimesDefault + -- | The class of monoids (types with an associative binary operation that -- has an identity). Instances should satisfy the following laws: -- --- * @mappend mempty x = x@ +-- * @x '<>' 'mempty' = x@ -- --- * @mappend x mempty = x@ +-- * @'mempty' '<>' x = x@ -- --- * @mappend x (mappend y z) = mappend (mappend x y) z@ +-- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law) -- --- * @mconcat = 'foldr' mappend mempty@ +-- * @'mconcat' = 'foldr' ('<>') 'mempty'@ -- -- The method names refer to the monoid of lists under concatenation, -- but there are many other instances. @@ -221,28 +263,40 @@ data Maybe a = Nothing | Just a -- Some types can be viewed as a monoid in more than one way, -- e.g. both addition and multiplication on numbers. -- In such cases we often define @newtype@s and make those instances --- of 'Monoid', e.g. 'Sum' and 'Product'. - -class Monoid a where +-- of 'Monoid', e.g. 'Data.Semigroup.Sum' and 'Data.Semigroup.Product'. +-- +-- __NOTE__: 'Semigroup' is a superclass of 'Monoid' since /base-4.11.0.0/. +class Semigroup a => Monoid a where + -- | Identity of 'mappend' mempty :: a - -- ^ Identity of 'mappend' + + -- | An associative operation + -- + -- __NOTE__: This method is redundant and has the default + -- implementation @'mappend' = ('<>')@ since /base-4.11.0.0/. mappend :: a -> a -> a - -- ^ An associative operation - mconcat :: [a] -> a + mappend = (<>) + {-# INLINE mappend #-} - -- ^ Fold a list using the monoid. + -- | Fold a list using the monoid. + -- -- For most types, the default definition for 'mconcat' will be -- used, but the function is included in the class definition so -- that an optimized version can be provided for specific types. - + mconcat :: [a] -> a mconcat = foldr mappend mempty +-- | @since 4.9.0.0 +instance Semigroup [a] where + (<>) = (++) + {-# INLINE (<>) #-} + + stimes = stimesList + -- | @since 2.01 instance Monoid [a] where {-# INLINE mempty #-} mempty = [] - {-# INLINE mappend #-} - mappend = (++) {-# INLINE mconcat #-} mconcat xss = [x | xs <- xss, x <- xs] -- See Note: [List comprehensions and inlining] @@ -266,66 +320,104 @@ needed to make foldr/build forms efficient are turned off, we'll get reasonably efficient translations anyway. -} +-- | @since 4.9.0.0 +instance Semigroup (NonEmpty a) where + (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs) + +-- | @since 4.9.0.0 +instance Semigroup b => Semigroup (a -> b) where + f <> g = \x -> f x <> g x + stimes n f e = stimes n (f e) + -- | @since 2.01 instance Monoid b => Monoid (a -> b) where mempty _ = mempty - mappend f g x = f x `mappend` g x + +-- | @since 4.9.0.0 +instance Semigroup () where + _ <> _ = () + sconcat _ = () + stimes _ _ = () -- | @since 2.01 instance Monoid () where -- Should it be strict? mempty = () - _ `mappend` _ = () mconcat _ = () +-- | @since 4.9.0.0 +instance (Semigroup a, Semigroup b) => Semigroup (a, b) where + (a,b) <> (a',b') = (a<>a',b<>b') + stimes n (a,b) = (stimes n a, stimes n b) + -- | @since 2.01 instance (Monoid a, Monoid b) => Monoid (a,b) where mempty = (mempty, mempty) - (a1,b1) `mappend` (a2,b2) = - (a1 `mappend` a2, b1 `mappend` b2) + +-- | @since 4.9.0.0 +instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where + (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') + stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) -- | @since 2.01 instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where mempty = (mempty, mempty, mempty) - (a1,b1,c1) `mappend` (a2,b2,c2) = - (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2) + +-- | @since 4.9.0.0 +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) + => Semigroup (a, b, c, d) where + (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') + stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) -- | @since 2.01 instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where mempty = (mempty, mempty, mempty, mempty) - (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) = - (a1 `mappend` a2, b1 `mappend` b2, - c1 `mappend` c2, d1 `mappend` d2) + +-- | @since 4.9.0.0 +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) + => Semigroup (a, b, c, d, e) where + (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') + stimes n (a,b,c,d,e) = + (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) -- | @since 2.01 instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => Monoid (a,b,c,d,e) where mempty = (mempty, mempty, mempty, mempty, mempty) - (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) = - (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, - d1 `mappend` d2, e1 `mappend` e2) + + +-- | @since 4.9.0.0 +instance Semigroup Ordering where + LT <> _ = LT + EQ <> y = y + GT <> _ = GT + + stimes = stimesIdempotentMonoid -- lexicographical ordering -- | @since 2.01 instance Monoid Ordering where - mempty = EQ - LT `mappend` _ = LT - EQ `mappend` y = y - GT `mappend` _ = GT + mempty = EQ + +-- | @since 4.9.0.0 +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> b = b + a <> Nothing = a + Just a <> Just b = Just (a <> b) + + stimes = stimesMaybe -- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to -- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be -- turned into a monoid simply by adjoining an element @e@ not in @S@ --- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since --- there used to be no \"Semigroup\" typeclass providing just 'mappend', --- we use 'Monoid' instead. +-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" +-- +-- /Since 4.11.0/: constraint on inner @a@ value generalised from +-- 'Monoid' to 'Semigroup'. -- -- @since 2.01 -instance Monoid a => Monoid (Maybe a) where - mempty = Nothing - Nothing `mappend` m = m - m `mappend` Nothing = m - Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) +instance Semigroup a => Monoid (Maybe a) where + mempty = Nothing -- | For tuples, the 'Monoid' constraint on @a@ determines -- how the first values merge. @@ -337,26 +429,27 @@ instance Monoid a => Monoid (Maybe a) where -- @since 2.01 instance Monoid a => Applicative ((,) a) where pure x = (mempty, x) - (u, f) <*> (v, x) = (u `mappend` v, f x) - liftA2 f (u, x) (v, y) = (u `mappend` v, f x y) + (u, f) <*> (v, x) = (u <> v, f x) + liftA2 f (u, x) (v, y) = (u <> v, f x y) -- | @since 4.9.0.0 instance Monoid a => Monad ((,) a) where - (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b) + (u, a) >>= k = case k a of (v, b) -> (u <> v, b) + +-- | @since 4.10.0.0 +instance Semigroup a => Semigroup (IO a) where + (<>) = liftA2 (<>) -- | @since 4.9.0.0 instance Monoid a => Monoid (IO a) where mempty = pure mempty - mappend = liftA2 mappend -{- | The 'Functor' class is used for types that can be mapped over. -Instances of 'Functor' should satisfy the following laws: +{- | A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@ +lets you apply any function from @(a -> b)@ to turn an @f a@ into an @f b@, preserving the +structure of @f@. Furthermore @f@ needs to adhere to the following laws: -> fmap id == id -> fmap (f . g) == fmap f . fmap g - -The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' -satisfy these laws. +> fmap id == id +> fmap (f . g) == fmap f . fmap g -} class Functor f where @@ -379,7 +472,8 @@ class Functor f where -- the same as their default definitions: -- -- @('<*>') = 'liftA2' 'id'@ --- @'liftA2' f x y = f '<$>' x '<*>' y@ +-- +-- @'liftA2' f x y = f 'Prelude.<$>' x '<*>' y@ -- -- Further, any definition must satisfy the following: -- @@ -427,6 +521,8 @@ class Functor f where -- -- * @('<*>') = 'ap'@ -- +-- * @('*>') = ('>>')@ +-- -- (which implies that 'pure' and '<*>' satisfy the applicative functor laws). class Functor f => Applicative f where @@ -494,6 +590,33 @@ liftA3 f a b c = liftA2 f a b <*> c -- | The 'join' function is the conventional monad join operator. It -- is used to remove one level of monadic structure, projecting its -- bound argument into the outer level. +-- +-- ==== __Examples__ +-- +-- A common use of 'join' is to run an 'IO' computation returned from +-- an 'GHC.Conc.STM' transaction, since 'GHC.Conc.STM' transactions +-- can't perform 'IO' directly. Recall that +-- +-- @ +-- 'GHC.Conc.atomically' :: STM a -> IO a +-- @ +-- +-- is used to run 'GHC.Conc.STM' transactions atomically. So, by +-- specializing the types of 'GHC.Conc.atomically' and 'join' to +-- +-- @ +-- 'GHC.Conc.atomically' :: STM (IO b) -> IO (IO b) +-- 'join' :: IO (IO b) -> IO b +-- @ +-- +-- we can compose them as +-- +-- @ +-- 'join' . 'GHC.Conc.atomically' :: STM (IO b) -> IO b +-- @ +-- +-- to run an 'GHC.Conc.STM' transaction and the 'IO' action it +-- returns. join :: (Monad m) => m (m a) -> m a join x = x >>= id @@ -546,8 +669,8 @@ class Applicative m => Monad m where -- failure in a @do@ expression. -- -- As part of the MonadFail proposal (MFP), this function is moved - -- to its own class 'MonadFail' (see "Control.Monad.Fail" for more - -- details). The definition here will be removed in a future + -- to its own class 'Control.Monad.MonadFail' (see "Control.Monad.Fail" for + -- more details). The definition here will be removed in a future -- release. fail :: String -> m a fail s = errorWithoutStackTrace s @@ -629,8 +752,8 @@ liftM f m1 = do { x1 <- m1; return (f x1) } -- | Promote a function to a monad, scanning the monadic arguments from -- left to right. For example, -- --- > liftM2 (+) [0,1] [0,2] = [0,2,1,3] --- > liftM2 (+) (Just 1) Nothing = Nothing +-- > liftM2 (+) [0,1] [0,2] = [0,2,1,3] +-- > liftM2 (+) (Just 1) Nothing = Nothing -- liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } @@ -671,11 +794,11 @@ liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; {- | In many situations, the 'liftM' operations can be replaced by uses of 'ap', which promotes function application. -> return f `ap` x1 `ap` ... `ap` xn +> return f `ap` x1 `ap` ... `ap` xn is equivalent to -> liftMn f x1 x2 ... xn +> liftMn f x1 x2 ... xn -} @@ -744,9 +867,9 @@ infixl 3 <|> -- If defined, 'some' and 'many' should be the least solutions -- of the equations: -- --- * @some v = (:) '<$>' v '<*>' many v@ +-- * @'some' v = (:) 'Prelude.<$>' v '<*>' 'many' v@ -- --- * @many v = some v '<|>' 'pure' []@ +-- * @'many' v = 'some' v '<|>' 'pure' []@ class Applicative f => Alternative f where -- | The identity of '<|>' empty :: f a @@ -779,21 +902,61 @@ instance Alternative Maybe where -- | Monads that also support choice and failure. class (Alternative m, Monad m) => MonadPlus m where - -- | the identity of 'mplus'. It should also satisfy the equations + -- | The identity of 'mplus'. It should also satisfy the equations -- -- > mzero >>= f = mzero -- > v >> mzero = mzero -- + -- The default definition is + -- + -- @ + -- mzero = 'empty' + -- @ mzero :: m a mzero = empty - -- | an associative operation + -- | An associative operation. The default definition is + -- + -- @ + -- mplus = ('<|>') + -- @ mplus :: m a -> m a -> m a mplus = (<|>) -- | @since 2.01 instance MonadPlus Maybe +--------------------------------------------- +-- The non-empty list type + +infixr 5 :| + +-- | Non-empty (and non-strict) list type. +-- +-- @since 4.9.0.0 +data NonEmpty a = a :| [a] + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + ) + +-- | @since 4.9.0.0 +instance Functor NonEmpty where + fmap f ~(a :| as) = f a :| fmap f as + b <$ ~(_ :| as) = b :| (b <$ as) + +-- | @since 4.9.0.0 +instance Applicative NonEmpty where + pure a = a :| [] + (<*>) = ap + liftA2 = liftM2 + +-- | @since 4.9.0.0 +instance Monad NonEmpty where + ~(a :| as) >>= f = b :| (bs ++ bs') + where b :| bs = f a + bs' = as >>= toList . f + toList ~(c :| cs) = c : cs + ---------------------------------------------- -- The list type @@ -1082,6 +1245,8 @@ maxInt = I# 0x7FFFFFFFFFFFFFFF# ---------------------------------------------- -- | Identity function. +-- +-- > id x = x id :: a -> a id x = x @@ -1089,8 +1254,8 @@ id x = x -- The compiler may rewrite it to @('assertError' line)@. -- | If the first argument evaluates to 'True', then the result is the --- second argument. Otherwise an 'AssertionFailed' exception is raised, --- containing a 'String' with the source file and line number of the +-- second argument. Otherwise an 'Control.Exception.AssertionFailed' exception +-- is raised, containing a 'String' with the source file and line number of the -- call to 'assert'. -- -- Assertions can normally be turned on or off with a compiler flag @@ -1115,7 +1280,8 @@ breakpointCond _ r = r data Opaque = forall a. O a -- | @const x@ is a unary function which evaluates to @x@ for all inputs. -- --- For instance, +-- >>> const 42 "hello" +-- 42 -- -- >>> map (const 42) [0..3] -- [42,42,42,42] @@ -1130,6 +1296,9 @@ const x _ = x (.) f g = \x -> f (g x) -- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@. +-- +-- >>> flip (++) "hello" "world" +-- "worldhello" flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x @@ -1138,20 +1307,24 @@ flip f x y = f y x -- low, right-associative binding precedence, so it sometimes allows -- parentheses to be omitted; for example: -- --- > f $ g $ h x = f (g (h x)) +-- > f $ g $ h x = f (g (h x)) -- -- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@, -- or @'Data.List.zipWith' ('$') fs xs@. +-- +-- Note that @($)@ is levity-polymorphic in its result type, so that +-- foo $ True where foo :: Bool -> Int# +-- is well-typed {-# INLINE ($) #-} -($) :: (a -> b) -> a -> b -f $ x = f x +($) :: forall r a (b :: TYPE r). (a -> b) -> a -> b +f $ x = f x -- | Strict (call-by-value) application operator. It takes a function and an -- argument, evaluates the argument to weak head normal form (WHNF), then calls -- the function with that value. -($!) :: (a -> b) -> a -> b -f $! x = let !vx = x in f vx -- see #2273 +($!) :: forall r a (b :: TYPE r). (a -> b) -> a -> b +f $! x = let !vx = x in f vx -- see #2273 -- | @'until' p f@ yields the result of applying @f@ until @p@ holds. until :: (a -> Bool) -> (a -> a) -> a -> a @@ -1213,7 +1386,7 @@ unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) unIO (IO a) = a {- | -Returns the 'tag' of a constructor application; this function is used +Returns the tag of a constructor application; this function is used by the deriving code for Eq, Ord and Enum. The primitive dataToTag# requires an evaluated constructor application diff --git a/libraries/base/GHC/Base.hs-boot b/libraries/base/GHC/Base.hs-boot new file mode 100644 index 0000000000..64e6365525 --- /dev/null +++ b/libraries/base/GHC/Base.hs-boot @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Base (Maybe, Semigroup, Monoid) where + +import GHC.Maybe (Maybe) +import GHC.Types () + +class Semigroup a +class Monoid a diff --git a/libraries/base/GHC/ByteOrder.hs b/libraries/base/GHC/ByteOrder.hs index eecc56c9ad..8a42e8df71 100644 --- a/libraries/base/GHC/ByteOrder.hs +++ b/libraries/base/GHC/ByteOrder.hs @@ -12,6 +12,7 @@ -- -- Target byte ordering. -- +-- @since 4.11.0.0 ----------------------------------------------------------------------------- module GHC.ByteOrder where @@ -20,7 +21,13 @@ module GHC.ByteOrder where data ByteOrder = BigEndian -- ^ most-significant-byte occurs in lowest address. | LittleEndian -- ^ least-significant-byte occurs in lowest address. - deriving (Eq, Ord, Bounded, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.11.0.0 + , Ord -- ^ @since 4.11.0.0 + , Bounded -- ^ @since 4.11.0.0 + , Enum -- ^ @since 4.11.0.0 + , Read -- ^ @since 4.11.0.0 + , Show -- ^ @since 4.11.0.0 + ) -- | The byte ordering of the target machine. targetByteOrder :: ByteOrder diff --git a/libraries/base/GHC/Event/Clock.hsc b/libraries/base/GHC/Clock.hsc index 7f98a03cd2..6339dc0a52 100644 --- a/libraries/base/GHC/Event/Clock.hsc +++ b/libraries/base/GHC/Clock.hsc @@ -1,7 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -module GHC.Event.Clock +module GHC.Clock ( getMonotonicTime , getMonotonicTimeNSec ) where @@ -11,11 +11,15 @@ import GHC.Real import Data.Word -- | Return monotonic time in seconds, since some unspecified starting point +-- +-- @since 4.11.0.0 getMonotonicTime :: IO Double getMonotonicTime = do w <- getMonotonicTimeNSec return (fromIntegral w / 1000000000) -- | Return monotonic time in nanoseconds, since some unspecified starting point +-- +-- @since 4.11.0.0 foreign import ccall unsafe "getMonotonicNSec" getMonotonicTimeNSec :: IO Word64 diff --git a/libraries/base/GHC/Conc.hs b/libraries/base/GHC/Conc.hs index 8c5c1536d9..15397422a5 100644 --- a/libraries/base/GHC/Conc.hs +++ b/libraries/base/GHC/Conc.hs @@ -74,8 +74,6 @@ module GHC.Conc , orElse , throwSTM , catchSTM - , alwaysSucceeds - , always , TVar(..) , newTVar , newTVarIO diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs index eb0bffe8b4..7b87adc7ea 100644 --- a/libraries/base/GHC/Conc/IO.hs +++ b/libraries/base/GHC/Conc/IO.hs @@ -85,7 +85,7 @@ ioManagerCapabilitiesChanged = return () -- | Block the current thread until data is available to read on the -- given file descriptor (GHC only). -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitRead', use 'closeFdWith'. threadWaitRead :: Fd -> IO () @@ -101,7 +101,7 @@ threadWaitRead fd -- | Block the current thread until data can be written to the -- given file descriptor (GHC only). -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitWrite', use 'closeFdWith'. threadWaitWrite :: Fd -> IO () @@ -188,8 +188,9 @@ threadDelay time case delay# time# s of { s' -> (# s', () #) }} --- | Set the value of returned TVar to True after a given number of --- microseconds. The caveats associated with threadDelay also apply. +-- | Switch the value of returned 'TVar' from initial value 'False' to 'True' +-- after a given number of microseconds. The caveats associated with +-- 'threadDelay' also apply. -- registerDelay :: Int -> IO (TVar Bool) registerDelay usecs diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index f9514d6681..6751de72a8 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -74,8 +74,6 @@ module GHC.Conc.Sync , orElse , throwSTM , catchSTM - , alwaysSucceeds - , always , TVar(..) , newTVar , newTVarIO @@ -105,6 +103,7 @@ import Data.Maybe import GHC.Base import {-# SOURCE #-} GHC.IO.Handle ( hFlush ) import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout ) +import GHC.Int import GHC.IO import GHC.IO.Encoding.UTF8 import GHC.IO.Exception @@ -194,18 +193,16 @@ instance Ord ThreadId where -- -- @since 4.8.0.0 setAllocationCounter :: Int64 -> IO () -setAllocationCounter i = do - ThreadId t <- myThreadId - rts_setThreadAllocationCounter t i +setAllocationCounter (I64# i) = IO $ \s -> + case setThreadAllocationCounter# i s of s' -> (# s', () #) -- | Return the current value of the allocation counter for the -- current thread. -- -- @since 4.8.0.0 getAllocationCounter :: IO Int64 -getAllocationCounter = do - ThreadId t <- myThreadId - rts_getThreadAllocationCounter t +getAllocationCounter = IO $ \s -> + case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #) -- | Enables the allocation counter to be treated as a limit for the -- current thread. When the allocation limit is enabled, if the @@ -242,16 +239,6 @@ disableAllocationLimit = do ThreadId t <- myThreadId rts_disableThreadAllocationLimit t --- We cannot do these operations safely on another thread, because on --- a 32-bit machine we cannot do atomic operations on a 64-bit value. --- Therefore, we only expose APIs that allow getting and setting the --- limit of the current thread. -foreign import ccall unsafe "rts_setThreadAllocationCounter" - rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO () - -foreign import ccall unsafe "rts_getThreadAllocationCounter" - rts_getThreadAllocationCounter :: ThreadId# -> IO Int64 - foreign import ccall unsafe "rts_enableThreadAllocationLimit" rts_enableThreadAllocationLimit :: ThreadId# -> IO () @@ -487,7 +474,7 @@ myThreadId = IO $ \s -> case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #) --- |The 'yield' action allows (forces, in a co-operative multitasking +-- | The 'yield' action allows (forces, in a co-operative multitasking -- implementation) a context-switch to any other currently runnable -- threads (if any), and is occasionally useful when implementing -- concurrency abstractions. @@ -556,9 +543,12 @@ data BlockReason -- ^currently in a foreign call | BlockedOnOther -- ^blocked on some other resource. Without @-threaded@, - -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ - -- they show up as 'BlockedOnMVar'. - deriving (Eq,Ord,Show) + -- I\/O and 'Control.Concurrent.threadDelay' show up as + -- 'BlockedOnOther', with @-threaded@ they show up as 'BlockedOnMVar'. + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | The current status of a thread data ThreadStatus @@ -570,7 +560,10 @@ data ThreadStatus -- ^the thread is blocked on some resource | ThreadDied -- ^the thread received an uncaught exception - deriving (Eq,Ord,Show) + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) threadStatus :: ThreadId -> IO ThreadStatus threadStatus (ThreadId t) = IO $ \s -> @@ -591,7 +584,7 @@ threadStatus (ThreadId t) = IO $ \s -> mk_stat 17 = ThreadDied mk_stat _ = ThreadBlocked BlockedOnOther --- | returns the number of the capability on which the thread is currently +-- | Returns the number of the capability on which the thread is currently -- running, and a boolean indicating whether the thread is locked to -- that capability or not. A thread is locked to a capability if it -- was created with @forkOn@. @@ -602,7 +595,7 @@ threadCapability (ThreadId t) = IO $ \s -> case threadStatus# t s of (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #) --- | make a weak pointer to a 'ThreadId'. It can be important to do +-- | 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 @@ -714,32 +707,45 @@ instance MonadPlus STM unsafeIOToSTM :: IO a -> STM a unsafeIOToSTM (IO m) = STM m --- |Perform a series of STM actions atomically. +-- | Perform a series of STM actions atomically. -- --- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'. --- Any attempt to do so will result in a runtime error. (Reason: allowing --- this would effectively allow a transaction inside a transaction, depending --- on exactly when the thunk is evaluated.) +-- Using 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO' +-- subverts some of guarantees that STM provides. It makes it possible to +-- run a transaction inside of another transaction, depending on when the +-- thunk is evaluated. If a nested transaction is attempted, an exception +-- is thrown by the runtime. It is possible to safely use 'atomically' inside +-- 'unsafePerformIO' or 'unsafeInterleaveIO', but the typechecker does not +-- rule out programs that may attempt nested transactions, meaning that +-- the programmer must take special care to prevent these. -- --- However, see 'newTVarIO', which can be called inside 'unsafePerformIO', --- and which allows top-level TVars to be allocated. +-- However, there are functions for creating transactional variables that +-- can always be safely called in 'unsafePerformIO'. See: 'newTVarIO', +-- 'Control.Concurrent.STM.TChan.newTChanIO', +-- 'Control.Concurrent.STM.TChan.newBroadcastTChanIO', +-- 'Control.Concurrent.STM.TQueue.newTQueueIO', +-- 'Control.Concurrent.STM.TBQueue.newTBQueueIO', and +-- 'Control.Concurrent.STM.TMVar.newTMVarIO'. +-- +-- Using 'unsafePerformIO' inside of 'atomically' is also dangerous but for +-- different reasons. See 'unsafeIOToSTM' for more on this. atomically :: STM a -> IO a atomically (STM m) = IO (\s -> (atomically# m) s ) --- |Retry execution of the current memory transaction because it has seen --- values in TVars which mean that it should not continue (e.g. the TVars +-- | Retry execution of the current memory transaction because it has seen +-- values in 'TVar's which mean that it should not continue (e.g. the 'TVar's -- represent a shared buffer that is now empty). The implementation may --- block the thread until one of the TVars that it has read from has been +-- block the thread until one of the 'TVar's that it has read from has been -- updated. (GHC only) retry :: STM a retry = STM $ \s# -> retry# s# --- |Compose two alternative STM actions (GHC only). If the first action --- completes without retrying then it forms the result of the orElse. --- Otherwise, if the first action retries, then the second action is --- tried in its place. If both actions retry then the orElse as a --- whole retries. +-- | Compose two alternative STM actions (GHC only). +-- +-- If the first action completes without retrying then it forms the result of +-- the 'orElse'. Otherwise, if the first action retries, then the second action +-- is tried in its place. If both actions retry then the 'orElse' as a whole +-- retries. orElse :: STM a -> STM a -> STM a orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s @@ -772,30 +778,6 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler' Just e' -> unSTM (handler e') Nothing -> raiseIO# e --- | Low-level primitive on which always and alwaysSucceeds are built. --- checkInv differs form these in that (i) the invariant is not --- checked when checkInv is called, only at the end of this and --- subsequent transcations, (ii) the invariant failure is indicated --- by raising an exception. -checkInv :: STM a -> STM () -checkInv (STM m) = STM (\s -> case (check# m) s of s' -> (# s', () #)) - --- | alwaysSucceeds adds a new invariant that must be true when passed --- to alwaysSucceeds, at the end of the current transaction, and at --- the end of every subsequent transaction. If it fails at any --- of those points then the transaction violating it is aborted --- and the exception raised by the invariant is propagated. -alwaysSucceeds :: STM a -> STM () -alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) - checkInv i - --- | always is a variant of alwaysSucceeds in which the invariant is --- expressed as an STM Bool action that must return True. Returning --- False or raising an exception are both treated as invariant failures. -always :: STM Bool -> STM () -always i = alwaysSucceeds ( do v <- i - if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) ) - -- |Shared memory locations that support atomic memory transactions. data TVar a = TVar (TVar# RealWorld a) @@ -803,13 +785,13 @@ data TVar a = TVar (TVar# RealWorld a) instance Eq (TVar a) where (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#) --- |Create a new TVar holding a value supplied +-- | Create a new 'TVar' holding a value supplied newTVar :: a -> STM (TVar a) newTVar val = STM $ \s1# -> case newTVar# val s1# of (# s2#, tvar# #) -> (# s2#, TVar tvar# #) --- |@IO@ version of 'newTVar'. This is useful for creating top-level +-- | @IO@ version of 'newTVar'. This is useful for creating top-level -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. @@ -818,7 +800,7 @@ newTVarIO val = IO $ \s1# -> case newTVar# val s1# of (# s2#, tvar# #) -> (# s2#, TVar tvar# #) --- |Return the current value stored in a TVar. +-- | Return the current value stored in a 'TVar'. -- This is equivalent to -- -- > readTVarIO = atomically . readTVar @@ -828,11 +810,11 @@ newTVarIO val = IO $ \s1# -> readTVarIO :: TVar a -> IO a readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s# --- |Return the current value stored in a TVar +-- |Return the current value stored in a 'TVar'. readTVar :: TVar a -> STM a readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s# --- |Write the supplied value into a TVar +-- |Write the supplied value into a 'TVar'. writeTVar :: TVar a -> a -> STM () writeTVar (TVar tvar#) val = STM $ \s1# -> case writeTVar# tvar# val s1# of @@ -842,6 +824,8 @@ writeTVar (TVar tvar#) val = STM $ \s1# -> -- MVar utilities ----------------------------------------------------------------------------- +-- | Provide an 'IO' action with the current value of an 'MVar'. The 'MVar' +-- will be empty for the duration that the action is running. withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io = mask $ \restore -> do @@ -851,6 +835,7 @@ withMVar m io = putMVar m a return b +-- | Modify the value of an 'MVar'. modifyMVar_ :: MVar a -> (a -> IO a) -> IO () modifyMVar_ m io = mask $ \restore -> do diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs index 6b87b06fe7..ed5e0452a0 100644 --- a/libraries/base/GHC/Conc/Windows.hs +++ b/libraries/base/GHC/Conc/Windows.hs @@ -131,7 +131,7 @@ waitForDelayEvent :: Int -> IO () waitForDelayEvent usecs = do m <- newEmptyMVar target <- calculateTarget usecs - atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ())) + _ <- atomicModifyIORef'_ pendingDelays (\xs -> Delay target m : xs) prodServiceThread takeMVar m @@ -140,7 +140,7 @@ waitForDelayEventSTM :: Int -> IO (TVar Bool) waitForDelayEventSTM usecs = do t <- atomically $ newTVar False target <- calculateTarget usecs - atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ())) + _ <- atomicModifyIORef'_ pendingDelays (\xs -> DelaySTM target t : xs) prodServiceThread return t @@ -219,10 +219,10 @@ foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore" prodServiceThread :: IO () prodServiceThread = do - -- NB. use atomicModifyIORef here, otherwise there are race + -- NB. use atomicSwapIORef here, otherwise there are race -- conditions in which prodding is left at True but the server is -- blocked in select(). - was_set <- atomicModifyIORef prodding $ \b -> (True,b) + was_set <- atomicSwapIORef prodding True when (not was_set) wakeupIOManager -- ---------------------------------------------------------------------------- @@ -239,7 +239,7 @@ service_loop :: HANDLE -- read end of pipe service_loop wakeup old_delays = do -- pick up new delay requests - new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) + new_delays <- atomicSwapIORef pendingDelays [] let delays = foldr insertDelay old_delays new_delays now <- getMonotonicUSec @@ -262,8 +262,7 @@ service_loop wakeup old_delays = do service_cont :: HANDLE -> [DelayReq] -> IO () service_cont wakeup delays = do - r <- atomicModifyIORef prodding (\_ -> (False,False)) - r `seq` return () -- avoid space leak + _ <- atomicSwapIORef prodding False service_loop wakeup delays -- must agree with rts/win32/ThrIOManager.c @@ -278,7 +277,12 @@ data ConsoleEvent -- these are sent to Services only. | Logoff | Shutdown - deriving (Eq, Ord, Enum, Show, Read) + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Enum -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + ) start_console_handler :: Word32 -> IO () start_console_handler r = diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs index feb45854d2..af74f7c984 100644 --- a/libraries/base/GHC/Enum.hs +++ b/libraries/base/GHC/Enum.hs @@ -92,13 +92,51 @@ class Enum a where -- applied to a value that is too large to fit in an 'Int'. fromEnum :: a -> Int - -- | Used in Haskell's translation of @[n..]@. + -- | Used in Haskell's translation of @[n..]@ with @[n..] = enumFrom n@, + -- a possible implementation being @enumFrom n = n : enumFrom (succ n)@. + -- For example: + -- + -- * @enumFrom 4 :: [Integer] = [4,5,6,7,...]@ + -- * @enumFrom 6 :: [Int] = [6,7,8,9,...,maxBound :: Int]@ enumFrom :: a -> [a] - -- | Used in Haskell's translation of @[n,n'..]@. + -- | Used in Haskell's translation of @[n,n'..]@ + -- with @[n,n'..] = enumFromThen n n'@, a possible implementation being + -- @enumFromThen n n' = n : n' : worker (f x) (f x n')@, + -- @worker s v = v : worker s (s v)@, @x = fromEnum n' - fromEnum n@ and + -- @f n y + -- | n > 0 = f (n - 1) (succ y) + -- | n < 0 = f (n + 1) (pred y) + -- | otherwise = y@ + -- For example: + -- + -- * @enumFromThen 4 6 :: [Integer] = [4,6,8,10...]@ + -- * @enumFromThen 6 2 :: [Int] = [6,2,-2,-6,...,minBound :: Int]@ enumFromThen :: a -> a -> [a] - -- | Used in Haskell's translation of @[n..m]@. + -- | Used in Haskell's translation of @[n..m]@ with + -- @[n..m] = enumFromTo n m@, a possible implementation being + -- @enumFromTo n m + -- | n <= m = n : enumFromTo (succ n) m + -- | otherwise = []@. + -- For example: + -- + -- * @enumFromTo 6 10 :: [Int] = [6,7,8,9,10]@ + -- * @enumFromTo 42 1 :: [Integer] = []@ enumFromTo :: a -> a -> [a] - -- | Used in Haskell's translation of @[n,n'..m]@. + -- | Used in Haskell's translation of @[n,n'..m]@ with + -- @[n,n'..m] = enumFromThenTo n n' m@, a possible implementation + -- being @enumFromThenTo n n' m = worker (f x) (c x) n m@, + -- @x = fromEnum n' - fromEnum n@, @c x = bool (>=) (<=) (x > 0)@ + -- @f n y + -- | n > 0 = f (n - 1) (succ y) + -- | n < 0 = f (n + 1) (pred y) + -- | otherwise = y@ and + -- @worker s c v m + -- | c v m = v : worker s c (s v) m + -- | otherwise = []@ + -- For example: + -- + -- * @enumFromThenTo 4 2 -6 :: [Integer] = [4,2,0,-2,-4,-6]@ + -- * @enumFromThenTo 6 8 2 :: [Int] = []@ enumFromThenTo :: a -> a -> a -> [a] succ = toEnum . (+ 1) . fromEnum @@ -877,6 +915,79 @@ dn_list x0 delta lim = go (x0 :: Integer) go x | x < lim = [] | otherwise = x : go (x+delta) +------------------------------------------------------------------------ +-- Natural +------------------------------------------------------------------------ + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Enum Natural where + succ n = n `plusNatural` wordToNaturalBase 1## + pred n = n `minusNatural` wordToNaturalBase 1## + + toEnum = intToNatural + + fromEnum (NatS# w) + | i >= 0 = i + | otherwise = errorWithoutStackTrace "fromEnum: out of Int range" + where + i = I# (word2Int# w) + fromEnum n = fromEnum (naturalToInteger n) + + enumFrom x = enumDeltaNatural x (wordToNaturalBase 1##) + enumFromThen x y + | x <= y = enumDeltaNatural x (y-x) + | otherwise = enumNegDeltaToNatural x (x-y) (wordToNaturalBase 0##) + + enumFromTo x lim = enumDeltaToNatural x (wordToNaturalBase 1##) lim + enumFromThenTo x y lim + | x <= y = enumDeltaToNatural x (y-x) lim + | otherwise = enumNegDeltaToNatural x (x-y) lim + +-- Helpers for 'Enum Natural'; TODO: optimise & make fusion work + +enumDeltaNatural :: Natural -> Natural -> [Natural] +enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d + +enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumDeltaToNatural x0 delta lim = go x0 + where + go x | x > lim = [] + | otherwise = x : go (x+delta) + +enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumNegDeltaToNatural x0 ndelta lim = go x0 + where + go x | x < lim = [] + | x >= ndelta = x : go (x-ndelta) + | otherwise = [x] + +#else + +-- | @since 4.8.0.0 +instance Enum Natural where + pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" + pred (Natural n) = Natural (pred n) + {-# INLINE pred #-} + succ (Natural n) = Natural (succ n) + {-# INLINE succ #-} + fromEnum (Natural n) = fromEnum n + {-# INLINE fromEnum #-} + toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" + | otherwise = Natural (toEnum n) + {-# INLINE toEnum #-} + + enumFrom = coerce (enumFrom :: Integer -> [Integer]) + enumFromThen x y + | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y + | otherwise = enumFromThenTo x y (wordToNaturalBase 0##) + + enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) + enumFromThenTo + = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) + +#endif + -- Instances from GHC.Types -- | @since 4.10.0.0 diff --git a/libraries/base/GHC/Environment.hs b/libraries/base/GHC/Environment.hs index a077f6f8c4..4db0837664 100644 --- a/libraries/base/GHC/Environment.hs +++ b/libraries/base/GHC/Environment.hs @@ -8,11 +8,10 @@ import Foreign import Foreign.C import GHC.Base import GHC.Real ( fromIntegral ) +import GHC.IO.Encoding +import qualified GHC.Foreign as GHC #if defined(mingw32_HOST_OS) -import GHC.IO (finally) -import GHC.Windows - # if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH) @@ -20,47 +19,21 @@ import GHC.Windows # else # error Unknown mingw32 arch # endif -#else -import GHC.IO.Encoding -import qualified GHC.Foreign as GHC #endif --- | Computation 'getFullArgs' is the "raw" version of 'getArgs', similar --- to @argv@ in other languages. It returns a list of the program's --- command line arguments, starting with the program name, and --- including those normally eaten by the RTS (+RTS ... -RTS). +-- | Computation 'getFullArgs' is the "raw" version of +-- 'System.Environment.getArgs', similar to @argv@ in other languages. It +-- returns a list of the program's command line arguments, starting with the +-- program name, and including those normally eaten by the RTS (+RTS ... -RTS). getFullArgs :: IO [String] -#if defined(mingw32_HOST_OS) --- Ignore the arguments to hs_init on Windows for the sake of Unicode compat getFullArgs = do - p_arg_string <- c_GetCommandLine - alloca $ \p_argc -> do - p_argv <- c_CommandLineToArgv p_arg_string p_argc - if p_argv == nullPtr - then throwGetLastError "getFullArgs" - else flip finally (c_LocalFree p_argv) $ do - argc <- peek p_argc - p_argvs <- peekArray (fromIntegral argc) p_argv - mapM peekCWString p_argvs - -foreign import WINDOWS_CCONV unsafe "windows.h GetCommandLineW" - c_GetCommandLine :: IO (Ptr CWString) - -foreign import WINDOWS_CCONV unsafe "windows.h CommandLineToArgvW" - c_CommandLineToArgv :: Ptr CWString -> Ptr CInt -> IO (Ptr CWString) - -foreign import WINDOWS_CCONV unsafe "Windows.h LocalFree" - c_LocalFree :: Ptr a -> IO (Ptr a) -#else -getFullArgs = - alloca $ \ p_argc -> - alloca $ \ p_argv -> do - getFullProgArgv p_argc p_argv - p <- fromIntegral `liftM` peek p_argc - argv <- peek p_argv - enc <- getFileSystemEncoding - peekArray p argv >>= mapM (GHC.peekCString enc) + alloca $ \ p_argc -> do + alloca $ \ p_argv -> do + getFullProgArgv p_argc p_argv + p <- fromIntegral `liftM` peek p_argc + argv <- peek p_argv + enc <- argvEncoding + peekArray p argv >>= mapM (GHC.peekCString enc) foreign import ccall unsafe "getFullProgArgv" getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () -#endif diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index 4231fcefa5..095ccd8dd7 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} -{-# LANGUAGE RankNTypes, TypeInType #-} +{-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -27,10 +27,14 @@ import GHC.CString () import GHC.Types (Char, RuntimeRep) import GHC.Stack.Types import GHC.Prim -import GHC.Integer () -- Make sure Integer is compiled first - -- because GHC depends on it in a wired-in way - -- so the build system doesn't see the dependency -import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) +import GHC.Integer () -- Make sure Integer and Natural are compiled first +import GHC.Natural () -- because GHC depends on it in a wired-in way + -- so the build system doesn't see the dependency. + -- See Note [Depend on GHC.Integer] and + -- Note [Depend on GHC.Natural] in GHC.Base. +import {-# SOURCE #-} GHC.Exception + ( errorCallWithCallStackException + , errorCallException ) -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). @@ -46,10 +50,7 @@ error s = raise# (errorCallWithCallStackException s ?callStack) -- @since 4.9.0.0 errorWithoutStackTrace :: forall (r :: RuntimeRep). forall (a :: TYPE r). [Char] -> a -errorWithoutStackTrace s = - -- we don't have withFrozenCallStack yet, so we just inline the definition - let ?callStack = freezeCallStack emptyCallStack - in error s +errorWithoutStackTrace s = raise# (errorCallException s) -- Note [Errors in base] diff --git a/libraries/base/GHC/Event/Control.hs b/libraries/base/GHC/Event/Control.hs index 9e3940ad19..779d60d5d7 100644 --- a/libraries/base/GHC/Event/Control.hs +++ b/libraries/base/GHC/Event/Control.hs @@ -57,7 +57,9 @@ data ControlMessage = CMsgWakeup | CMsgDie | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Signal - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | The structure used to tell the IO manager thread what to do. data Control = W { @@ -124,7 +126,7 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do -- file after it has been closed. closeControl :: Control -> IO () closeControl w = do - atomicModifyIORef (controlIsDead w) (\_ -> (True, ())) + _ <- atomicSwapIORef (controlIsDead w) True _ <- c_close . fromIntegral . controlReadFd $ w _ <- c_close . fromIntegral . controlWriteFd $ w when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1) diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc index 32bfc3913b..14324bc43d 100644 --- a/libraries/base/GHC/Event/EPoll.hsc +++ b/libraries/base/GHC/Event/EPoll.hsc @@ -161,7 +161,12 @@ newtype ControlOp = ControlOp CInt newtype EventType = EventType { unEventType :: Word32 - } deriving (Show, Eq, Num, Bits, FiniteBits) + } deriving ( Show -- ^ @since 4.4.0.0 + , Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Bits -- ^ @since 4.4.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + ) #{enum EventType, EventType , epollIn = EPOLLIN diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs index 9b8230c032..5778c6f3fe 100644 --- a/libraries/base/GHC/Event/Internal.hs +++ b/libraries/base/GHC/Event/Internal.hs @@ -36,10 +36,11 @@ import GHC.Base import GHC.Word (Word64) import GHC.Num (Num(..)) import GHC.Show (Show(..)) +import Data.Semigroup.Internal (stimesMonoid) -- | An I\/O event. newtype Event = Event Int - deriving (Eq) + deriving Eq -- ^ @since 4.4.0.0 evtNothing :: Event evtNothing = Event 0 @@ -63,7 +64,7 @@ evtClose = Event 4 eventIs :: Event -> Event -> Bool eventIs (Event a) (Event b) = a .&. b /= 0 --- | @since 4.3.1.0 +-- | @since 4.4.0.0 instance Show Event where show e = '[' : (intercalate "," . filter (not . null) $ [evtRead `so` "evtRead", @@ -72,10 +73,14 @@ instance Show Event where where ev `so` disp | e `eventIs` ev = disp | otherwise = "" --- | @since 4.3.1.0 +-- | @since 4.10.0.0 +instance Semigroup Event where + (<>) = evtCombine + stimes = stimesMonoid + +-- | @since 4.4.0.0 instance Monoid Event where mempty = evtNothing - mappend = evtCombine mconcat = evtConcat evtCombine :: Event -> Event -> Event @@ -92,7 +97,9 @@ evtConcat = foldl' evtCombine evtNothing data Lifetime = OneShot -- ^ the registration will be active for only one -- event | MultiShot -- ^ the registration will trigger multiple times - deriving (Show, Eq) + deriving ( Show -- ^ @since 4.8.1.0 + , Eq -- ^ @since 4.8.1.0 + ) -- | The longer of two lifetimes. elSupremum :: Lifetime -> Lifetime -> Lifetime @@ -100,24 +107,33 @@ elSupremum OneShot OneShot = OneShot elSupremum _ _ = MultiShot {-# INLINE elSupremum #-} +-- | @since 4.10.0.0 +instance Semigroup Lifetime where + (<>) = elSupremum + stimes = stimesMonoid + -- | @mappend@ takes the longer of two lifetimes. -- -- @since 4.8.0.0 instance Monoid Lifetime where mempty = OneShot - mappend = elSupremum -- | A pair of an event and lifetime -- -- Here we encode the event in the bottom three bits and the lifetime -- in the fourth bit. newtype EventLifetime = EL Int - deriving (Show, Eq) + deriving ( Show -- ^ @since 4.8.0.0 + , Eq -- ^ @since 4.8.0.0 + ) + +-- | @since 4.11.0.0 +instance Semigroup EventLifetime where + EL a <> EL b = EL (a .|. b) -- | @since 4.8.0.0 instance Monoid EventLifetime where mempty = EL 0 - EL a `mappend` EL b = EL (a .|. b) eventLifetime :: Event -> Lifetime -> EventLifetime eventLifetime (Event e) l = EL (e .|. lifetimeBit l) @@ -137,7 +153,7 @@ elEvent (EL x) = Event (x .&. 0x7) -- | A type alias for timeouts, specified in nanoseconds. data Timeout = Timeout {-# UNPACK #-} !Word64 | Forever - deriving (Show) + deriving Show -- ^ @since 4.4.0.0 -- | Event notification backend. data Backend = forall a. Backend { @@ -200,7 +216,7 @@ delete :: Backend -> IO () delete (Backend bState _ _ _ bDelete) = bDelete bState {-# INLINE delete #-} --- | Throw an 'IOError' corresponding to the current value of +-- | Throw an 'Prelude.IOError' corresponding to the current value of -- 'getErrno' if the result value of the 'IO' action is -1 and -- 'getErrno' is not 'eINTR'. If the result value is -1 and -- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result diff --git a/libraries/base/GHC/Event/KQueue.hsc b/libraries/base/GHC/Event/KQueue.hsc index e9c8419ea7..49cf82db14 100644 --- a/libraries/base/GHC/Event/KQueue.hsc +++ b/libraries/base/GHC/Event/KQueue.hsc @@ -28,11 +28,13 @@ available = False import Data.Bits (Bits(..), FiniteBits(..)) import Data.Int +import Data.Maybe ( catMaybes ) import Data.Word (Word16, Word32) import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL, eNOTSUP, getErrno, throwErrno) import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (withArrayLen) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (Storable(..)) import GHC.Base @@ -85,23 +87,20 @@ delete kq = do return () modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool -modifyFd kq fd oevt nevt - | nevt == mempty = do - let !ev = event fd (toFilter oevt) flagDelete noteEOF - kqueueControl (kqueueFd kq) ev - | otherwise = do - let !ev = event fd (toFilter nevt) flagAdd noteEOF - kqueueControl (kqueueFd kq) ev - -toFilter :: E.Event -> Filter -toFilter evt - | evt `E.eventIs` E.evtRead = filterRead - | otherwise = filterWrite +modifyFd kq fd oevt nevt = kqueueControl (kqueueFd kq) evs + where + evs + | nevt == mempty = toEvents fd (toFilter oevt) flagDelete noteEOF + | otherwise = toEvents fd (toFilter nevt) flagAdd noteEOF + +toFilter :: E.Event -> [Filter] +toFilter e = catMaybes [ check E.evtRead filterRead, check E.evtWrite filterWrite ] + where + check e' f = if e `E.eventIs` e' then Just f else Nothing modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool -modifyFdOnce kq fd evt = do - let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF - kqueueControl (kqueueFd kq) ev +modifyFdOnce kq fd evt = + kqueueControl (kqueueFd kq) (toEvents fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF) poll :: KQueue -> Maybe Timeout @@ -125,7 +124,9 @@ poll kq mtimeout f = do newtype KQueueFd = KQueueFd { fromKQueueFd :: CInt - } deriving (Eq, Show) + } deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) data Event = KEvent { ident :: {-# UNPACK #-} !CUIntPtr @@ -138,10 +139,10 @@ data Event = KEvent { , data_ :: {-# UNPACK #-} !CIntPtr #endif , udata :: {-# UNPACK #-} !(Ptr ()) - } deriving Show + } deriving Show -- ^ @since 4.4.0.0 -event :: Fd -> Filter -> Flag -> FFlag -> Event -event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr +toEvents :: Fd -> [Filter] -> Flag -> FFlag -> [Event] +toEvents fd flts flag fflag = map (\filt -> KEvent (fromIntegral fd) filt flag fflag 0 nullPtr) flts -- | @since 4.3.1.0 instance Storable Event where @@ -168,7 +169,10 @@ instance Storable Event where #{poke struct kevent, udata} ptr (udata ev) newtype FFlag = FFlag Word32 - deriving (Eq, Show, Storable) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) #{enum FFlag, FFlag , noteEOF = NOTE_EOF @@ -179,7 +183,13 @@ newtype Flag = Flag Word32 #else newtype Flag = Flag Word16 #endif - deriving (Bits, FiniteBits, Eq, Num, Show, Storable) + deriving ( Bits -- ^ @since 4.7.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + , Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) #{enum Flag, Flag , flagAdd = EV_ADD @@ -192,7 +202,11 @@ newtype Filter = Filter Int32 #else newtype Filter = Filter Int16 #endif - deriving (Bits, FiniteBits, Eq, Num, Show, Storable) + deriving ( Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) filterRead :: Filter filterRead = Filter (#const EVFILT_READ) @@ -222,11 +236,11 @@ instance Storable TimeSpec where kqueue :: IO KQueueFd kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue -kqueueControl :: KQueueFd -> Event -> IO Bool -kqueueControl kfd ev = +kqueueControl :: KQueueFd -> [Event] -> IO Bool +kqueueControl kfd evts = withTimeSpec (TimeSpec 0 0) $ \tp -> - withEvent ev $ \evp -> do - res <- kevent False kfd evp 1 nullPtr 0 tp + withArrayLen evts $ \evlen evp -> do + res <- kevent False kfd evp evlen nullPtr 0 tp if res == -1 then do err <- getErrno @@ -255,9 +269,6 @@ kevent safe k chs chlen evs evlen ts | safe = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts -withEvent :: Event -> (Ptr Event -> IO a) -> IO a -withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr - withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a withTimeSpec ts f | tv_sec ts < 0 = f nullPtr diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs index 013850b5d2..3ee9116812 100644 --- a/libraries/base/GHC/Event/Manager.hs +++ b/libraries/base/GHC/Event/Manager.hs @@ -110,7 +110,9 @@ data FdData = FdData { data FdKey = FdKey { keyFd :: {-# UNPACK #-} !Fd , keyUnique :: {-# UNPACK #-} !Unique - } deriving (Eq, Show) + } deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | Callback invoked on I/O events. type IOCallback = FdKey -> Event -> IO () @@ -120,7 +122,9 @@ data State = Created | Dying | Releasing | Finished - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | The event manager state. data EventManager = EventManager diff --git a/libraries/base/GHC/Event/PSQ.hs b/libraries/base/GHC/Event/PSQ.hs index 976ffe16b3..6e13839491 100644 --- a/libraries/base/GHC/Event/PSQ.hs +++ b/libraries/base/GHC/Event/PSQ.hs @@ -28,7 +28,7 @@ module GHC.Event.PSQ , singleton -- * Insertion - , insert + , unsafeInsertNew -- * Delete/Update , delete @@ -36,7 +36,6 @@ module GHC.Event.PSQ -- * Conversion , toList - , fromList -- * Min , findMin @@ -58,7 +57,7 @@ import GHC.Types (Int) {- -- Use macros to define strictness of functions. --- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter. +-- STRICT_x_OF_y denotes a y-ary function strict in the x-th parameter. -- We do not use BangPatterns, because they are not in any standard and we -- want the compilers to be compiled by as many compilers as possible. #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined @@ -213,14 +212,7 @@ singleton = Tip -- Insertion ------------------------------------------------------------------------------ --- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key --- is already present in the queue, the associated priority and value are --- replaced with the supplied priority and value. -insert :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v -insert k p x t0 = unsafeInsertNew k p x (delete k t0) - --- | Internal function to insert a key that is *not* present in the priority --- queue. +-- | /O(min(n,W))/ Insert a new key that is *not* present in the priority queue. {-# INLINABLE unsafeInsertNew #-} unsafeInsertNew :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v unsafeInsertNew k p x = go @@ -340,13 +332,6 @@ binShrinkR k p x m l r = Bin k p x m l r -- Lists ------------------------------------------------------------------------------ --- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples. --- If the list contains more than one priority and value for the same key, the --- last priority and value for the key is retained. -{-# INLINABLE fromList #-} -fromList :: [Elem v] -> IntPSQ v -fromList = foldr (\(E k p x) im -> insert k p x im) empty - -- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The -- order of the list is not specified. toList :: IntPSQ v -> [Elem v] diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc index 74525c6b40..1dafd601ec 100644 --- a/libraries/base/GHC/Event/Poll.hsc +++ b/libraries/base/GHC/Event/Poll.hsc @@ -151,10 +151,16 @@ data PollFd = PollFd { pfdFd :: {-# UNPACK #-} !Fd , pfdEvents :: {-# UNPACK #-} !Event , pfdRevents :: {-# UNPACK #-} !Event - } deriving (Show) + } deriving Show -- ^ @since 4.4.0.0 newtype Event = Event CShort - deriving (Eq, Show, Num, Storable, Bits, FiniteBits) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + , Bits -- ^ @since 4.4.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + ) -- We have to duplicate the whole enum like this in order for the -- hsc2hs cross-compilation mode to work diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index d4b679206a..a9d5410d9c 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -72,7 +72,7 @@ registerDelay usecs = do -- | Block the current thread until data is available to read from the -- given file descriptor. -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitRead', use 'closeFdWith'. threadWaitRead :: Fd -> IO () @@ -82,7 +82,7 @@ threadWaitRead = threadWait evtRead -- | Block the current thread until the given file descriptor can -- accept data to write. -- --- This will throw an 'IOError' if the file descriptor was closed +-- This will throw an 'Prelude.IOError' if the file descriptor was closed -- while this thread was blocked. To safely close a file descriptor -- that has been used with 'threadWaitWrite', use 'closeFdWith'. threadWaitWrite :: Fd -> IO () @@ -145,7 +145,7 @@ threadWaitSTM evt fd = mask_ $ do -- The second element of the return value pair is an IO action that can be used -- to deregister interest in the file descriptor. -- --- The STM action will throw an 'IOError' if the file descriptor was closed +-- The STM action will throw an 'Prelude.IOError' if the file descriptor was closed -- while the STM action is being executed. To safely close a file descriptor -- that has been used with 'threadWaitReadSTM', use 'closeFdWith'. threadWaitReadSTM :: Fd -> IO (STM (), IO ()) @@ -157,7 +157,7 @@ threadWaitReadSTM = threadWaitSTM evtRead -- The second element of the return value pair is an IO action that can be used to deregister -- interest in the file descriptor. -- --- The STM action will throw an 'IOError' if the file descriptor was closed +-- The STM action will throw an 'Prelude.IOError' if the file descriptor was closed -- while the STM action is being executed. To safely close a file descriptor -- that has been used with 'threadWaitWriteSTM', use 'closeFdWith'. threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index f3dbb21686..946f2333bf 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -43,11 +43,12 @@ import Data.Foldable (sequence_) import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, writeIORef) import GHC.Base +import GHC.Clock (getMonotonicTimeNSec) import GHC.Conc.Signal (runHandlers) +import GHC.Enum (maxBound) import GHC.Num (Num(..)) -import GHC.Real (fromIntegral) +import GHC.Real (quot, fromIntegral) import GHC.Show (Show(..)) -import GHC.Event.Clock (getMonotonicTimeNSec) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..)) import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) @@ -67,7 +68,7 @@ import qualified GHC.Event.Poll as Poll -- | A timeout registration cookie. newtype TimeoutKey = TK Unique - deriving (Eq) + deriving Eq -- ^ @since 4.7.0.0 -- | Callback invoked on timeout events. type TimeoutCallback = IO () @@ -76,7 +77,9 @@ data State = Created | Running | Dying | Finished - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + ) -- | A priority search queue, with timeouts as priorities. type TimeoutQueue = Q.PSQ TimeoutCallback @@ -206,6 +209,18 @@ wakeManager mgr = sendWakeup (emControl mgr) ------------------------------------------------------------------------ -- Registering interest in timeout events +expirationTime :: Int -> IO Q.Prio +expirationTime us = do + now <- getMonotonicTimeNSec + let expTime + -- Currently we treat overflows by clamping to maxBound. If humanity + -- still exists in 2500 CE we will ned to be a bit more careful here. + -- See #15158. + | (maxBound - now) `quot` 1000 < fromIntegral us = maxBound + | otherwise = now + ns + where ns = 1000 * fromIntegral us + return expTime + -- | Register a timeout in the given number of microseconds. The -- returned 'TimeoutKey' can be used to later unregister or update the -- timeout. The timeout is automatically unregistered after the given @@ -215,10 +230,11 @@ registerTimeout mgr us cb = do !key <- newUnique (emUniqueSource mgr) if us <= 0 then cb else do - now <- getMonotonicTimeNSec - let expTime = fromIntegral us * 1000 + now + expTime <- expirationTime us - editTimeouts mgr (Q.insert key expTime cb) + -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It + -- doesn't because we just generated it from a unique supply. + editTimeouts mgr (Q.unsafeInsertNew key expTime cb) return $ TK key -- | Unregister an active timeout. @@ -230,9 +246,7 @@ unregisterTimeout mgr (TK key) = do -- microseconds. updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO () updateTimeout mgr (TK key) us = do - now <- getMonotonicTimeNSec - let expTime = fromIntegral us * 1000 + now - + expTime <- expirationTime us editTimeouts mgr (Q.adjust (const expTime) key) editTimeouts :: TimerManager -> TimeoutEdit -> IO () diff --git a/libraries/base/GHC/Event/Unique.hs b/libraries/base/GHC/Event/Unique.hs index 0363af2068..1339bd97e7 100644 --- a/libraries/base/GHC/Event/Unique.hs +++ b/libraries/base/GHC/Event/Unique.hs @@ -19,7 +19,10 @@ import GHC.Show(Show(..)) data UniqueSource = US (MutableByteArray# RealWorld) newtype Unique = Unique { asInt :: Int } - deriving (Eq, Ord, Num) + deriving ( Eq -- ^ @since 4.4.0.0 + , Ord -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + ) -- | @since 4.3.1.0 instance Show Unique where diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index 6a77e6e50b..3b32e230e8 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -5,6 +5,7 @@ , RecordWildCards , PatternSynonyms #-} +{-# LANGUAGE TypeInType #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -22,155 +23,38 @@ ----------------------------------------------------------------------------- module GHC.Exception - ( Exception(..) -- Class + ( module GHC.Exception.Type , throw - , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..) - , divZeroException, overflowException, ratioZeroDenomException - , underflowException - , errorCallException, errorCallWithCallStackException + , ErrorCall(..,ErrorCall) + , errorCallException + , errorCallWithCallStackException -- re-export CallStack and SrcLoc from GHC.Types , CallStack, fromCallSiteList, getCallStack, prettyCallStack , prettyCallStackLines, showCCSStack , SrcLoc(..), prettySrcLoc ) where -import Data.Maybe -import Data.Typeable (Typeable, cast) - -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show import GHC.Stack.Types import GHC.OldList +import GHC.Prim import GHC.IO.Unsafe import {-# SOURCE #-} GHC.Stack.CCS - -{- | -The @SomeException@ type is the root of the exception type hierarchy. -When an exception of type @e@ is thrown, behind the scenes it is -encapsulated in a @SomeException@. --} -data SomeException = forall e . Exception e => SomeException e - --- | @since 3.0 -instance Show SomeException where - showsPrec p (SomeException e) = showsPrec p e - -{- | -Any type that you wish to throw or catch as an exception must be an -instance of the @Exception@ class. The simplest case is a new exception -type directly below the root: - -> data MyException = ThisException | ThatException -> deriving Show -> -> instance Exception MyException - -The default method definitions in the @Exception@ class do what we need -in this case. You can now throw and catch @ThisException@ and -@ThatException@ as exceptions: - -@ -*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) -Caught ThisException -@ - -In more complicated examples, you may wish to define a whole hierarchy -of exceptions: - -> --------------------------------------------------------------------- -> -- Make the root exception type for all the exceptions in a compiler -> -> data SomeCompilerException = forall e . Exception e => SomeCompilerException e -> -> instance Show SomeCompilerException where -> show (SomeCompilerException e) = show e -> -> instance Exception SomeCompilerException -> -> compilerExceptionToException :: Exception e => e -> SomeException -> compilerExceptionToException = toException . SomeCompilerException -> -> compilerExceptionFromException :: Exception e => SomeException -> Maybe e -> compilerExceptionFromException x = do -> SomeCompilerException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make a subhierarchy for exceptions in the frontend of the compiler -> -> data SomeFrontendException = forall e . Exception e => SomeFrontendException e -> -> instance Show SomeFrontendException where -> show (SomeFrontendException e) = show e -> -> instance Exception SomeFrontendException where -> toException = compilerExceptionToException -> fromException = compilerExceptionFromException -> -> frontendExceptionToException :: Exception e => e -> SomeException -> frontendExceptionToException = toException . SomeFrontendException -> -> frontendExceptionFromException :: Exception e => SomeException -> Maybe e -> frontendExceptionFromException x = do -> SomeFrontendException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make an exception type for a particular frontend compiler exception -> -> data MismatchedParentheses = MismatchedParentheses -> deriving Show -> -> instance Exception MismatchedParentheses where -> toException = frontendExceptionToException -> fromException = frontendExceptionFromException - -We can now catch a @MismatchedParentheses@ exception as -@MismatchedParentheses@, @SomeFrontendException@ or -@SomeCompilerException@, but not other types, e.g. @IOException@: - -@ -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: IOException)) -*** Exception: MismatchedParentheses -@ - --} -class (Typeable e, Show e) => Exception e where - toException :: e -> SomeException - fromException :: SomeException -> Maybe e - - toException = SomeException - fromException (SomeException e) = cast e - - -- | Render this exception value in a human-friendly manner. - -- - -- Default implementation: @'show'@. - -- - -- @since 4.8.0.0 - displayException :: e -> String - displayException = show - --- | @since 3.0 -instance Exception SomeException where - toException se = se - fromException = Just - displayException (SomeException e) = displayException e +import GHC.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely -- functional code, but may only be caught within the 'IO' monad. -throw :: Exception e => e -> a +throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e. + Exception e => e -> a throw e = raise# (toException e) --- |This is thrown when the user calls 'error'. The @String@ is the --- argument given to 'error'. +-- | This is thrown when the user calls 'error'. The first @String@ is the +-- argument given to 'error', second @String@ is the location. data ErrorCall = ErrorCallWithLocation String String - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + ) pattern ErrorCall :: String -> ErrorCall pattern ErrorCall err <- ErrorCallWithLocation err _ where @@ -184,7 +68,8 @@ instance Exception ErrorCall -- | @since 4.0.0.0 instance Show ErrorCall where showsPrec _ (ErrorCallWithLocation err "") = showString err - showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc) + showsPrec _ (ErrorCallWithLocation err loc) = + showString err . showChar '\n' . showString loc errorCallException :: String -> SomeException errorCallException s = toException (ErrorCall s) @@ -230,31 +115,3 @@ prettyCallStackLines cs = case getCallStack cs of : map ((" " ++) . prettyCallSite) stk where prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc - --- |Arithmetic exceptions. -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - | RatioZeroDenominator -- ^ @since 4.6.0.0 - deriving (Eq, Ord) - -divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException -divZeroException = toException DivideByZero -overflowException = toException Overflow -ratioZeroDenomException = toException RatioZeroDenominator -underflowException = toException Underflow - --- | @since 4.0.0.0 -instance Exception ArithException - --- | @since 4.0.0.0 -instance Show ArithException where - showsPrec _ Overflow = showString "arithmetic overflow" - showsPrec _ Underflow = showString "arithmetic underflow" - showsPrec _ LossOfPrecision = showString "loss of precision" - showsPrec _ DivideByZero = showString "divide by zero" - showsPrec _ Denormal = showString "denormal" - showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot index d539dd4962..4507b20790 100644 --- a/libraries/base/GHC/Exception.hs-boot +++ b/libraries/base/GHC/Exception.hs-boot @@ -24,17 +24,15 @@ well-behaved, non-bottom values. The clients use 'raise#' to get a visibly-bottom value. -} -module GHC.Exception ( SomeException, errorCallException, - errorCallWithCallStackException, - divZeroException, overflowException, ratioZeroDenomException, - underflowException - ) where +module GHC.Exception + ( module GHC.Exception.Type + , errorCallException + , errorCallWithCallStackException + ) where + +import {-# SOURCE #-} GHC.Exception.Type import GHC.Types ( Char ) import GHC.Stack.Types ( CallStack ) -data SomeException -divZeroException, overflowException, ratioZeroDenomException :: SomeException -underflowException :: SomeException - errorCallException :: [Char] -> SomeException errorCallWithCallStackException :: [Char] -> CallStack -> SomeException diff --git a/libraries/base/GHC/Exception/Type.hs b/libraries/base/GHC/Exception/Type.hs new file mode 100644 index 0000000000..6c3eb49ff9 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , RecordWildCards + , PatternSynonyms + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exception.Type +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- +----------------------------------------------------------------------------- + +module GHC.Exception.Type + ( Exception(..) -- Class + , SomeException(..), ArithException(..) + , divZeroException, overflowException, ratioZeroDenomException + , underflowException + ) where + +import Data.Maybe +import Data.Typeable (Typeable, cast) + -- loop: Data.Typeable -> GHC.Err -> GHC.Exception +import GHC.Base +import GHC.Show + +{- | +The @SomeException@ type is the root of the exception type hierarchy. +When an exception of type @e@ is thrown, behind the scenes it is +encapsulated in a @SomeException@. +-} +data SomeException = forall e . Exception e => SomeException e + +-- | @since 3.0 +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +{- | +Any type that you wish to throw or catch as an exception must be an +instance of the @Exception@ class. The simplest case is a new exception +type directly below the root: + +> data MyException = ThisException | ThatException +> deriving Show +> +> instance Exception MyException + +The default method definitions in the @Exception@ class do what we need +in this case. You can now throw and catch @ThisException@ and +@ThatException@ as exceptions: + +@ +*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +Caught ThisException +@ + +In more complicated examples, you may wish to define a whole hierarchy +of exceptions: + +> --------------------------------------------------------------------- +> -- Make the root exception type for all the exceptions in a compiler +> +> data SomeCompilerException = forall e . Exception e => SomeCompilerException e +> +> instance Show SomeCompilerException where +> show (SomeCompilerException e) = show e +> +> instance Exception SomeCompilerException +> +> compilerExceptionToException :: Exception e => e -> SomeException +> compilerExceptionToException = toException . SomeCompilerException +> +> compilerExceptionFromException :: Exception e => SomeException -> Maybe e +> compilerExceptionFromException x = do +> SomeCompilerException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make a subhierarchy for exceptions in the frontend of the compiler +> +> data SomeFrontendException = forall e . Exception e => SomeFrontendException e +> +> instance Show SomeFrontendException where +> show (SomeFrontendException e) = show e +> +> instance Exception SomeFrontendException where +> toException = compilerExceptionToException +> fromException = compilerExceptionFromException +> +> frontendExceptionToException :: Exception e => e -> SomeException +> frontendExceptionToException = toException . SomeFrontendException +> +> frontendExceptionFromException :: Exception e => SomeException -> Maybe e +> frontendExceptionFromException x = do +> SomeFrontendException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make an exception type for a particular frontend compiler exception +> +> data MismatchedParentheses = MismatchedParentheses +> deriving Show +> +> instance Exception MismatchedParentheses where +> toException = frontendExceptionToException +> fromException = frontendExceptionFromException + +We can now catch a @MismatchedParentheses@ exception as +@MismatchedParentheses@, @SomeFrontendException@ or +@SomeCompilerException@, but not other types, e.g. @IOException@: + +@ +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) +*** Exception: MismatchedParentheses +@ + +-} +class (Typeable e, Show e) => Exception e where + toException :: e -> SomeException + fromException :: SomeException -> Maybe e + + toException = SomeException + fromException (SomeException e) = cast e + + -- | Render this exception value in a human-friendly manner. + -- + -- Default implementation: @'show'@. + -- + -- @since 4.8.0.0 + displayException :: e -> String + displayException = show + +-- | @since 3.0 +instance Exception SomeException where + toException se = se + fromException = Just + displayException (SomeException e) = displayException e + +-- |Arithmetic exceptions. +data ArithException + = Overflow + | Underflow + | LossOfPrecision + | DivideByZero + | Denormal + | RatioZeroDenominator -- ^ @since 4.6.0.0 + deriving ( Eq -- ^ @since 3.0 + , Ord -- ^ @since 3.0 + ) + +divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException +divZeroException = toException DivideByZero +overflowException = toException Overflow +ratioZeroDenomException = toException RatioZeroDenominator +underflowException = toException Underflow + +-- | @since 4.0.0.0 +instance Exception ArithException + +-- | @since 4.0.0.0 +instance Show ArithException where + showsPrec _ Overflow = showString "arithmetic overflow" + showsPrec _ Underflow = showString "arithmetic underflow" + showsPrec _ LossOfPrecision = showString "loss of precision" + showsPrec _ DivideByZero = showString "divide by zero" + showsPrec _ Denormal = showString "denormal" + showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception/Type.hs-boot b/libraries/base/GHC/Exception/Type.hs-boot new file mode 100644 index 0000000000..1b4f0c0d81 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Exception.Type + ( SomeException + , divZeroException + , overflowException + , ratioZeroDenomException + , underflowException + ) where + +import GHC.Types () + +data SomeException +divZeroException, overflowException, + ratioZeroDenomException, underflowException :: SomeException diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index f6204aabd4..9fc1a638fc 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -34,6 +34,9 @@ module GHC.Exts uncheckedIShiftL64#, uncheckedIShiftRA64#, isTrue#, + -- * Compat wrapper + atomicModifyMutVar#, + -- * Fusion build, augment, @@ -46,7 +49,7 @@ module GHC.Exts -- * Ids with special behaviour lazy, inline, oneShot, - -- * Running 'RealWorld' state transformers + -- * Running 'RealWorld' state thread runRW#, -- * Safe coercions @@ -154,7 +157,9 @@ traceEvent = Debug.Trace.traceEventIO -- entire ghc package at runtime data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr - deriving( Data, Eq ) + deriving ( Data -- ^ @since 4.3.0.0 + , Eq -- ^ @since 4.3.0.0 + ) {- ********************************************************************** @@ -194,6 +199,15 @@ instance IsList [a] where fromList = id toList = id +-- | @since 4.9.0.0 +instance IsList (NonEmpty a) where + type Item (NonEmpty a) = a + + fromList (a:as) = a :| as + fromList [] = errorWithoutStackTrace "NonEmpty.fromList: empty list" + + toList ~(a :| as) = a : as + -- | @since 4.8.0.0 instance IsList Version where type (Item Version) = Int @@ -208,3 +222,27 @@ instance IsList CallStack where type (Item CallStack) = (String, SrcLoc) fromList = fromCallSiteList toList = getCallStack + +-- | An implementation of the old @atomicModifyMutVar#@ primop in +-- terms of the new 'atomicModifyMutVar2#' primop, for backwards +-- compatibility. The type of this function is a bit bogus. It's +-- best to think of it as having type +-- +-- @ +-- atomicModifyMutVar# +-- :: MutVar# s a +-- -> (a -> (a, b)) +-- -> State# s +-- -> (# State# s, b #) +-- @ +-- +-- but there may be code that uses this with other two-field record +-- types. +atomicModifyMutVar# + :: MutVar# s a + -> (a -> b) + -> State# s + -> (# State# s, c #) +atomicModifyMutVar# mv f s = + case unsafeCoerce# (atomicModifyMutVar2# mv f s) of + (# s', _, ~(_, res) #) -> (# s', res #) diff --git a/libraries/base/GHC/Fingerprint/Type.hs b/libraries/base/GHC/Fingerprint/Type.hs index 1ad34a7791..234bac1d43 100644 --- a/libraries/base/GHC/Fingerprint/Type.hs +++ b/libraries/base/GHC/Fingerprint/Type.hs @@ -22,7 +22,9 @@ import Numeric (showHex) -- Using 128-bit MD5 fingerprints for now. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.4.0.0 + , Ord -- ^ @since 4.4.0.0 + ) -- | @since 4.7.0.0 instance Show Fingerprint where diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index c534bafa07..9296978bd4 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -64,6 +64,13 @@ infixr 8 ** ------------------------------------------------------------------------ -- | Trigonometric and hyperbolic functions and related functions. +-- +-- The Haskell Report defines no laws for 'Floating'. However, '(+)', '(*)' +-- and 'exp' are customarily expected to define an exponential field and have +-- the following properties: +-- +-- * @exp (a + b)@ = @exp a * exp b +-- * @exp (fromInteger 0)@ = @fromInteger 1@ class (Fractional a) => Floating a where pi :: a exp, log, sqrt :: a -> a @@ -159,7 +166,7 @@ class (RealFrac a, Floating a) => RealFloat a where decodeFloat :: a -> (Integer,Int) -- | 'encodeFloat' performs the inverse of 'decodeFloat' in the -- sense that for finite @x@ with the exception of @-0.0@, - -- @'uncurry' 'encodeFloat' ('decodeFloat' x) = x@. + -- @'Prelude.uncurry' 'encodeFloat' ('decodeFloat' x) = x@. -- @'encodeFloat' m n@ is one of the two closest representable -- floating-point numbers to @m*b^^n@ (or @±Infinity@ if overflow -- occurs); usually the closer, but if @m@ contains too many bits, @@ -245,7 +252,18 @@ class (RealFrac a, Floating a) => RealFloat a where ------------------------------------------------------------------------ -- | @since 2.01 -instance Num Float where +-- Note that due to the presence of @NaN@, not all elements of 'Float' have an +-- additive inverse. +-- +-- >>> 0/0 + (negate 0/0 :: Float) +-- NaN +-- +-- Also note that due to the presence of -0, `Float`'s 'Num' instance doesn't +-- have an additive identity +-- +-- >>> 0 + (-0 :: Float) +-- 0.0 +instance Num Float where (+) x y = plusFloat x y (-) x y = minusFloat x y negate x = negateFloat x @@ -272,6 +290,11 @@ instance Real Float where smallInteger m# :% shiftLInteger 1 (negateInt# e#) -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Float' have an +-- multiplicative inverse. +-- +-- >>> 0/0 * (recip 0/0 :: Float) +-- NaN instance Fractional Float where (/) x y = divideFloat x y {-# INLINE fromRational #-} @@ -367,9 +390,9 @@ instance Floating Float where (**) x y = powerFloat x y logBase x y = log y / log x - asinh x = log (x + sqrt (1.0+x*x)) - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + asinh x = asinhFloat x + acosh x = acoshFloat x + atanh x = atanhFloat x log1p = log1pFloat expm1 = expm1Float @@ -425,6 +448,17 @@ instance Show Float where ------------------------------------------------------------------------ -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Double' have an +-- additive inverse. +-- +-- >>> 0/0 + (negate 0/0 :: Double) +-- NaN +-- +-- Also note that due to the presence of -0, `Double`'s 'Num' instance doesn't +-- have an additive identity +-- +-- >>> 0 + (-0 :: Double) +-- 0.0 instance Num Double where (+) x y = plusDouble x y (-) x y = minusDouble x y @@ -454,6 +488,11 @@ instance Real Double where m :% shiftLInteger 1 (negateInt# e#) -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Double' have an +-- multiplicative inverse. +-- +-- >>> 0/0 * (recip 0/0 :: Double) +-- NaN instance Fractional Double where (/) x y = divideDouble x y {-# INLINE fromRational #-} @@ -492,9 +531,9 @@ instance Floating Double where (**) x y = powerDouble x y logBase x y = log y / log x - asinh x = log (x + sqrt (1.0+x*x)) - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - atanh x = 0.5 * log ((1.0+x) / (1.0-x)) + asinh x = asinhDouble x + acosh x = acoshDouble x + atanh x = atanhDouble x log1p = log1pDouble expm1 = expm1Double @@ -682,6 +721,18 @@ formatRealFloatAlt fmt decs alt x [d] -> d : ".0e" ++ show_e' (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' [] -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []" + Just d | d <= 0 -> + -- handle this case specifically since we need to omit the + -- decimal point as well (#15115). + -- Note that this handles negative precisions as well for consistency + -- (see #15509). + case is of + [0] -> "0e0" + _ -> + let + (ei,is') = roundTo base 1 is + n:_ = map intToDigit (if ei > 0 then init is' else is') + in n : 'e' : show (e-1+ei) Just dec -> let dec' = max dec 1 in case is of @@ -1092,6 +1143,7 @@ expFloat, logFloat, sqrtFloat, fabsFloat :: Float -> Float sinFloat, cosFloat, tanFloat :: Float -> Float asinFloat, acosFloat, atanFloat :: Float -> Float sinhFloat, coshFloat, tanhFloat :: Float -> Float +asinhFloat, acoshFloat, atanhFloat :: Float -> Float expFloat (F# x) = F# (expFloat# x) logFloat (F# x) = F# (logFloat# x) sqrtFloat (F# x) = F# (sqrtFloat# x) @@ -1105,6 +1157,9 @@ atanFloat (F# x) = F# (atanFloat# x) sinhFloat (F# x) = F# (sinhFloat# x) coshFloat (F# x) = F# (coshFloat# x) tanhFloat (F# x) = F# (tanhFloat# x) +asinhFloat (F# x) = F# (asinhFloat# x) +acoshFloat (F# x) = F# (acoshFloat# x) +atanhFloat (F# x) = F# (atanhFloat# x) powerFloat :: Float -> Float -> Float powerFloat (F# x) (F# y) = F# (powerFloat# x y) @@ -1137,6 +1192,7 @@ expDouble, logDouble, sqrtDouble, fabsDouble :: Double -> Double sinDouble, cosDouble, tanDouble :: Double -> Double asinDouble, acosDouble, atanDouble :: Double -> Double sinhDouble, coshDouble, tanhDouble :: Double -> Double +asinhDouble, acoshDouble, atanhDouble :: Double -> Double expDouble (D# x) = D# (expDouble# x) logDouble (D# x) = D# (logDouble# x) sqrtDouble (D# x) = D# (sqrtDouble# x) @@ -1150,6 +1206,9 @@ atanDouble (D# x) = D# (atanDouble# x) sinhDouble (D# x) = D# (sinhDouble# x) coshDouble (D# x) = D# (coshDouble# x) tanhDouble (D# x) = D# (tanhDouble# x) +asinhDouble (D# x) = D# (asinhDouble# x) +acoshDouble (D# x) = D# (acoshDouble# x) +atanhDouble (D# x) = D# (atanhDouble# x) powerDouble :: Double -> Double -> Double powerDouble (D# x) (D# y) = D# (x **## y) diff --git a/libraries/base/GHC/Foreign.hs b/libraries/base/GHC/Foreign.hs index eb5e853b38..196005d3a7 100644 --- a/libraries/base/GHC/Foreign.hs +++ b/libraries/base/GHC/Foreign.hs @@ -154,7 +154,8 @@ withCStringsLen enc strs f = go [] strs go cs (s:ss) = withCString enc s $ \c -> go (c:cs) ss go cs [] = withArrayLen (reverse cs) f --- | Determines whether a character can be accurately encoded in a 'CString'. +-- | Determines whether a character can be accurately encoded in a +-- 'Foreign.C.String.CString'. -- -- Pretty much anyone who uses this function is in a state of sin because -- whether or not a character is encodable will, in general, depend on the @@ -200,7 +201,7 @@ peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes) from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p) to <- newCharBuffer chunk_size WriteBuffer - let go iteration from = do + let go !iteration from = do (why, from', to') <- encode decoder from to if isEmptyBuffer from' then @@ -229,7 +230,7 @@ withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p - let go iteration to_sz_bytes = do + let go !iteration to_sz_bytes = do putDebugMsg ("withEncodedCString: " ++ show iteration) allocaBytes to_sz_bytes $ \to_p -> do mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes act @@ -249,7 +250,7 @@ newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p - let go iteration to_p to_sz_bytes = do + let go !iteration to_p to_sz_bytes = do putDebugMsg ("newEncodedCString: " ++ show iteration) mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes return case mb_res of @@ -271,7 +272,7 @@ tryFillBufferAndCall encoder null_terminate from0 to_p to_sz_bytes act = do to_fp <- newForeignPtr_ to_p go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer) where - go iteration (from, to) = do + go !iteration (from, to) = do (why, from', to') <- encode encoder from to putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from') if isEmptyBuffer from' diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index 043de1f94b..6aed677dbb 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -153,8 +153,8 @@ mallocForeignPtr :: Storable a => IO (ForeignPtr a) -- implementation in GHC. It uses pinned memory in the garbage -- collected heap, so the 'ForeignPtr' does not require a finalizer to -- free the memory. Use of 'mallocForeignPtr' and associated --- functions is strongly recommended in preference to 'newForeignPtr' --- with a finalizer. +-- functions is strongly recommended in preference to +-- 'Foreign.ForeignPtr.newForeignPtr' with a finalizer. -- mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) @@ -289,9 +289,10 @@ addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO () -- -- NB. Be very careful with these finalizers. One common trap is that -- if a finalizer references another finalized value, it does not --- prevent that value from being finalized. In particular, 'Handle's --- are finalized objects, so a finalizer should not refer to a 'Handle' --- (including @stdout@, @stdin@ or @stderr@). +-- prevent that value from being finalized. In particular, 'System.IO.Handle's +-- are finalized objects, so a finalizer should not refer to a +-- 'System.IO.Handle' (including 'System.IO.stdout', 'System.IO.stdin', or +-- 'System.IO.stderr'). -- addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer = addForeignPtrConcFinalizer_ c finalizer @@ -321,7 +322,7 @@ addForeignPtrConcFinalizer_ _ _ = insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool insertHaskellFinalizer r f = do - !wasEmpty <- atomicModifyIORef r $ \finalizers -> case finalizers of + !wasEmpty <- atomicModifyIORefP r $ \finalizers -> case finalizers of NoFinalizers -> (HaskellFinalizers [f], True) HaskellFinalizers fs -> (HaskellFinalizers (f:fs), False) _ -> noMixingError @@ -352,8 +353,8 @@ ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do NoFinalizers -> IO $ \s -> case mkWeakNoFinalizer# r# (unsafeCoerce# value) s of { (# s1, w #) -> -- See Note [MallocPtr finalizers] (#10904) - case atomicModifyMutVar# r# (update w) s1 of - { (# s2, (weak, needKill ) #) -> + case atomicModifyMutVar2# r# (update w) s1 of + { (# s2, _, (_, (weak, needKill )) #) -> if needKill then case finalizeWeak# w s2 of { (# s3, _, _ #) -> (# s3, weak #) } @@ -370,7 +371,8 @@ noMixingError = errorWithoutStackTrace $ foreignPtrFinalizer :: IORef Finalizers -> IO () foreignPtrFinalizer r = do - fs <- atomicModifyIORef r $ \fs -> (NoFinalizers, fs) -- atomic, see #7170 + fs <- atomicSwapIORef r NoFinalizers + -- atomic, see #7170 case fs of NoFinalizers -> return () CFinalizers w -> IO $ \s -> case finalizeWeak# w s of diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs index 14184c2eb6..c4e09aa198 100644 --- a/libraries/base/GHC/Generics.hs +++ b/libraries/base/GHC/Generics.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -14,7 +15,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -105,7 +105,7 @@ module GHC.Generics ( -- This is a lot of information! However, most of it is actually merely meta-information -- that makes names of datatypes and constructors and more available on the type level. -- --- Here is a reduced representation for 'Tree' with nearly all meta-information removed, +-- Here is a reduced representation for @Tree@ with nearly all meta-information removed, -- for now keeping only the most essential aspects: -- -- @ @@ -189,7 +189,7 @@ module GHC.Generics ( -- -- Here, 'R' is a type-level proxy that does not have any associated values. -- --- There used to be another variant of 'K1' (namely 'Par0'), but it has since +-- There used to be another variant of 'K1' (namely @Par0@), but it has since -- been deprecated. -- *** Meta information: 'M1' @@ -273,7 +273,7 @@ module GHC.Generics ( -- between the original value and its `Rep`-based representation and then invokes the -- generic instances. -- --- As an example, let us look at a function 'encode' that produces a naive, but lossless +-- As an example, let us look at a function @encode@ that produces a naive, but lossless -- bit encoding of values of various datatypes. So we are aiming to define a function -- -- @ @@ -367,18 +367,15 @@ module GHC.Generics ( -- @ -- -- The case for 'K1' is rather interesting. Here, we call the final function --- 'encode' that we yet have to define, recursively. We will use another type --- class 'Encode' for that function: +-- @encode@ that we yet have to define, recursively. We will use another type +-- class @Encode@ for that function: -- -- @ -- instance (Encode c) => Encode' ('K1' i c) where -- encode' ('K1' x) = encode x -- @ -- --- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define --- a uniform instance here. --- --- Similarly, we can define a uniform instance for 'M1', because we completely +-- Note how we can define a uniform instance for 'M1', because we completely -- disregard all meta-information: -- -- @ @@ -386,13 +383,13 @@ module GHC.Generics ( -- encode' ('M1' x) = encode' x -- @ -- --- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. +-- Unlike in 'K1', the instance for 'M1' refers to @encode'@, not @encode@. -- *** The wrapper and generic default -- -- | -- --- We now define class 'Encode' for the actual 'encode' function: +-- We now define class @Encode@ for the actual @encode@ function: -- -- @ -- class Encode a where @@ -401,9 +398,9 @@ module GHC.Generics ( -- encode x = encode' ('from' x) -- @ -- --- The incoming 'x' is converted using 'from', then we dispatch to the --- generic instances using 'encode''. We use this as a default definition --- for 'encode'. We need the 'default encode' signature because ordinary +-- The incoming @x@ is converted using 'from', then we dispatch to the +-- generic instances using @encode'@. We use this as a default definition +-- for @encode@. We need the @default encode@ signature because ordinary -- Haskell default methods must not introduce additional class constraints, -- but our generic default does. -- @@ -421,10 +418,10 @@ module GHC.Generics ( -- possible to use @deriving Encode@ as well, but GHC does not yet support -- that syntax for this situation. -- --- Having 'Encode' as a class has the advantage that we can define +-- Having @Encode@ as a class has the advantage that we can define -- non-generic special cases, which is particularly useful for abstract -- datatypes that have no structural representation. For example, given --- a suitable integer encoding function 'encodeInt', we can define +-- a suitable integer encoding function @encodeInt@, we can define -- -- @ -- instance Encode Int where @@ -457,7 +454,7 @@ module GHC.Generics ( -- any datatype where each constructor has at least one field. -- -- An 'M1' instance is always required (but it can just ignore the --- meta-information, as is the case for 'encode' above). +-- meta-information, as is the case for @encode@ above). #if 0 -- *** Using meta-information -- @@ -470,14 +467,15 @@ module GHC.Generics ( -- | -- -- Datatype-generic functions as defined above work for a large class --- of datatypes, including parameterized datatypes. (We have used 'Tree' +-- of datatypes, including parameterized datatypes. (We have used @Tree@ -- as our example above, which is of kind @* -> *@.) However, the -- 'Generic' class ranges over types of kind @*@, and therefore, the --- resulting generic functions (such as 'encode') must be parameterized +-- resulting generic functions (such as @encode@) must be parameterized -- by a generic type argument of kind @*@. -- -- What if we want to define generic classes that range over type --- constructors (such as 'Functor', 'Traversable', or 'Foldable')? +-- constructors (such as 'Data.Functor.Functor', +-- 'Data.Traversable.Traversable', or 'Data.Foldable.Foldable')? -- *** The 'Generic1' class -- @@ -491,7 +489,7 @@ module GHC.Generics ( -- The 'Generic1' class is also derivable. -- -- The representation 'Rep1' is ever so slightly different from 'Rep'. --- Let us look at 'Tree' as an example again: +-- Let us look at @Tree@ as an example again: -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) @@ -731,6 +729,7 @@ module GHC.Generics ( -- We use some base types import Data.Either ( Either (..) ) import Data.Maybe ( Maybe(..), fromMaybe ) +import Data.Ord ( Down(..) ) import GHC.Integer ( Integer, integerToInt ) import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Ptr ( Ptr ) @@ -739,10 +738,11 @@ import GHC.Types -- Needed for instances import GHC.Arr ( Ix ) import GHC.Base ( Alternative(..), Applicative(..), Functor(..) - , Monad(..), MonadPlus(..), String, coerce ) + , Monad(..), MonadPlus(..), NonEmpty(..), String, coerce + , Semigroup(..), Monoid(..) ) import GHC.Classes ( Eq(..), Ord(..) ) import GHC.Enum ( Bounded, Enum ) -import GHC.Read ( Read(..), lex, readParen ) +import GHC.Read ( Read(..) ) import GHC.Show ( Show(..), showString ) -- Needed for metadata @@ -755,28 +755,35 @@ import GHC.TypeLits ( Nat, Symbol, KnownSymbol, KnownNat, symbolVal, natVal ) -- | Void: used for datatypes without constructors data V1 (p :: k) - deriving (Functor, Generic, Generic1) - -deriving instance Eq (V1 p) -deriving instance Ord (V1 p) -deriving instance Read (V1 p) -deriving instance Show (V1 p) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.12.0.0 +instance Semigroup (V1 p) where + v <> _ = v -- | Unit: used for constructors without arguments data U1 (p :: k) = U1 - deriving (Generic, Generic1) + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Eq (U1 p) where _ == _ = True --- | @since 4.9.0.0 +-- | @since 4.7.0.0 instance Ord (U1 p) where compare _ _ = EQ -- | @since 4.9.0.0 -instance Read (U1 p) where - readsPrec d = readParen (d > 10) (\r -> [(U1, s) | ("U1",s) <- lex r ]) +deriving instance Read (U1 p) -- | @since 4.9.0.0 instance Show (U1 p) where @@ -804,9 +811,24 @@ instance Monad U1 where -- | @since 4.9.0.0 instance MonadPlus U1 +-- | @since 4.12.0.0 +instance Semigroup (U1 p) where + _ <> _ = U1 + +-- | @since 4.12.0.0 +instance Monoid (U1 p) where + mempty = U1 + -- | Used for marking occurrences of the parameter newtype Par1 p = Par1 { unPar1 :: p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Applicative Par1 where @@ -818,10 +840,23 @@ instance Applicative Par1 where instance Monad Par1 where Par1 x >>= f = f x +-- | @since 4.12.0.0 +deriving instance Semigroup p => Semigroup (Par1 p) + +-- | @since 4.12.0.0 +deriving instance Monoid p => Monoid (Par1 p) + -- | Recursive calls of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@ -- is enabled) -newtype Rec1 (f :: k -> *) (p :: k) = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype Rec1 (f :: k -> Type) (p :: k) = Rec1 { unRec1 :: f p } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 deriving instance Applicative f => Applicative (Rec1 f) @@ -836,9 +871,34 @@ instance Monad f => Monad (Rec1 f) where -- | @since 4.9.0.0 deriving instance MonadPlus f => MonadPlus (Rec1 f) +-- | @since 4.12.0.0 +deriving instance Semigroup (f p) => Semigroup (Rec1 f p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f p) => Monoid (Rec1 f p) + -- | Constants, additional parameters and recursion of kind @*@ -newtype K1 (i :: *) c (p :: k) = K1 { unK1 :: c } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype K1 (i :: Type) c (p :: k) = K1 { unK1 :: c } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) + +-- | @since 4.12.0.0 +instance Monoid c => Applicative (K1 i c) where + pure _ = K1 mempty + liftA2 = \_ -> coerce (mappend :: c -> c -> c) + (<*>) = coerce (mappend :: c -> c -> c) + +-- | @since 4.12.0.0 +deriving instance Semigroup c => Semigroup (K1 i c p) + +-- | @since 4.12.0.0 +deriving instance Monoid c => Monoid (K1 i c p) -- | @since 4.9.0.0 deriving instance Applicative f => Applicative (M1 i c f) @@ -852,19 +912,47 @@ deriving instance Monad f => Monad (M1 i c f) -- | @since 4.9.0.0 deriving instance MonadPlus f => MonadPlus (M1 i c f) +-- | @since 4.12.0.0 +deriving instance Semigroup (f p) => Semigroup (M1 i c f p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f p) => Monoid (M1 i c f p) + -- | Meta-information (constructor names, etc.) -newtype M1 (i :: *) (c :: Meta) (f :: k -> *) (p :: k) = M1 { unM1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype M1 (i :: Type) (c :: Meta) (f :: k -> Type) (p :: k) = + M1 { unM1 :: f p } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Sums: encode choice between constructors infixr 5 :+: -data (:+:) (f :: k -> *) (g :: k -> *) (p :: k) = L1 (f p) | R1 (g p) - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +data (:+:) (f :: k -> Type) (g :: k -> Type) (p :: k) = L1 (f p) | R1 (g p) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Products: encode multiple arguments to constructors infixr 6 :*: -data (:*:) (f :: k -> *) (g :: k -> *) (p :: k) = f p :*: g p - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +data (:*:) (f :: k -> Type) (g :: k -> Type) (p :: k) = f p :*: g p + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Applicative f, Applicative g) => Applicative (f :*: g) where @@ -887,11 +975,26 @@ instance (Monad f, Monad g) => Monad (f :*: g) where -- | @since 4.9.0.0 instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) +-- | @since 4.12.0.0 +instance (Semigroup (f p), Semigroup (g p)) => Semigroup ((f :*: g) p) where + (x1 :*: y1) <> (x2 :*: y2) = (x1 <> x2) :*: (y1 <> y2) + +-- | @since 4.12.0.0 +instance (Monoid (f p), Monoid (g p)) => Monoid ((f :*: g) p) where + mempty = mempty :*: mempty + -- | Composition of functors infixr 7 :.: -newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = +newtype (:.:) (f :: k2 -> Type) (g :: k1 -> k2) (p :: k1) = Comp1 { unComp1 :: f (g p) } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Applicative f, Applicative g) => Applicative (f :.: g) where @@ -905,46 +1008,85 @@ instance (Alternative f, Applicative g) => Alternative (f :.: g) where (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a)) :: forall a . (f :.: g) a -> (f :.: g) a -> (f :.: g) a +-- | @since 4.12.0.0 +deriving instance Semigroup (f (g p)) => Semigroup ((f :.: g) p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f (g p)) => Monoid ((f :.: g) p) + -- | Constants of unlifted kinds -- -- @since 4.9.0.0 -data family URec (a :: *) (p :: k) +data family URec (a :: Type) (p :: k) -- | Used for marking occurrences of 'Addr#' -- -- @since 4.9.0.0 data instance URec (Ptr ()) (p :: k) = UAddr { uAddr# :: Addr# } - deriving (Eq, Ord, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Char#' -- -- @since 4.9.0.0 data instance URec Char (p :: k) = UChar { uChar# :: Char# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Double#' -- -- @since 4.9.0.0 data instance URec Double (p :: k) = UDouble { uDouble# :: Double# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Float#' -- -- @since 4.9.0.0 data instance URec Float (p :: k) = UFloat { uFloat# :: Float# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq, Ord, Show + , Functor -- ^ @since 4.9.0.0 + , Generic + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Int#' -- -- @since 4.9.0.0 data instance URec Int (p :: k) = UInt { uInt# :: Int# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Word#' -- -- @since 4.9.0.0 data instance URec Word (p :: k) = UWord { uWord# :: Word# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Type synonym for @'URec' 'Addr#'@ -- @@ -975,10 +1117,10 @@ type UInt = URec Int -- @since 4.9.0.0 type UWord = URec Word --- | Tag for K1: recursion (of kind @*@) +-- | Tag for K1: recursion (of kind @Type@) data R --- | Type synonym for encoding recursion (of kind @*@) +-- | Type synonym for encoding recursion (of kind @Type@) type Rec0 = K1 R -- | Tag for M1: datatype @@ -1000,17 +1142,17 @@ type S1 = M1 S -- | Class for datatypes that represent datatypes class Datatype d where -- | The name of the datatype (unqualified) - datatypeName :: t d (f :: k -> *) (a :: k) -> [Char] + datatypeName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | The fully-qualified name of the module where the type is declared - moduleName :: t d (f :: k -> *) (a :: k) -> [Char] + moduleName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | The package name of the module where the type is declared -- -- @since 4.9.0.0 - packageName :: t d (f :: k -> *) (a :: k) -> [Char] + packageName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | Marks if the datatype is actually a newtype -- -- @since 4.7.0.0 - isNewtype :: t d (f :: k -> *) (a :: k) -> Bool + isNewtype :: t d (f :: k -> Type) (a :: k) -> Bool isNewtype _ = False -- | @since 4.9.0.0 @@ -1024,14 +1166,14 @@ instance (KnownSymbol n, KnownSymbol m, KnownSymbol p, SingI nt) -- | Class for datatypes that represent data constructors class Constructor c where -- | The name of the constructor - conName :: t c (f :: k -> *) (a :: k) -> [Char] + conName :: t c (f :: k -> Type) (a :: k) -> [Char] -- | The fixity of the constructor - conFixity :: t c (f :: k -> *) (a :: k) -> Fixity + conFixity :: t c (f :: k -> Type) (a :: k) -> Fixity conFixity _ = Prefix -- | Marks if this constructor is a record - conIsRecord :: t c (f :: k -> *) (a :: k) -> Bool + conIsRecord :: t c (f :: k -> Type) (a :: k) -> Bool conIsRecord _ = False -- | @since 4.9.0.0 @@ -1044,7 +1186,12 @@ instance (KnownSymbol n, SingI f, SingI r) -- | 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, Generic) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + , Ord -- ^ @since 4.6.0.0 + , Read -- ^ @since 4.6.0.0 + , Generic -- ^ @since 4.7.0.0 + ) -- | This variant of 'Fixity' appears at the type level. -- @@ -1060,7 +1207,15 @@ prec (Infix _ n) = n data Associativity = LeftAssociative | RightAssociative | NotAssociative - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + , Ord -- ^ @since 4.6.0.0 + , Read -- ^ @since 4.6.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + ) -- | The unpackedness of a field as the user wrote it in the source code. For -- example, in the following data type: @@ -1078,7 +1233,15 @@ data Associativity = LeftAssociative data SourceUnpackedness = NoSourceUnpackedness | SourceNoUnpack | SourceUnpack - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | The strictness of a field as the user wrote it in the source code. For -- example, in the following data type: @@ -1094,7 +1257,15 @@ data SourceUnpackedness = NoSourceUnpackedness data SourceStrictness = NoSourceStrictness | SourceLazy | SourceStrict - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | The strictness that GHC infers for a field during compilation. Whereas -- there are nine different combinations of 'SourceUnpackedness' and @@ -1121,24 +1292,32 @@ data SourceStrictness = NoSourceStrictness data DecidedStrictness = DecidedLazy | DecidedStrict | DecidedUnpack - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | Class for datatypes that represent records class Selector s where -- | The name of the selector - selName :: t s (f :: k -> *) (a :: k) -> [Char] + selName :: t s (f :: k -> Type) (a :: k) -> [Char] -- | The selector's unpackedness annotation (if any) -- -- @since 4.9.0.0 - selSourceUnpackedness :: t s (f :: k -> *) (a :: k) -> SourceUnpackedness + selSourceUnpackedness :: t s (f :: k -> Type) (a :: k) -> SourceUnpackedness -- | The selector's strictness annotation (if any) -- -- @since 4.9.0.0 - selSourceStrictness :: t s (f :: k -> *) (a :: k) -> SourceStrictness + selSourceStrictness :: t s (f :: k -> Type) (a :: k) -> SourceStrictness -- | The strictness that the compiler inferred for the selector -- -- @since 4.9.0.0 - selDecidedStrictness :: t s (f :: k -> *) (a :: k) -> DecidedStrictness + selDecidedStrictness :: t s (f :: k -> Type) (a :: k) -> DecidedStrictness -- | @since 4.9.0.0 instance (SingI mn, SingI su, SingI ss, SingI ds) @@ -1148,11 +1327,18 @@ instance (SingI mn, SingI su, SingI ss, SingI ds) selSourceStrictness _ = fromSing (sing :: Sing ss) selDecidedStrictness _ = fromSing (sing :: Sing ds) --- | Representable types of kind *. --- This class is derivable in GHC with the DeriveGeneric flag on. +-- | Representable types of kind @*@. +-- This class is derivable in GHC with the @DeriveGeneric@ flag on. +-- +-- A 'Generic' instance must satisfy the following laws: +-- +-- @ +-- 'from' . 'to' ≡ 'Prelude.id' +-- 'to' . 'from' ≡ 'Prelude.id' +-- @ class Generic a where -- | Generic representation type - type Rep a :: * -> * + type Rep a :: Type -> Type -- | Convert from the datatype to its representation from :: a -> (Rep a) x -- | Convert from the representation to the datatype @@ -1162,9 +1348,16 @@ class Generic a where -- | Representable types of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@ -- is enabled). -- This class is derivable in GHC with the @DeriveGeneric@ flag on. -class Generic1 (f :: k -> *) where +-- +-- A 'Generic1' instance must satisfy the following laws: +-- +-- @ +-- 'from1' . 'to1' ≡ 'Prelude.id' +-- 'to1' . 'from1' ≡ 'Prelude.id' +-- @ +class Generic1 (f :: k -> Type) where -- | Generic representation type - type Rep1 f :: k -> * + type Rep1 f :: k -> Type -- | Convert from the datatype to its representation from1 :: f a -> (Rep1 f) a -- | Convert from the representation to the datatype @@ -1199,31 +1392,88 @@ data Meta = MetaData Symbol Symbol Symbol Bool -- Derived instances -------------------------------------------------------------------------------- +-- | @since 4.6.0.0 deriving instance Generic [a] + +-- | @since 4.6.0.0 +deriving instance Generic (NonEmpty a) + +-- | @since 4.6.0.0 deriving instance Generic (Maybe a) + +-- | @since 4.6.0.0 deriving instance Generic (Either a b) + +-- | @since 4.6.0.0 deriving instance Generic Bool + +-- | @since 4.6.0.0 deriving instance Generic Ordering + +-- | @since 4.6.0.0 deriving instance Generic (Proxy t) + +-- | @since 4.6.0.0 deriving instance Generic () + +-- | @since 4.6.0.0 deriving instance Generic ((,) a b) + +-- | @since 4.6.0.0 deriving instance Generic ((,,) a b c) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,) a b c d) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,) a b c d e) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,,) a b c d e f) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,,,) a b c d e f g) +-- | @since 4.12.0.0 +deriving instance Generic (Down a) + + +-- | @since 4.6.0.0 deriving instance Generic1 [] + +-- | @since 4.6.0.0 +deriving instance Generic1 NonEmpty + +-- | @since 4.6.0.0 deriving instance Generic1 Maybe + +-- | @since 4.6.0.0 deriving instance Generic1 (Either a) + +-- | @since 4.6.0.0 deriving instance Generic1 Proxy + +-- | @since 4.6.0.0 deriving instance Generic1 ((,) a) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,) a b) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,) a b c) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,) a b c d) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,,) a b c d e) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,,,) a b c d e f) +-- | @since 4.12.0.0 +deriving instance Generic1 Down + -------------------------------------------------------------------------------- -- Copied from the singletons package -------------------------------------------------------------------------------- @@ -1232,8 +1482,6 @@ deriving instance Generic1 ((,,,,,,) a b c d e f) data family Sing (a :: k) -- | A 'SingI' constraint is essentially an implicitly-passed singleton. --- If you need to satisfy this constraint with an explicit singleton, please --- see 'withSingI'. class SingI (a :: k) where -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ -- extension to use this method the way you want. @@ -1245,7 +1493,7 @@ class SingI (a :: k) where class SingKind k where -- | Get a base type from a proxy for the promoted kind. For example, -- @DemoteRep Bool@ will be the type @Bool@. - type DemoteRep k :: * + type DemoteRep k :: Type -- | Convert a singleton to its unrefined version. fromSing :: Sing (a :: k) -> DemoteRep k diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs index 118ebeaeed..6b83cca0d1 100644 --- a/libraries/base/GHC/IO.hs +++ b/libraries/base/GHC/IO.hs @@ -53,8 +53,8 @@ import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError ) -- The IO Monad {- -The IO Monad is just an instance of the ST monad, where the state is -the real world. We use the exception mechanism (in GHC.Exception) to +The IO Monad is just an instance of the ST monad, where the state thread +is the real world. We use the exception mechanism (in GHC.Exception) to implement IO exceptions. NOTE: The IO representation is deeply wired in to various parts of the @@ -84,7 +84,7 @@ failIO s = IO (raiseIO# (toException (userError s))) -- --------------------------------------------------------------------------- -- Coercions between IO and ST --- | Embed a strict state transformer in an 'IO' +-- | Embed a strict state thread in an 'IO' -- action. The 'RealWorld' parameter indicates that the internal state -- used by the 'ST' computation is a special one supplied by the 'IO' -- monad, and thus distinct from those used by invocations of 'runST'. @@ -92,20 +92,20 @@ stToIO :: ST RealWorld a -> IO a stToIO (ST m) = IO m -- | Convert an 'IO' action into an 'ST' action. The type of the result --- is constrained to use a 'RealWorld' state, and therefore the result cannot --- be passed to 'runST'. +-- is constrained to use a 'RealWorld' state thread, and therefore the +-- result cannot be passed to 'runST'. ioToST :: IO a -> ST RealWorld a ioToST (IO m) = (ST m) -- | Convert an 'IO' action to an 'ST' action. -- This relies on 'IO' and 'ST' having the same representation modulo the --- constraint on the type of the state. +-- constraint on the state thread type parameter. unsafeIOToST :: IO a -> ST s a unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s -- | Convert an 'ST' action to an 'IO' action. -- This relies on 'IO' and 'ST' having the same representation modulo the --- constraint on the type of the state. +-- constraint on the state thread type parameter. -- -- For an example demonstrating why this is unsafe, see -- https://mail.haskell.org/pipermail/haskell-cafe/2009-April/060719.html @@ -279,7 +279,9 @@ data MaskingState -- ^ the state during 'mask': asynchronous exceptions are masked, but blocking operations may still be interrupted | MaskedUninterruptible -- ^ the state during 'uninterruptibleMask': asynchronous exceptions are masked, and blocking operations may not be interrupted - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | Returns the 'MaskingState' for the current thread. getMaskingState :: IO MaskingState @@ -334,7 +336,7 @@ onException io what = io `catchException` \e -> do _ <- what -- 'MaskedInterruptible' state, -- use @mask_ $ forkIO ...@. This is particularly useful if you need -- to establish an exception handler in the forked thread before any --- asynchronous exceptions are received. To create a a new thread in +-- asynchronous exceptions are received. To create a new thread in -- an unmasked state use 'Control.Concurrent.forkIOWithUnmask'. -- mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b diff --git a/libraries/base/GHC/IO.hs-boot b/libraries/base/GHC/IO.hs-boot index 88b09aafb0..aa2e5ccd2d 100644 --- a/libraries/base/GHC/IO.hs-boot +++ b/libraries/base/GHC/IO.hs-boot @@ -4,6 +4,7 @@ module GHC.IO where import GHC.Types +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base failIO :: [Char] -> IO a mplusIO :: IO a -> IO a -> IO a diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs index 33eee6363d..447c574e2b 100644 --- a/libraries/base/GHC/IO/Buffer.hs +++ b/libraries/base/GHC/IO/Buffer.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Trustworthy, BangPatterns #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -192,7 +192,8 @@ type CharBuffer = Buffer Word16 type CharBuffer = Buffer Char #endif -data BufferState = ReadBuffer | WriteBuffer deriving (Eq) +data BufferState = ReadBuffer | WriteBuffer + deriving Eq -- ^ @since 4.2.0.0 withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f @@ -264,7 +265,8 @@ foreign import ccall unsafe "memmove" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) summaryBuffer :: Buffer a -> String -summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" +summaryBuffer !buf -- Strict => slightly better code + = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" -- INVARIANTS on Buffers: -- * r <= w diff --git a/libraries/base/GHC/IO/BufferedIO.hs b/libraries/base/GHC/IO/BufferedIO.hs index 4c81d9a4ec..cd38cefe07 100644 --- a/libraries/base/GHC/IO/BufferedIO.hs +++ b/libraries/base/GHC/IO/BufferedIO.hs @@ -32,8 +32,8 @@ import GHC.IO.Buffer -- | The purpose of 'BufferedIO' is to provide a common interface for I/O -- devices that can read and write data through a buffer. Devices that -- implement 'BufferedIO' include ordinary files, memory-mapped files, --- and bytestrings. The underlying device implementing a 'Handle' must --- provide 'BufferedIO'. +-- and bytestrings. The underlying device implementing a 'System.IO.Handle' +-- must provide 'BufferedIO'. -- class BufferedIO dev where -- | allocate a new buffer. The size of the buffer is at the diff --git a/libraries/base/GHC/IO/Device.hs b/libraries/base/GHC/IO/Device.hs index ddeb861eca..e33dcd02b1 100644 --- a/libraries/base/GHC/IO/Device.hs +++ b/libraries/base/GHC/IO/Device.hs @@ -56,7 +56,7 @@ class RawIO a where writeNonBlocking :: a -> Ptr Word8 -> Int -> IO Int --- | I/O operations required for implementing a 'Handle'. +-- | I/O operations required for implementing a 'System.IO.Handle'. class IODevice a where -- | @ready dev write msecs@ returns 'True' if the device has data -- to read (if @write@ is 'False') or space to write new data (if @@ -154,17 +154,24 @@ data IODeviceType -- read and write operations and may be seekable only -- to positions of certain granularity (block- -- aligned). - deriving (Eq) + deriving ( Eq -- ^ @since 4.2.0.0 + ) -- ----------------------------------------------------------------------------- -- SeekMode type --- | A mode that determines the effect of 'hSeek' @hdl mode i@. +-- | A mode that determines the effect of 'System.IO.hSeek' @hdl mode i@. data SeekMode = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@. | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@ -- from the current position. | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ -- from the end of the file. - deriving (Eq, Ord, Ix, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Ix -- ^ @since 4.2.0.0 + , Enum -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) diff --git a/libraries/base/GHC/IO/Encoding.hs b/libraries/base/GHC/IO/Encoding.hs index 578a420faf..b734f00f5b 100644 --- a/libraries/base/GHC/IO/Encoding.hs +++ b/libraries/base/GHC/IO/Encoding.hs @@ -27,6 +27,7 @@ module GHC.IO.Encoding ( setLocaleEncoding, setFileSystemEncoding, setForeignEncoding, char8, mkTextEncoding, + argvEncoding ) where import GHC.Base @@ -56,7 +57,8 @@ import System.IO.Unsafe (unsafePerformIO) -- | The Latin1 (ISO8859-1) encoding. This encoding maps bytes -- directly to the first 256 Unicode code points, and is thus not a -- complete Unicode encoding. An attempt to write a character greater than --- '\255' to a 'Handle' using the 'latin1' encoding will result in an error. +-- '\255' to a 'System.IO.Handle' using the 'latin1' encoding will result in an +-- error. latin1 :: TextEncoding latin1 = Latin1.latin1_checked @@ -121,7 +123,7 @@ getFileSystemEncoding :: IO TextEncoding -- | The Unicode encoding of the current locale, but where undecodable -- bytes are replaced with their closest visual match. Used for --- the 'CString' marshalling functions in "Foreign.C.String" +-- the 'Foreign.C.String.CString' marshalling functions in "Foreign.C.String" -- -- @since 4.5.0.0 getForeignEncoding :: IO TextEncoding @@ -161,6 +163,17 @@ initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure initForeignEncoding = CodePage.mkLocaleEncoding IgnoreCodingFailure #endif +-- See Note [Windows Unicode Arguments] in rts/RtsFlags.c +-- On Windows we assume hs_init argv is in utf8 encoding. + +-- | Internal encoding of argv +argvEncoding :: IO TextEncoding +#if defined(mingw32_HOST_OS) +argvEncoding = return utf8 +#else +argvEncoding = getFileSystemEncoding +#endif + -- | An encoding in which Unicode code points are translated to bytes -- by taking the code point modulo 256. When decoding, bytes are -- translated directly into the equivalent code point. @@ -175,7 +188,7 @@ char8 = Latin1.latin1 -- | Look up the named Unicode encoding. May fail with -- --- * 'isDoesNotExistError' if the encoding is unknown +-- * 'System.IO.Error.isDoesNotExistError' if the encoding is unknown -- -- The set of known encodings is system-dependent, but includes at least: -- diff --git a/libraries/base/GHC/IO/Encoding/CodePage/API.hs b/libraries/base/GHC/IO/Encoding/CodePage/API.hs index f1d9d93e8f..b31ebe96f5 100644 --- a/libraries/base/GHC/IO/Encoding/CodePage/API.hs +++ b/libraries/base/GHC/IO/Encoding/CodePage/API.hs @@ -285,7 +285,7 @@ cpEncode cp _max_char_size = \ibuf obuf -> do return (why2, mbuf', obuf) #else case why2 of - -- If we succesfully translate all of the UTF-16 buffer, we need to know why + -- If we successfully translate all of the UTF-16 buffer, we need to know why -- we weren't able to get any more UTF-16 out of the UTF-32 buffer InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf) | otherwise -> errorWithoutStackTrace "cpEncode: impossible underflown UTF-16 buffer" @@ -361,7 +361,7 @@ bSearch msg code ibuf mbuf target_to_elems = go -- -- Luckily if we have InvalidSequence/OutputUnderflow and we do not appear to have reached -- the target, what we should do is the same as normal because the fraction of ibuf that our - -- first "code" coded succesfully must be invalid-sequence-free, and ibuf will always + -- first "code" coded successfully must be invalid-sequence-free, and ibuf will always -- have been decoded as far as the first invalid sequence in it. case bufferElems mbuf `compare` target_to_elems of -- Coding n "from" chars from the input yields exactly as many "to" chars diff --git a/libraries/base/GHC/IO/Encoding/Failure.hs b/libraries/base/GHC/IO/Encoding/Failure.hs index 3f9360d731..c8d29f4d50 100644 --- a/libraries/base/GHC/IO/Encoding/Failure.hs +++ b/libraries/base/GHC/IO/Encoding/Failure.hs @@ -34,8 +34,8 @@ import GHC.Real ( fromIntegral ) --import System.Posix.Internals --- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and --- specifies how they handle illegal sequences. +-- | The 'CodingFailureMode' is used to construct 'System.IO.TextEncoding's, +-- and specifies how they handle illegal sequences. data CodingFailureMode = ErrorOnCodingFailure -- ^ Throw an error when an illegal sequence is encountered @@ -48,7 +48,8 @@ data CodingFailureMode | RoundtripFailure -- ^ Use the private-use escape mechanism to attempt to allow -- illegal sequences to be roundtripped. - deriving (Show) + deriving ( Show -- ^ @since 4.4.0.0 + ) -- This will only work properly for those encodings which are -- strict supersets of ASCII in the sense that valid ASCII data -- is also valid in that encoding. This is not true for diff --git a/libraries/base/GHC/IO/Encoding/Types.hs b/libraries/base/GHC/IO/Encoding/Types.hs index daab9d5157..2f8ffd5e59 100644 --- a/libraries/base/GHC/IO/Encoding/Types.hs +++ b/libraries/base/GHC/IO/Encoding/Types.hs @@ -103,11 +103,11 @@ type TextEncoder state = BufferCodec CharBufElem Word8 state -- between sequences of bytes and sequences of Unicode characters. -- -- For example, UTF-8 is an encoding of Unicode characters into a sequence --- of bytes. The 'TextEncoding' for UTF-8 is 'utf8'. +-- of bytes. The 'TextEncoding' for UTF-8 is 'System.IO.utf8'. data TextEncoding = forall dstate estate . TextEncoding { textEncodingName :: String, - -- ^ a string that can be passed to 'mkTextEncoding' to + -- ^ a string that can be passed to 'System.IO.mkTextEncoding' to -- create an equivalent 'TextEncoding'. mkTextDecoder :: IO (TextDecoder dstate), -- ^ Creates a means of decoding bytes into characters: the result must not @@ -129,5 +129,7 @@ data CodingProgress = InputUnderflow -- ^ Stopped because the input contains in | InvalidSequence -- ^ Stopped because there are sufficient free elements in the output -- to output at least one encoded ASCII character, but the input contains -- an invalid or unrepresentable sequence - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs index 9203f46828..bd9a15216d 100644 --- a/libraries/base/GHC/IO/Exception.hs +++ b/libraries/base/GHC/IO/Exception.hs @@ -33,6 +33,7 @@ module GHC.IO.Exception ( ArrayException(..), ExitCode(..), + FixIOException (..), ioException, ioError, @@ -225,7 +226,9 @@ data AsyncException -- ^This exception is raised by default in the main thread of -- the program when the user requests to terminate the program -- via the usual mechanism(s) (e.g. Control-C in the console). - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + ) -- | @since 4.7.0.0 instance Exception AsyncException where @@ -240,7 +243,9 @@ data ArrayException | UndefinedElement String -- ^An attempt was made to evaluate an element of an -- array that had not been initialized. - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + ) -- | @since 4.1.0.0 instance Exception ArrayException @@ -268,6 +273,19 @@ instance Show ArrayException where . (if not (null s) then showString ": " . showString s else id) +-- | The exception thrown when an infinite cycle is detected in +-- 'System.IO.fixIO'. +-- +-- @since 4.11.0.0 +data FixIOException = FixIOException + +-- | @since 4.11.0.0 +instance Exception FixIOException + +-- | @since 4.11.0.0 +instance Show FixIOException where + showsPrec _ FixIOException = showString "cyclic evaluation in fixIO" + -- ----------------------------------------------------------------------------- -- The ExitCode type diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index 8eafe08fdc..d5567f0838 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -45,6 +45,7 @@ import GHC.Conc.IO import GHC.IO.Exception #if defined(mingw32_HOST_OS) import GHC.Windows +import Data.Bool #endif import Foreign @@ -179,14 +180,10 @@ openFile filepath iomode non_blocking = | otherwise = oflags2 in do - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- directories. However, the man pages I've read say that open() - -- always returns EISDIR if the file is a directory and was opened - -- for writing, so I think we're ok with a single open() here... - fd <- throwErrnoIfMinus1Retry "openFile" - (if non_blocking then c_open f oflags 0o666 - else c_safe_open f oflags 0o666) + -- NB. always use a safe open(), because we don't know whether open() + -- will be fast or not. It can be slow on NFS and FUSE filesystems, + -- for example. + fd <- throwErrnoIfMinus1Retry "openFile" $ c_safe_open f oflags 0o666 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-} False{-not a socket-} @@ -405,7 +402,7 @@ ready fd write msecs = do return (toEnum (fromIntegral r)) foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt -- --------------------------------------------------------------------------- -- Terminal-related stuff @@ -566,7 +563,7 @@ isNonBlocking :: FD -> Bool isNonBlocking fd = fdIsNonBlocking fd /= 0 foreign import ccall unsafe "fdReady" - unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt #else /* mingw32_HOST_OS.... */ @@ -593,8 +590,10 @@ asyncReadRawBufferPtr loc !fd !buf !off !len = do (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt @@ -602,34 +601,46 @@ asyncWriteRawBufferPtr loc !fd !buf !off !len = do (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) -- Blocking versions of the read/write primitives, for the threaded RTS blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt blockingReadRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len) + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0 + read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len) + r <- bool read_ret recv_ret (fdIsSocket fd) + when ((fdIsSocket fd) && (r == -1)) c_maperrno + return r + -- We trust read() to give us the correct errno but recv(), as a + -- Winsock function, doesn't do the errno conversion so if the fd + -- is for a socket, we do it from GetLastError() ourselves. blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt blockingWriteRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else do - r <- c_safe_write (fdFD fd) (buf `plusPtr` off) (fromIntegral len) - when (r == -1) c_maperrno - return r - -- we don't trust write() to give us the correct errno, and + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0 + write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len) + r <- bool write_ret send_ret (fdIsSocket fd) + when (r == -1) c_maperrno + return r + -- We don't trust write() to give us the correct errno, and -- instead do the errno conversion from GetLastError() - -- ourselves. The main reason is that we treat ERROR_NO_DATA + -- ourselves. The main reason is that we treat ERROR_NO_DATA -- (pipe is closing) as EPIPE, whereas write() returns EINVAL - -- for this case. We need to detect EPIPE correctly, because it + -- for this case. We need to detect EPIPE correctly, because it -- shouldn't be reported as an error when it happens on stdout. + -- As for send()'s case, Winsock functions don't do errno + -- conversion in any case so we have to do it ourselves. + -- That means we're doing the errno conversion no matter if the + -- fd is from a socket or not. -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs index 648523a11f..01c226dfbd 100644 --- a/libraries/base/GHC/IO/Handle.hs +++ b/libraries/base/GHC/IO/Handle.hs @@ -183,7 +183,7 @@ isEOF = hIsEOF stdin -- -- This operation may fail with: -- --- * 'isEOFError' if the end of file has been reached. +-- * 'System.IO.Error.isEOFError' if the end of file has been reached. hLookAhead :: Handle -> IO Char hLookAhead handle = @@ -208,9 +208,9 @@ hLookAhead handle = -- -- This operation may fail with: -- --- * 'isPermissionError' if the handle has already been used for reading --- or writing and the implementation does not allow the buffering mode --- to be changed. +-- * 'System.IO.Error.isPermissionError' if the handle has already been used +-- for reading or writing and the implementation does not allow the +-- buffering mode to be changed. hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = @@ -251,8 +251,8 @@ hSetBuffering handle mode = -- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding -- for the handle @hdl@ to @encoding@. The default encoding when a 'Handle' is --- created is 'localeEncoding', namely the default encoding for the current --- locale. +-- created is 'System.IO.localeEncoding', namely the default encoding for the +-- current locale. -- -- To create a 'Handle' with no encoding at all, use 'openBinaryFile'. To -- stop further encoding or decoding on an existing 'Handle', use @@ -295,11 +295,11 @@ hGetEncoding hdl = -- -- This operation may fail with: -- --- * 'isFullError' if the device is full; +-- * 'System.IO.Error.isFullError' if the device is full; -- --- * 'isPermissionError' if a system resource limit would be exceeded. --- It is unspecified whether the characters in the buffer are discarded --- or retained under these circumstances. +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. It is unspecified whether the characters in the buffer are +-- discarded or retained under these circumstances. hFlush :: Handle -> IO () hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer @@ -312,14 +312,14 @@ hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer -- -- This operation may fail with: -- --- * 'isFullError' if the device is full; +-- * 'System.IO.Error.isFullError' if the device is full; -- --- * 'isPermissionError' if a system resource limit would be exceeded. --- It is unspecified whether the characters in the buffer are discarded --- or retained under these circumstances; +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. It is unspecified whether the characters in the buffer are +-- discarded or retained under these circumstances; -- --- * 'isIllegalOperation' if @hdl@ has buffered read data, and is not --- seekable. +-- * 'System.IO.Error.isIllegalOperation' if @hdl@ has buffered read data, and +-- is not seekable. hFlushAll :: Handle -> IO () hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer @@ -358,7 +358,8 @@ hGetPosn handle = do -- -- This operation may fail with: -- --- * 'isPermissionError' if a system resource limit would be exceeded. +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. hSetPosn :: HandlePosn -> IO () hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i @@ -391,10 +392,11 @@ hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i -- -- This operation may fail with: -- --- * 'isIllegalOperationError' if the Handle is not seekable, or does --- not support the requested seek mode. +-- * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable, +-- or does not support the requested seek mode. -- --- * 'isPermissionError' if a system resource limit would be exceeded. +-- * 'System.IO.Error.isPermissionError' if a system resource limit would be +-- exceeded. hSeek :: Handle -> SeekMode -> Integer -> IO () hSeek handle mode offset = @@ -425,7 +427,7 @@ hSeek handle mode offset = -- -- This operation may fail with: -- --- * 'isIllegalOperationError' if the Handle is not seekable. +-- * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable. -- hTell :: Handle -> IO Integer hTell handle = diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs index 786fccc4f1..883bc5fe59 100644 --- a/libraries/base/GHC/IO/Handle/FD.hs +++ b/libraries/base/GHC/IO/Handle/FD.hs @@ -128,11 +128,13 @@ addFilePathToIOError fun fp ioe -- -- This operation may fail with: -- --- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; +-- * 'System.IO.Error.isAlreadyInUseError' if the file is already open and +-- cannot be reopened; -- --- * 'isDoesNotExistError' if the file does not exist; or +-- * 'System.IO.Error.isDoesNotExistError' if the file does not exist; or -- --- * 'isPermissionError' if the user does not have permission to open the file. +-- * 'System.IO.Error.isPermissionError' if the user does not have permission +-- to open the file. -- -- Note: if you will be working with files containing binary data, you'll want to -- be using 'openBinaryFile'. @@ -161,7 +163,7 @@ openFileBlocking fp im = -- this is undesirable; also, as usual under Microsoft operating systems, -- text mode treats control-Z as EOF. Binary mode turns off all special -- treatment of end-of-line and end-of-file characters. --- (See also 'hSetBinaryMode'.) +-- (See also 'System.IO.hSetBinaryMode'.) openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc index ec62f86cc9..ec85ffd25e 100644 --- a/libraries/base/GHC/IO/Handle/Lock.hsc +++ b/libraries/base/GHC/IO/Handle/Lock.hsc @@ -8,6 +8,7 @@ module GHC.IO.Handle.Lock ( , LockMode(..) , hLock , hTryLock + , hUnlock ) where #include "HsBaseConfig.h" @@ -62,8 +63,9 @@ import GHC.Show -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported - deriving Show + deriving Show -- ^ @since 4.10.0.0 +-- ^ @since 4.10.0.0 instance Exception FileLockingNotSupported -- | Indicates a mode in which a file should be locked. @@ -97,9 +99,82 @@ hLock h mode = void $ lockImpl h "hLock" mode True hTryLock :: Handle -> LockMode -> IO Bool hTryLock h mode = lockImpl h "hTryLock" mode False +-- | Release a lock taken with 'hLock' or 'hTryLock'. +hUnlock :: Handle -> IO () +hUnlock = unlockImpl + ---------------------------------------- -#if HAVE_FLOCK +#if HAVE_OFD_LOCKING +-- Linux open file descriptor locking. +-- +-- We prefer this over BSD locking (e.g. flock) since the latter appears to +-- break in some NFS configurations. Note that we intentionally do not try to +-- use ordinary POSIX file locking due to its peculiar semantics under +-- multi-threaded environments. + +foreign import ccall interruptible "fcntl" + c_fcntl :: CInt -> CInt -> Ptr () -> IO CInt + +data FLock = FLock { l_type :: CShort + , l_whence :: CShort + , l_start :: COff + , l_len :: COff + , l_pid :: CPid + } + +instance Storable FLock where + sizeOf _ = #{size flock} + alignment _ = #{alignment flock} + poke ptr x = do + fillBytes ptr 0 (sizeOf x) + #{poke flock, l_type} ptr (l_type x) + #{poke flock, l_whence} ptr (l_whence x) + #{poke flock, l_start} ptr (l_start x) + #{poke flock, l_len} ptr (l_len x) + #{poke flock, l_pid} ptr (l_pid x) + peek ptr = do + FLock <$> #{peek flock, l_type} ptr + <*> #{peek flock, l_whence} ptr + <*> #{peek flock, l_start} ptr + <*> #{peek flock, l_len} ptr + <*> #{peek flock, l_pid} ptr + +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl h ctx mode block = do + FD{fdFD = fd} <- handleToFd h + with flock $ \flock_ptr -> fix $ \retry -> do + ret <- with flock $ fcntl fd mode flock_ptr + case ret of + 0 -> return True + _ -> getErrno >>= \errno -> if + | not block && errno == eWOULDBLOCK -> return False + | errno == eINTR -> retry + | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing + where + flock = FLock { l_type = case mode of + SharedLock -> #{const F_RDLCK} + ExclusiveLock -> #{const F_WRLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + mode + | block = #{const F_SETLKW} + | otherwise = #{const F_SETLK} + +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + let flock = FLock { l_type = #{const F_UNLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + throwErrnoIfMinus1_ "hUnlock" + $ with flock $ c_fcntl fd #{const F_SETLK} + +#elif HAVE_FLOCK lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do @@ -108,7 +183,8 @@ lockImpl h ctx mode block = do fix $ \retry -> c_flock fd flags >>= \case 0 -> return True _ -> getErrno >>= \errno -> if - | not block && errno == eWOULDBLOCK -> return False + | not block + , errno == eAGAIN || errno == eACCES -> return False | errno == eINTR -> retry | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing where @@ -116,6 +192,11 @@ lockImpl h ctx mode block = do SharedLock -> #{const LOCK_SH} ExclusiveLock -> #{const LOCK_EX} +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN} + foreign import ccall interruptible "flock" c_flock :: CInt -> CInt -> IO CInt @@ -146,6 +227,18 @@ lockImpl h ctx mode block = do SharedLock -> 0 ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd + allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do + fillBytes ovrlpd 0 sizeof_OVERLAPPED + c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case + True -> return () + False -> getLastError >>= failWith "hUnlock" + where + sizeof_OVERLAPPED = #{size OVERLAPPED} + -- https://msdn.microsoft.com/en-us/library/aa297958.aspx foreign import ccall unsafe "_get_osfhandle" c_get_osfhandle :: CInt -> IO HANDLE @@ -154,10 +247,18 @@ foreign import ccall unsafe "_get_osfhandle" foreign import WINDOWS_CCONV interruptible "LockFileEx" c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx +foreign import WINDOWS_CCONV interruptible "UnlockFileEx" + c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL + #else -- | No-op implementation. lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl _ _ _ _ = throwIO FileLockingNotSupported +-- | No-op implementation. +unlockImpl :: Handle -> IO () +unlockImpl _ = throwIO FileLockingNotSupported + #endif diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs index 57b9534976..dcf4b7c174 100644 --- a/libraries/base/GHC/IO/Handle/Text.hs +++ b/libraries/base/GHC/IO/Handle/Text.hs @@ -353,10 +353,10 @@ unpack_nl !buf !r !w acc0 -- list returned by 'hGetContents' @hdl@. -- -- Any operation that fails because a handle is closed, --- also fails if a handle is semi-closed. The only exception is 'hClose'. --- A semi-closed handle becomes closed: +-- also fails if a handle is semi-closed. The only exception is +-- 'System.IO.hClose'. A semi-closed handle becomes closed: -- --- * if 'hClose' is applied to it; +-- * if 'System.IO.hClose' is applied to it; -- -- * if an I\/O error occurs when reading an item from the handle; -- @@ -537,6 +537,7 @@ hPutStrLn handle str = hPutStr' handle str True -- overhead of a single putChar '\n', which is quite high now that we -- have to encode eagerly. +{-# NOINLINE hPutStr' #-} hPutStr' :: Handle -> String -> Bool -> IO () hPutStr' handle str add_nl = do @@ -683,7 +684,7 @@ commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..} -- 'hPutBuf' ignores any text encoding that applies to the 'Handle', -- writing the bytes directly to the underlying file or device. -- --- 'hPutBuf' ignores the prevailing 'TextEncoding' and +-- 'hPutBuf' ignores the prevailing 'System.IO.TextEncoding' and -- 'NewlineMode' on the 'Handle', and writes bytes directly. -- -- This operation may fail with: @@ -803,11 +804,11 @@ writeChunkNonBlocking h_@Handle__{..} ptr bytes -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBuf' will behave as if EOF was reached. -- --- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode' +-- 'hGetBuf' ignores the prevailing 'System.IO.TextEncoding' and 'NewlineMode' -- on the 'Handle', and reads bytes directly. hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf h ptr count +hGetBuf h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = @@ -885,11 +886,11 @@ bufReadEmpty h_@Handle__{..} -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBufSome' will behave as if EOF was reached. -- --- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode' --- on the 'Handle', and reads bytes directly. +-- 'hGetBufSome' ignores the prevailing 'System.IO.TextEncoding' and +-- 'NewlineMode' on the 'Handle', and reads bytes directly. hGetBufSome :: Handle -> Ptr a -> Int -> IO Int -hGetBufSome h ptr count +hGetBufSome h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBufSome" count | otherwise = @@ -927,14 +928,14 @@ haFD h_@Handle__{..} = cast haDevice -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. -- --- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and +-- 'hGetBufNonBlocking' ignores the prevailing 'System.IO.TextEncoding' and -- 'NewlineMode' on the 'Handle', and reads bytes directly. -- -- NOTE: on Windows, this function does not work correctly; it -- behaves identically to 'hGetBuf'. hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count +hGetBufNonBlocking h !ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count | otherwise = diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs index c58a9fb1b0..d38962e77e 100644 --- a/libraries/base/GHC/IO/Handle/Types.hs +++ b/libraries/base/GHC/IO/Handle/Types.hs @@ -247,7 +247,11 @@ data BufferMode -- ^ block-buffering should be enabled if possible. -- The size of the buffer is @n@ items if the argument -- is 'Just' @n@ and is otherwise implementation-dependent. - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) {- [note Buffering Implementation] @@ -349,7 +353,11 @@ and hence it is only possible on a seekable Handle. -- | The representation of a newline in the external file or stream. data Newline = LF -- ^ '\n' | CRLF -- ^ '\r\n' - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | Specifies the translation, if any, of newline characters between -- internal Strings and the external file or stream. Haskell Strings @@ -362,7 +370,11 @@ data NewlineMode outputNL :: Newline -- ^ the representation of newlines on output } - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | The native newline representation for the current platform: 'LF' -- on Unix systems, 'CRLF' on Windows. diff --git a/libraries/base/GHC/IO/IOMode.hs b/libraries/base/GHC/IO/IOMode.hs index 42cc9f31b1..7eb848f50a 100644 --- a/libraries/base/GHC/IO/IOMode.hs +++ b/libraries/base/GHC/IO/IOMode.hs @@ -26,5 +26,11 @@ import GHC.Enum -- | See 'System.IO.openFile' data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Ix -- ^ @since 4.2.0.0 + , Enum -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) diff --git a/libraries/base/GHC/IO/Unsafe.hs b/libraries/base/GHC/IO/Unsafe.hs index c1c07ae2df..039acfe85b 100644 --- a/libraries/base/GHC/IO/Unsafe.hs +++ b/libraries/base/GHC/IO/Unsafe.hs @@ -96,7 +96,8 @@ times (on a multiprocessor), and you should therefore ensure that it gives the same results each time. It may even happen that one of the duplicated IO actions is only run partially, and then interrupted in the middle without an exception being raised. Therefore, functions -like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'. +like 'Control.Exception.bracket' cannot be used safely within +'unsafeDupablePerformIO'. @since 4.4.0.0 -} diff --git a/libraries/base/GHC/IORef.hs b/libraries/base/GHC/IORef.hs index 0832be04cf..d04ae728fd 100644 --- a/libraries/base/GHC/IORef.hs +++ b/libraries/base/GHC/IORef.hs @@ -1,6 +1,7 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -19,7 +20,9 @@ module GHC.IORef ( IORef(..), - newIORef, readIORef, writeIORef, atomicModifyIORef + newIORef, readIORef, writeIORef, atomicModifyIORef2Lazy, + atomicModifyIORef2, atomicModifyIORefLazy_, atomicModifyIORef'_, + atomicModifyIORefP, atomicSwapIORef, atomicModifyIORef' ) where import GHC.Base @@ -31,7 +34,7 @@ import GHC.IO -- |A mutable variable in the 'IO' monad newtype IORef a = IORef (STRef RealWorld a) - deriving Eq + deriving Eq -- ^ @since 4.2.0.0 -- ^ Pointer equality. -- -- @since 4.1.0.0 @@ -48,6 +51,120 @@ readIORef (IORef var) = stToIO (readSTRef var) writeIORef :: IORef a -> a -> IO () writeIORef (IORef var) v = stToIO (writeSTRef var v) -atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s +-- Atomically apply a function to the contents of an 'IORef', +-- installing its first component in the 'IORef' and returning +-- the old contents and the result of applying the function. +-- The result of the function application (the pair) is not forced. +-- As a result, this can lead to memory leaks. It is generally better +-- to use 'atomicModifyIORef2'. +atomicModifyIORef2Lazy :: IORef a -> (a -> (a,b)) -> IO (a, (a, b)) +atomicModifyIORef2Lazy (IORef (STRef r#)) f = + IO (\s -> case atomicModifyMutVar2# r# f s of + (# s', old, res #) -> (# s', (old, res) #)) +-- Atomically apply a function to the contents of an 'IORef', +-- installing its first component in the 'IORef' and returning +-- the old contents and the result of applying the function. +-- The result of the function application (the pair) is forced, +-- but neither of its components is. +atomicModifyIORef2 :: IORef a -> (a -> (a,b)) -> IO (a, (a, b)) +atomicModifyIORef2 ref f = do + r@(_old, (_new, _res)) <- atomicModifyIORef2Lazy ref f + return r + +-- | A version of 'Data.IORef.atomicModifyIORef' that forces +-- the (pair) result of the function. +atomicModifyIORefP :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORefP ref f = do + (_old, (_,r)) <- atomicModifyIORef2 ref f + pure r + +-- | Atomically apply a function to the contents of an +-- 'IORef' and return the old and new values. The result +-- of the function is not forced. As this can lead to a +-- memory leak, it is usually better to use `atomicModifyIORef'_`. +atomicModifyIORefLazy_ :: IORef a -> (a -> a) -> IO (a, a) +atomicModifyIORefLazy_ (IORef (STRef ref)) f = IO $ \s -> + case atomicModifyMutVar_# ref f s of + (# s', old, new #) -> (# s', (old, new) #) + +-- | Atomically apply a function to the contents of an +-- 'IORef' and return the old and new values. The result +-- of the function is forced. +atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO (a, a) +atomicModifyIORef'_ ref f = do + (old, !new) <- atomicModifyIORefLazy_ ref f + return (old, new) + +-- | Atomically replace the contents of an 'IORef', returning +-- the old contents. +atomicSwapIORef :: IORef a -> a -> IO a +-- Bad implementation! This will be a primop shortly. +atomicSwapIORef (IORef (STRef ref)) new = IO $ \s -> + case atomicModifyMutVar2# ref (\_old -> Box new) s of + (# s', old, Box _new #) -> (# s', old #) + +data Box a = Box a + +-- | Strict version of 'Data.IORef.atomicModifyIORef'. This forces both +-- the value stored in the 'IORef' and the value returned. The new value +-- is installed in the 'IORef' before the returned value is forced. +-- So +-- +-- @atomicModifyIORef' ref (\x -> (x+1, undefined))@ +-- +-- will increment the 'IORef' and then throw an exception in the calling +-- thread. +-- +-- @since 4.6.0.0 +atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +-- See Note [atomicModifyIORef' definition] +atomicModifyIORef' ref f = do + (_old, (_new, !res)) <- atomicModifyIORef2 ref $ + \old -> case f old of + r@(!_new, _res) -> r + pure res + +-- Note [atomicModifyIORef' definition] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- atomicModifyIORef' was historically defined +-- +-- atomicModifyIORef' ref f = do +-- b <- atomicModifyIORef ref $ \a -> +-- case f a of +-- v@(a',_) -> a' `seq` v +-- b `seq` return b +-- +-- The most obvious definition, now that we have atomicModifyMutVar2#, +-- would be +-- +-- atomicModifyIORef' ref f = do +-- (_old, (!_new, !res)) <- atomicModifyIORef2 ref f +-- pure res +-- +-- Why do we force the new value on the "inside" instead of afterwards? +-- I initially thought the latter would be okay, but then I realized +-- that if we write +-- +-- atomicModifyIORef' ref $ \x -> (x + 5, x - 5) +-- +-- then we'll end up building a pair of thunks to calculate x + 5 +-- and x - 5. That's no good! With the more complicated definition, +-- we avoid this problem; the result pair is strict in the new IORef +-- contents. Of course, if the function passed to atomicModifyIORef' +-- doesn't inline, we'll build a closure for it. But that was already +-- true for the historical definition of atomicModifyIORef' (in terms +-- of atomicModifyIORef), so we shouldn't lose anything. Note that +-- in keeping with the historical behavior, we *don't* propagate the +-- strict demand on the result inwards. In particular, +-- +-- atomicModifyIORef' ref (\x -> (x + 1, undefined)) +-- +-- will increment the IORef and throw an exception; it will not +-- install an undefined value in the IORef. +-- +-- A clearer version, in my opinion (but one quite incompatible with +-- the traditional one) would only force the new IORef value and not +-- the result. This version would have been relatively inefficient +-- to implement using atomicModifyMutVar#, but is just fine now. diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index ad2a872c39..9bc161105d 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -1082,6 +1082,36 @@ instance Ix Int64 where unsafeIndex (m,_) i = fromIntegral i - fromIntegral m inRange (m,n) i = m <= i && i <= n +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Int8" + fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt +"fromIntegral/Natural->Int16" + fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt +"fromIntegral/Natural->Int32" + fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt + #-} + +{-# RULES +"fromIntegral/Int8->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) +"fromIntegral/Int16->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) +"fromIntegral/Int32->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 & Int==Int64 +{-# RULES +"fromIntegral/Natural->Int64" + fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt +"fromIntegral/Int64->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) + #-} +#endif + {- Note [Order of tests] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs index 70bfbe4de0..92b5952cbe 100644 --- a/libraries/base/GHC/List.hs +++ b/libraries/base/GHC/List.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -23,7 +22,7 @@ module GHC.List ( map, (++), filter, concat, head, last, tail, init, uncons, null, length, (!!), foldl, foldl', foldl1, foldl1', scanl, scanl1, scanl', foldr, foldr1, - scanr, scanr1, iterate, repeat, replicate, cycle, + scanr, scanr1, iterate, iterate', repeat, replicate, cycle, take, drop, sum, product, maximum, minimum, splitAt, takeWhile, dropWhile, span, break, reverse, and, or, any, all, elem, notElem, lookup, @@ -442,7 +441,10 @@ minimum xs = foldl1 min xs -- of @f@ to @x@: -- -- > iterate f x == [x, f x, f (f x), ...] - +-- +-- Note that 'iterate' is lazy, potentially leading to thunk build-up if +-- the consumer doesn't force each iterate. See 'iterate'' for a strict +-- variant of this function. {-# NOINLINE [1] iterate #-} iterate :: (a -> a) -> a -> [a] iterate f x = x : iterate f (f x) @@ -458,6 +460,29 @@ iterateFB c f x0 = go x0 #-} +-- | 'iterate'' is the strict version of 'iterate'. +-- +-- It ensures that the result of each application of force to weak head normal +-- form before proceeding. +{-# NOINLINE [1] iterate' #-} +iterate' :: (a -> a) -> a -> [a] +iterate' f x = + let x' = f x + in x' `seq` (x : iterate' f x') + +{-# INLINE [0] iterate'FB #-} -- See Note [Inline FB functions] +iterate'FB :: (a -> b -> b) -> (a -> a) -> a -> b +iterate'FB c f x0 = go x0 + where go x = + let x' = f x + in x' `seq` (x `c` go x') + +{-# RULES +"iterate'" [~1] forall f x. iterate' f x = build (\c _n -> iterate'FB c f x) +"iterate'FB" [1] iterate'FB (:) = iterate' + #-} + + -- | 'repeat' @x@ is an infinite list, with @x@ the value of every element. repeat :: a -> [a] {-# INLINE [0] repeat #-} @@ -921,12 +946,19 @@ foldr2_left k _z x r (y:ys) = k x y (r ys) ---------------------------------------------- -- | 'zip' takes two lists and returns a list of corresponding pairs. +-- +-- > zip [1, 2] ['a', 'b'] = [(1, 'a'), (2, 'b')] +-- -- If one input list is short, excess elements of the longer list are --- discarded. +-- discarded: +-- +-- > zip [1] ['a', 'b'] = [(1, 'a')] +-- > zip [1, 2] ['a'] = [(1, 'a')] -- -- 'zip' is right-lazy: -- -- > zip [] _|_ = [] +-- > zip _|_ [] = _|_ {-# NOINLINE [1] zip #-} zip :: [a] -> [b] -> [(a,b)] zip [] _bs = [] @@ -966,9 +998,11 @@ zip3 _ _ _ = [] -- > zipWith f [] _|_ = [] {-# NOINLINE [1] zipWith #-} zipWith :: (a->b->c) -> [a]->[b]->[c] -zipWith _f [] _bs = [] -zipWith _f _as [] = [] -zipWith f (a:as) (b:bs) = f a b : zipWith f as bs +zipWith f = go + where + go [] _ = [] + go _ [] = [] + go (x:xs) (y:ys) = f x y : go xs ys -- zipWithFB must have arity 2 since it gets two arguments in the "zipWith" -- rule; it might not get inlined otherwise @@ -985,9 +1019,10 @@ zipWithFB c f = \x y r -> (x `f` y) `c` r -- elements, as well as three lists and returns a list of their point-wise -- combination, analogous to 'zipWith'. zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith3 z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3 z as bs cs -zipWith3 _ _ _ _ = [] +zipWith3 z = go + where + go (a:as) (b:bs) (c:cs) = z a b c : go as bs cs + go _ _ _ = [] -- | 'unzip' transforms a list of pairs into a list of first components -- and a list of second components. diff --git a/libraries/base/GHC/MVar.hs b/libraries/base/GHC/MVar.hs index d367f2ba06..aa5900200a 100644 --- a/libraries/base/GHC/MVar.hs +++ b/libraries/base/GHC/MVar.hs @@ -38,7 +38,7 @@ data MVar a = MVar (MVar# RealWorld a) {- ^ An 'MVar' (pronounced \"em-var\") is a synchronising variable, used for communication between concurrent threads. It can be thought of -as a a box, which may be empty or full. +as a box, which may be empty or full. -} -- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module @@ -90,7 +90,7 @@ takeMVar :: MVar a -> IO a takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# -- |Atomically read the contents of an 'MVar'. If the 'MVar' is --- currently empty, 'readMVar' will wait until its full. +-- currently empty, 'readMVar' will wait until it is full. -- 'readMVar' is guaranteed to receive the next 'putMVar'. -- -- 'readMVar' is multiple-wakeup, so when multiple readers are diff --git a/libraries/base/GHC/Maybe.hs b/libraries/base/GHC/Maybe.hs new file mode 100644 index 0000000000..2bdfac54a2 --- /dev/null +++ b/libraries/base/GHC/Maybe.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Maybe type +module GHC.Maybe + ( Maybe (..) + ) +where + +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base +import GHC.Classes + +default () + +------------------------------------------------------------------------------- +-- Maybe type +------------------------------------------------------------------------------- + +-- | The 'Maybe' type encapsulates an optional value. A value of type +-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic +-- measures such as 'Prelude.error'. +-- +-- The 'Maybe' type is also a monad. It is a simple kind of error +-- monad, where all errors are represented by 'Nothing'. A richer +-- error monad can be built using the 'Data.Either.Either' type. +-- +data Maybe a = Nothing | Just a + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index 0e5abc77bc..71511d37b3 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -1,12 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | @@ -34,44 +30,76 @@ module GHC.Natural -- (i.e. which constructors are available) depends on the -- 'Integer' backend used! Natural(..) + , mkNatural , isValidNatural + -- * Arithmetic + , plusNatural + , minusNatural + , minusNaturalMaybe + , timesNatural + , negateNatural + , signumNatural + , quotRemNatural + , quotNatural + , remNatural +#if defined(MIN_VERSION_integer_gmp) + , gcdNatural + , lcmNatural +#endif + -- * Bits + , andNatural + , orNatural + , xorNatural + , bitNatural + , testBitNatural +#if defined(MIN_VERSION_integer_gmp) + , popCountNatural +#endif + , shiftLNatural + , shiftRNatural -- * Conversions + , naturalToInteger + , naturalToWord + , naturalToInt , naturalFromInteger , wordToNatural + , intToNatural , naturalToWordMaybe - -- * Checked subtraction - , minusNaturalMaybe + , wordToNatural# + , wordToNaturalBase -- * Modular arithmetic , powModNatural ) where #include "MachDeps.h" +import GHC.Classes +import GHC.Maybe +import GHC.Types +import GHC.Prim +import {-# SOURCE #-} GHC.Exception.Type (underflowException, divZeroException) #if defined(MIN_VERSION_integer_gmp) -# define HAVE_GMP_BIGNAT MIN_VERSION_integer_gmp(1,0,0) -#else -# define HAVE_GMP_BIGNAT 0 -#endif - -import GHC.Arr -import GHC.Base -import {-# SOURCE #-} GHC.Exception (underflowException) -#if HAVE_GMP_BIGNAT import GHC.Integer.GMP.Internals -import Data.Word -import Data.Int +#else +import GHC.Integer #endif -import GHC.Num -import GHC.Real -import GHC.Read -import GHC.Show -import GHC.Enum -import GHC.List - -import Data.Bits default () +-- Most high-level operations need to be marked `NOINLINE` as +-- otherwise GHC doesn't recognize them and fails to apply constant +-- folding to `Natural`-typed expression. +-- +-- To this end, the CPP hack below allows to write the pseudo-pragma +-- +-- {-# CONSTANT_FOLDED plusNatural #-} +-- +-- which is simply expanded into a +-- +-- {-# NOINLINE plusNatural #-} +-- +#define CONSTANT_FOLDED NOINLINE + ------------------------------------------------------------------------------- -- Arithmetic underflow ------------------------------------------------------------------------------- @@ -83,17 +111,27 @@ default () underflowError :: a underflowError = raise# underflowException +{-# NOINLINE divZeroError #-} +divZeroError :: a +divZeroError = raise# divZeroException + ------------------------------------------------------------------------------- -- Natural type ------------------------------------------------------------------------------- -#if HAVE_GMP_BIGNAT +#if defined(MIN_VERSION_integer_gmp) -- TODO: if saturated arithmetic is to used, replace 'underflowError' by '0' -- | Type representing arbitrary-precision non-negative integers. -- --- Operations whose result would be negative --- @'throw' ('Underflow' :: 'ArithException')@. +-- >>> 2^100 :: Natural +-- 1267650600228229401496703205376 +-- +-- Operations whose result would be negative @'Control.Exception.throw' +-- ('Control.Exception.Underflow' :: 'Control.Exception.ArithException')@, +-- +-- >>> -1 :: Natural +-- *** Exception: arithmetic underflow -- -- @since 4.8.0.0 data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ @@ -102,8 +140,12 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ -- __Invariant__: 'NatJ#' is used -- /iff/ value doesn't fit in -- 'NatS#' constructor. - deriving (Eq,Ord) -- NB: Order of constructors *must* + -- NB: Order of constructors *must* -- coincide with 'Ord' relation + deriving ( Eq -- ^ @since 4.8.0.0 + , Ord -- ^ @since 4.8.0.0 + ) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- @@ -114,107 +156,32 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ isValidNatural :: Natural -> Bool isValidNatural (NatS# _) = True isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn) - && I# (sizeofBigNat# bn) > 0 - -{-# RULES -"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural -"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer -"fromIntegral/Natural->Word" fromIntegral = naturalToWord -"fromIntegral/Natural->Word8" - fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord -"fromIntegral/Natural->Word16" - fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord -"fromIntegral/Natural->Word32" - fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord -"fromIntegral/Natural->Int8" - fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt -"fromIntegral/Natural->Int16" - fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt -"fromIntegral/Natural->Int32" - fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt - #-} - -{-# RULES -"fromIntegral/Word->Natural" fromIntegral = wordToNatural -"fromIntegral/Word8->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) -"fromIntegral/Word16->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) -"fromIntegral/Word32->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) -"fromIntegral/Int->Natural" fromIntegral = intToNatural -"fromIntegral/Int8->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) -"fromIntegral/Int16->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) -"fromIntegral/Int32->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) - #-} - -#if WORD_SIZE_IN_BITS == 64 --- these RULES are valid for Word==Word64 & Int==Int64 -{-# RULES -"fromIntegral/Natural->Word64" - fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord -"fromIntegral/Natural->Int64" - fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt -"fromIntegral/Word64->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) -"fromIntegral/Int64->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) - #-} -#endif - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec p (NatS# w#) = showsPrec p (W# w#) - showsPrec p (NatJ# bn) = showsPrec p (Jp# bn) - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (fromInteger n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Num Natural where - fromInteger = naturalFromInteger + && isTrue# (sizeofBigNat# bn ># 0#) - (+) = plusNatural - (*) = timesNatural - (-) = minusNatural +signumNatural :: Natural -> Natural +signumNatural (NatS# 0##) = NatS# 0## +signumNatural _ = NatS# 1## +{-# CONSTANT_FOLDED signumNatural #-} - abs = id - - signum (NatS# 0##) = NatS# 0## - signum _ = NatS# 1## - - negate (NatS# 0##) = NatS# 0## - negate _ = underflowError +negateNatural :: Natural -> Natural +negateNatural (NatS# 0##) = NatS# 0## +negateNatural _ = underflowError +{-# CONSTANT_FOLDED negateNatural #-} -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural -naturalFromInteger (S# i#) | I# i# >= 0 = NatS# (int2Word# i#) -naturalFromInteger (Jp# bn) = bigNatToNatural bn -naturalFromInteger _ = underflowError -{-# INLINE naturalFromInteger #-} - --- | @since 4.8.0.0 -instance Real Natural where - toRational (NatS# w) = toRational (W# w) - toRational (NatJ# bn) = toRational (Jp# bn) - -#if OPTIMISE_INTEGER_GCD_LCM -{-# RULES -"gcd/Natural->Natural->Natural" gcd = gcdNatural -"lcm/Natural->Natural->Natural" lcm = lcmNatural - #-} +naturalFromInteger (S# i#) + | isTrue# (i# >=# 0#) = NatS# (int2Word# i#) +naturalFromInteger (Jp# bn) = bigNatToNatural bn +naturalFromInteger _ = underflowError +{-# CONSTANT_FOLDED naturalFromInteger #-} -- | Compute greatest common divisor. gcdNatural :: Natural -> Natural -> Natural gcdNatural (NatS# 0##) y = y gcdNatural x (NatS# 0##) = x -gcdNatural (NatS# 1##) _ = (NatS# 1##) -gcdNatural _ (NatS# 1##) = (NatS# 1##) +gcdNatural (NatS# 1##) _ = NatS# 1## +gcdNatural _ (NatS# 1##) = NatS# 1## gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y) gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y) gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x) @@ -222,149 +189,107 @@ gcdNatural (NatS# x) (NatS# y) = NatS# (gcdWord x y) -- | compute least common multiplier. lcmNatural :: Natural -> Natural -> Natural -lcmNatural (NatS# 0##) _ = (NatS# 0##) -lcmNatural _ (NatS# 0##) = (NatS# 0##) +lcmNatural (NatS# 0##) _ = NatS# 0## +lcmNatural _ (NatS# 0##) = NatS# 0## lcmNatural (NatS# 1##) y = y lcmNatural x (NatS# 1##) = x -lcmNatural x y = (x `quot` (gcdNatural x y)) * y - -#endif - --- | @since 4.8.0.0 -instance Enum Natural where - succ n = n `plusNatural` NatS# 1## - pred n = n `minusNatural` NatS# 1## - - toEnum = intToNatural - - fromEnum (NatS# w) | i >= 0 = i - where - i = fromIntegral (W# w) - fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range" - - enumFrom x = enumDeltaNatural x (NatS# 1##) - enumFromThen x y - | x <= y = enumDeltaNatural x (y-x) - | otherwise = enumNegDeltaToNatural x (x-y) (NatS# 0##) - - enumFromTo x lim = enumDeltaToNatural x (NatS# 1##) lim - enumFromThenTo x y lim - | x <= y = enumDeltaToNatural x (y-x) lim - | otherwise = enumNegDeltaToNatural x (x-y) lim - ----------------------------------------------------------------------------- --- Helpers for 'Enum Natural'; TODO: optimise & make fusion work - -enumDeltaNatural :: Natural -> Natural -> [Natural] -enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d - -enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumDeltaToNatural x0 delta lim = go x0 - where - go x | x > lim = [] - | otherwise = x : go (x+delta) - -enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumNegDeltaToNatural x0 ndelta lim = go x0 - where - go x | x < lim = [] - | x >= ndelta = x : go (x-ndelta) - | otherwise = [x] +lcmNatural x y = (x `quotNatural` (gcdNatural x y)) `timesNatural` y ---------------------------------------------------------------------------- --- | @since 4.8.0.0 -instance Integral Natural where - toInteger (NatS# w) = wordToInteger w - toInteger (NatJ# bn) = Jp# bn - - divMod = quotRem - div = quot - mod = rem - - quotRem _ (NatS# 0##) = divZeroError - quotRem n (NatS# 1##) = (n,NatS# 0##) - quotRem n@(NatS# _) (NatJ# _) = (NatS# 0##, n) - quotRem (NatS# n) (NatS# d) = case quotRem (W# n) (W# d) of - (q,r) -> (wordToNatural q, wordToNatural r) - quotRem (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of - (# q,r #) -> (bigNatToNatural q, NatS# r) - quotRem (NatJ# n) (NatJ# d) = case quotRemBigNat n d of - (# q,r #) -> (bigNatToNatural q, bigNatToNatural r) - - quot _ (NatS# 0##) = divZeroError - quot n (NatS# 1##) = n - quot (NatS# _) (NatJ# _) = NatS# 0## - quot (NatS# n) (NatS# d) = wordToNatural (quot (W# n) (W# d)) - quot (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) - quot (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) - - rem _ (NatS# 0##) = divZeroError - rem _ (NatS# 1##) = NatS# 0## - rem n@(NatS# _) (NatJ# _) = n - rem (NatS# n) (NatS# d) = wordToNatural (rem (W# n) (W# d)) - rem (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) - rem (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) - --- | @since 4.8.0.0 -instance Ix Natural where - range (m,n) = [m..n] - inRange (m,n) i = m <= i && i <= n - unsafeIndex (m,_) i = fromIntegral (i-m) - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Natural" - - --- | @since 4.8.0.0 -instance Bits Natural where - NatS# n .&. NatS# m = wordToNatural (W# n .&. W# m) - NatS# n .&. NatJ# m = wordToNatural (W# n .&. W# (bigNatToWord m)) - NatJ# n .&. NatS# m = wordToNatural (W# (bigNatToWord n) .&. W# m) - NatJ# n .&. NatJ# m = bigNatToNatural (andBigNat n m) - - NatS# n .|. NatS# m = wordToNatural (W# n .|. W# m) - NatS# n .|. NatJ# m = NatJ# (orBigNat (wordToBigNat n) m) - NatJ# n .|. NatS# m = NatJ# (orBigNat n (wordToBigNat m)) - NatJ# n .|. NatJ# m = NatJ# (orBigNat n m) - - NatS# n `xor` NatS# m = wordToNatural (W# n `xor` W# m) - NatS# n `xor` NatJ# m = NatJ# (xorBigNat (wordToBigNat n) m) - NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m)) - NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m) - - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - - bitSizeMaybe _ = Nothing - bitSize = errorWithoutStackTrace "Natural: bitSize" - isSigned _ = False - - bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i) - | otherwise = NatJ# (bitBigNat i#) - - testBit (NatS# w) i = testBit (W# w) i - testBit (NatJ# bn) (I# i#) = testBitBigNat bn i# - - -- TODO: setBit, clearBit, complementBit (needs more primitives) - - shiftL n 0 = n - shiftL (NatS# 0##) _ = NatS# 0## - shiftL (NatS# 1##) i = bit i - shiftL (NatS# w) (I# i#) - = bigNatToNatural $ shiftLBigNat (wordToBigNat w) i# - shiftL (NatJ# bn) (I# i#) - = bigNatToNatural $ shiftLBigNat bn i# - - shiftR n 0 = n - shiftR (NatS# w) i = wordToNatural $ shiftR (W# w) i - shiftR (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) - - rotateL = shiftL - rotateR = shiftR - - popCount (NatS# w) = popCount (W# w) - popCount (NatJ# bn) = I# (popCountBigNat bn) - - zeroBits = NatS# 0## +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural _ (NatS# 0##) = divZeroError +quotRemNatural n (NatS# 1##) = (n,NatS# 0##) +quotRemNatural n@(NatS# _) (NatJ# _) = (NatS# 0##, n) +quotRemNatural (NatS# n) (NatS# d) = case quotRemWord# n d of + (# q, r #) -> (NatS# q, NatS# r) +quotRemNatural (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of + (# q, r #) -> (bigNatToNatural q, NatS# r) +quotRemNatural (NatJ# n) (NatJ# d) = case quotRemBigNat n d of + (# q, r #) -> (bigNatToNatural q, bigNatToNatural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural _ (NatS# 0##) = divZeroError +quotNatural n (NatS# 1##) = n +quotNatural (NatS# _) (NatJ# _) = NatS# 0## +quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d) +quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) +quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural _ (NatS# 0##) = divZeroError +remNatural _ (NatS# 1##) = NatS# 0## +remNatural n@(NatS# _) (NatJ# _) = n +remNatural (NatS# n) (NatS# d) = NatS# (remWord# n d) +remNatural (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) +remNatural (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) +{-# CONSTANT_FOLDED remNatural #-} + +-- | @since 4.X.0.0 +naturalToInteger :: Natural -> Integer +naturalToInteger (NatS# w) = wordToInteger w +naturalToInteger (NatJ# bn) = Jp# bn +{-# CONSTANT_FOLDED naturalToInteger #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (NatS# n) (NatS# m) = NatS# (n `and#` m) +andNatural (NatS# n) (NatJ# m) = NatS# (n `and#` bigNatToWord m) +andNatural (NatJ# n) (NatS# m) = NatS# (bigNatToWord n `and#` m) +andNatural (NatJ# n) (NatJ# m) = bigNatToNatural (andBigNat n m) +{-# CONSTANT_FOLDED andNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (NatS# n) (NatS# m) = NatS# (n `or#` m) +orNatural (NatS# n) (NatJ# m) = NatJ# (orBigNat (wordToBigNat n) m) +orNatural (NatJ# n) (NatS# m) = NatJ# (orBigNat n (wordToBigNat m)) +orNatural (NatJ# n) (NatJ# m) = NatJ# (orBigNat n m) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (NatS# n) (NatS# m) = NatS# (n `xor#` m) +xorNatural (NatS# n) (NatJ# m) = NatJ# (xorBigNat (wordToBigNat n) m) +xorNatural (NatJ# n) (NatS# m) = NatJ# (xorBigNat n (wordToBigNat m)) +xorNatural (NatJ# n) (NatJ# m) = bigNatToNatural (xorBigNat n m) +{-# CONSTANT_FOLDED xorNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = NatS# (1## `uncheckedShiftL#` i#) + | True = NatJ# (bitBigNat i#) +{-# CONSTANT_FOLDED bitNatural #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (NatS# w) (I# i#) + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = + isTrue# ((w `and#` (1## `uncheckedShiftL#` i#)) `neWord#` 0##) + | True = False +testBitNatural (NatJ# bn) (I# i#) = testBitBigNat bn i# +{-# CONSTANT_FOLDED testBitNatural #-} + +popCountNatural :: Natural -> Int +popCountNatural (NatS# w) = I# (word2Int# (popCnt# w)) +popCountNatural (NatJ# bn) = I# (popCountBigNat bn) +{-# CONSTANT_FOLDED popCountNatural #-} + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural n (I# 0#) = n +shiftLNatural (NatS# 0##) _ = NatS# 0## +shiftLNatural (NatS# 1##) (I# i#) = bitNatural i# +shiftLNatural (NatS# w) (I# i#) + = bigNatToNatural (shiftLBigNat (wordToBigNat w) i#) +shiftLNatural (NatJ# bn) (I# i#) + = bigNatToNatural (shiftLBigNat bn i#) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural n (I# 0#) = n +shiftRNatural (NatS# w) (I# i#) + | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = NatS# 0## + | True = NatS# (w `uncheckedShiftRL#` i#) +shiftRNatural (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) +{-# CONSTANT_FOLDED shiftRNatural #-} ---------------------------------------------------------------------------- @@ -379,6 +304,7 @@ plusNatural (NatS# x) (NatS# y) plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x) plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y) plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat x y) +{-# CONSTANT_FOLDED plusNatural #-} -- | 'Natural' multiplication timesNatural :: Natural -> Natural -> Natural @@ -389,12 +315,14 @@ timesNatural (NatS# 1##) y = y timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of (# 0##, 0## #) -> NatS# 0## (# 0##, xy #) -> NatS# xy - (# h , l #) -> NatJ# $ wordToBigNat2 h l -timesNatural (NatS# x) (NatJ# y) = NatJ# $ timesBigNatWord y x -timesNatural (NatJ# x) (NatS# y) = NatJ# $ timesBigNatWord x y -timesNatural (NatJ# x) (NatJ# y) = NatJ# $ timesBigNat x y - --- | 'Natural' subtraction. May @'throw' 'Underflow'@. + (# h , l #) -> NatJ# (wordToBigNat2 h l) +timesNatural (NatS# x) (NatJ# y) = NatJ# (timesBigNatWord y x) +timesNatural (NatJ# x) (NatS# y) = NatJ# (timesBigNatWord x y) +timesNatural (NatJ# x) (NatJ# y) = NatJ# (timesBigNat x y) +{-# CONSTANT_FOLDED timesNatural #-} + +-- | 'Natural' subtraction. May @'Control.Exception.throw' +-- 'Control.Exception.Underflow'@. minusNatural :: Natural -> Natural -> Natural minusNatural x (NatS# 0##) = x minusNatural (NatS# x) (NatS# y) = case subWordC# x y of @@ -402,9 +330,10 @@ minusNatural (NatS# x) (NatS# y) = case subWordC# x y of _ -> underflowError minusNatural (NatS# _) (NatJ# _) = underflowError minusNatural (NatJ# x) (NatS# y) - = bigNatToNatural $ minusBigNatWord x y + = bigNatToNatural (minusBigNatWord x y) minusNatural (NatJ# x) (NatJ# y) - = bigNatToNatural $ minusBigNat x y + = bigNatToNatural (minusBigNat x y) +{-# CONSTANT_FOLDED minusNatural #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- @@ -414,34 +343,27 @@ minusNaturalMaybe x (NatS# 0##) = Just x minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of (# l, 0# #) -> Just (NatS# l) _ -> Nothing - where minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing minusNaturalMaybe (NatJ# x) (NatS# y) - = Just $ bigNatToNatural $ minusBigNatWord x y + = Just (bigNatToNatural (minusBigNatWord x y)) minusNaturalMaybe (NatJ# x) (NatJ# y) | isTrue# (isNullBigNat# res) = Nothing - | otherwise = Just (bigNatToNatural res) + | True = Just (bigNatToNatural res) where res = minusBigNat x y -- | Convert 'BigNat' to 'Natural'. --- Throws 'Underflow' if passed a 'nullBigNat'. +-- Throws 'Control.Exception.Underflow' if passed a 'nullBigNat'. bigNatToNatural :: BigNat -> Natural bigNatToNatural bn | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn) | isTrue# (isNullBigNat# bn) = underflowError - | otherwise = NatJ# bn + | True = NatJ# bn naturalToBigNat :: Natural -> BigNat naturalToBigNat (NatS# w#) = wordToBigNat w# naturalToBigNat (NatJ# bn) = bn --- | Convert 'Int' to 'Natural'. --- Throws 'Underflow' when passed a negative 'Int'. -intToNatural :: Int -> Natural -intToNatural i | i<0 = underflowError -intToNatural (I# i#) = NatS# (int2Word# i#) - naturalToWord :: Natural -> Word naturalToWord (NatS# w#) = W# w# naturalToWord (NatJ# bn) = W# (bigNatToWord bn) @@ -450,182 +372,184 @@ naturalToInt :: Natural -> Int naturalToInt (NatS# w#) = I# (word2Int# w#) naturalToInt (NatJ# bn) = I# (bigNatToInt bn) -#else /* !HAVE_GMP_BIGNAT */ +---------------------------------------------------------------------------- + +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w# = NatS# w# +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w# = NatS# w# + +#else /* !defined(MIN_VERSION_integer_gmp) */ ---------------------------------------------------------------------------- -- Use wrapped 'Integer' as fallback; taken from Edward Kmett's nats package -- | Type representing arbitrary-precision non-negative integers. -- --- Operations whose result would be negative --- @'throw' ('Underflow' :: 'ArithException')@. +-- Operations whose result would be negative @'Control.Exception.throw' +-- ('Control.Exception.Underflow' :: 'Control.Exception.ArithException')@. -- -- @since 4.8.0.0 newtype Natural = Natural Integer -- ^ __Invariant__: non-negative 'Integer' - deriving (Eq,Ord,Ix) + deriving (Eq,Ord) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- -- This operation is mostly useful for test-suites and/or code which --- constructs 'Integer' values directly. +-- constructs 'Natural' values directly. -- -- @since 4.8.0.0 isValidNatural :: Natural -> Bool -isValidNatural (Natural i) = i >= 0 - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (Natural n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec d (Natural i) = showsPrec d i - --- | @since 4.8.0.0 -instance Num Natural where - Natural n + Natural m = Natural (n + m) - {-# INLINE (+) #-} - Natural n * Natural m = Natural (n * m) - {-# INLINE (*) #-} - Natural n - Natural m | result < 0 = underflowError - | otherwise = Natural result - where result = n - m - {-# INLINE (-) #-} - abs (Natural n) = Natural n - {-# INLINE abs #-} - signum (Natural n) = Natural (signum n) - {-# INLINE signum #-} - fromInteger = naturalFromInteger - {-# INLINE fromInteger #-} +isValidNatural (Natural i) = i >= wordToInteger 0## + +-- | Convert a 'Word#' into a 'Natural' +-- +-- Built-in rule ensures that applications of this function to literal 'Word#' +-- are lifted into 'Natural' literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w## = Natural (wordToInteger w##) +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a 'Word#' into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w## = Natural (wordToInteger w##) -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural naturalFromInteger n - | n >= 0 = Natural n - | otherwise = underflowError + | n >= wordToInteger 0## = Natural n + | True = underflowError {-# INLINE naturalFromInteger #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- -- @since 4.8.0.0 minusNaturalMaybe :: Natural -> Natural -> Maybe Natural -minusNaturalMaybe x y - | x >= y = Just (x - y) - | otherwise = Nothing - --- | @since 4.8.0.0 -instance Bits Natural where - Natural n .&. Natural m = Natural (n .&. m) - {-# INLINE (.&.) #-} - Natural n .|. Natural m = Natural (n .|. m) - {-# INLINE (.|.) #-} - xor (Natural n) (Natural m) = Natural (xor n m) - {-# INLINE xor #-} - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - {-# INLINE complement #-} - shift (Natural n) = Natural . shift n - {-# INLINE shift #-} - rotate (Natural n) = Natural . rotate n - {-# INLINE rotate #-} - bit = Natural . bit - {-# INLINE bit #-} - setBit (Natural n) = Natural . setBit n - {-# INLINE setBit #-} - clearBit (Natural n) = Natural . clearBit n - {-# INLINE clearBit #-} - complementBit (Natural n) = Natural . complementBit n - {-# INLINE complementBit #-} - testBit (Natural n) = testBit n - {-# INLINE testBit #-} - bitSizeMaybe _ = Nothing - {-# INLINE bitSizeMaybe #-} - bitSize = errorWithoutStackTrace "Natural: bitSize" - {-# INLINE bitSize #-} - isSigned _ = False - {-# INLINE isSigned #-} - shiftL (Natural n) = Natural . shiftL n - {-# INLINE shiftL #-} - shiftR (Natural n) = Natural . shiftR n - {-# INLINE shiftR #-} - rotateL (Natural n) = Natural . rotateL n - {-# INLINE rotateL #-} - rotateR (Natural n) = Natural . rotateR n - {-# INLINE rotateR #-} - popCount (Natural n) = popCount n - {-# INLINE popCount #-} - zeroBits = Natural 0 - --- | @since 4.8.0.0 -instance Real Natural where - toRational (Natural a) = toRational a - {-# INLINE toRational #-} - --- | @since 4.8.0.0 -instance Enum Natural where - pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" - pred (Natural n) = Natural (pred n) - {-# INLINE pred #-} - succ (Natural n) = Natural (succ n) - {-# INLINE succ #-} - fromEnum (Natural n) = fromEnum n - {-# INLINE fromEnum #-} - toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" - | otherwise = Natural (toEnum n) - {-# INLINE toEnum #-} - - enumFrom = coerce (enumFrom :: Integer -> [Integer]) - enumFromThen x y - | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y - | otherwise = enumFromThenTo x y 0 - - enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) - enumFromThenTo - = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) - --- | @since 4.8.0.0 -instance Integral Natural where - quot (Natural a) (Natural b) = Natural (quot a b) - {-# INLINE quot #-} - rem (Natural a) (Natural b) = Natural (rem a b) - {-# INLINE rem #-} - div (Natural a) (Natural b) = Natural (div a b) - {-# INLINE div #-} - mod (Natural a) (Natural b) = Natural (mod a b) - {-# INLINE mod #-} - divMod (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = divMod a b - {-# INLINE divMod #-} - quotRem (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = quotRem a b - {-# INLINE quotRem #-} - toInteger (Natural a) = a - {-# INLINE toInteger #-} +minusNaturalMaybe (Natural x) (Natural y) + | x >= y = Just (Natural (x `minusInteger` y)) + | True = Nothing + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural (Natural n) (I# i) = Natural (n `shiftLInteger` i) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural (Natural n) (I# i) = Natural (n `shiftRInteger` i) +{-# CONSTANT_FOLDED shiftRNatural #-} + +plusNatural :: Natural -> Natural -> Natural +plusNatural (Natural x) (Natural y) = Natural (x `plusInteger` y) +{-# CONSTANT_FOLDED plusNatural #-} + +minusNatural :: Natural -> Natural -> Natural +minusNatural (Natural x) (Natural y) = Natural (x `minusInteger` y) +{-# CONSTANT_FOLDED minusNatural #-} + +timesNatural :: Natural -> Natural -> Natural +timesNatural (Natural x) (Natural y) = Natural (x `timesInteger` y) +{-# CONSTANT_FOLDED timesNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (Natural x) (Natural y) = Natural (x `orInteger` y) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (Natural x) (Natural y) = Natural (x `xorInteger` y) +{-# CONSTANT_FOLDED xorNatural #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (Natural x) (Natural y) = Natural (x `andInteger` y) +{-# CONSTANT_FOLDED andNatural #-} + +naturalToInt :: Natural -> Int +naturalToInt (Natural i) = I# (integerToInt i) + +naturalToWord :: Natural -> Word +naturalToWord (Natural i) = W# (integerToWord i) + +naturalToInteger :: Natural -> Integer +naturalToInteger (Natural i) = i +{-# CONSTANT_FOLDED naturalToInteger #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (Natural n) (I# i) = testBitInteger n i +{-# CONSTANT_FOLDED testBitNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = wordToNaturalBase (1## `uncheckedShiftL#` i#) + | True = Natural (1 `shiftLInteger` i#) +{-# CONSTANT_FOLDED bitNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = n + | True = Natural (x `quotInteger` y) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural (Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = wordToNaturalBase 0## + | True = Natural (x `remInteger` y) +{-# CONSTANT_FOLDED remNatural #-} + +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = (n,wordToNaturalBase 0##) + | True = case quotRemInteger x y of + (# k, r #) -> (Natural k, Natural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +signumNatural :: Natural -> Natural +signumNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = wordToNaturalBase 1## +{-# CONSTANT_FOLDED signumNatural #-} + +negateNatural :: Natural -> Natural +negateNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = underflowError +{-# CONSTANT_FOLDED negateNatural #-} + #endif -- | Construct 'Natural' from 'Word' value. -- -- @since 4.8.0.0 wordToNatural :: Word -> Natural -#if HAVE_GMP_BIGNAT -wordToNatural (W# w#) = NatS# w# -#else -wordToNatural w = Natural (fromIntegral w) -#endif +wordToNatural (W# w#) = wordToNatural# w# -- | Try downcasting 'Natural' to 'Word' value. -- Returns 'Nothing' if value doesn't fit in 'Word'. -- -- @since 4.8.0.0 naturalToWordMaybe :: Natural -> Maybe Word -#if HAVE_GMP_BIGNAT +#if defined(MIN_VERSION_integer_gmp) naturalToWordMaybe (NatS# w#) = Just (W# w#) naturalToWordMaybe (NatJ# _) = Nothing #else naturalToWordMaybe (Natural i) - | i <= maxw = Just (fromIntegral i) - | otherwise = Nothing + | i < maxw = Just (W# (integerToWord i)) + | True = Nothing where - maxw = toInteger (maxBound :: Word) + maxw = 1 `shiftLInteger` WORD_SIZE_IN_BITS# #endif -- | \"@'powModNatural' /b/ /e/ /m/@\" computes base @/b/@ raised to @@ -633,7 +557,7 @@ naturalToWordMaybe (Natural i) -- -- @since 4.8.0.0 powModNatural :: Natural -> Natural -> Natural -> Natural -#if HAVE_GMP_BIGNAT +#if defined(MIN_VERSION_integer_gmp) powModNatural _ _ (NatS# 0##) = divZeroError powModNatural _ _ (NatS# 1##) = NatS# 0## powModNatural _ (NatS# 0##) _ = NatS# 1## @@ -646,18 +570,38 @@ powModNatural b e (NatJ# m) = bigNatToNatural (powModBigNat (naturalToBigNat b) (naturalToBigNat e) m) #else -- Portable reference fallback implementation -powModNatural _ _ 0 = divZeroError -powModNatural _ _ 1 = 0 -powModNatural _ 0 _ = 1 -powModNatural 0 _ _ = 0 -powModNatural 1 _ _ = 1 -powModNatural b0 e0 m = go b0 e0 1 +powModNatural (Natural b0) (Natural e0) (Natural m) + | m == wordToInteger 0## = divZeroError + | m == wordToInteger 1## = wordToNaturalBase 0## + | e0 == wordToInteger 0## = wordToNaturalBase 1## + | b0 == wordToInteger 0## = wordToNaturalBase 0## + | b0 == wordToInteger 1## = wordToNaturalBase 1## + | True = go b0 e0 (wordToInteger 1##) where go !b e !r - | odd e = go b' e' (r*b `mod` m) - | e == 0 = r - | otherwise = go b' e' r + | e `testBitInteger` 0# = go b' e' ((r `timesInteger` b) `modInteger` m) + | e == wordToInteger 0## = naturalFromInteger r + | True = go b' e' r where - b' = b*b `mod` m - e' = e `unsafeShiftR` 1 -- slightly faster than "e `div` 2" + b' = (b `timesInteger` b) `modInteger` m + e' = e `shiftRInteger` 1# -- slightly faster than "e `div` 2" #endif + + +-- | Construct 'Natural' value from list of 'Word's. +-- +-- This function is used by GHC for constructing 'Natural' literals. +mkNatural :: [Word] -- ^ value expressed in 32 bit chunks, least + -- significant first + -> Natural +mkNatural [] = wordToNaturalBase 0## +mkNatural (W# i : is') = wordToNaturalBase (i `and#` 0xffffffff##) `orNatural` + shiftLNatural (mkNatural is') 32 +{-# CONSTANT_FOLDED mkNatural #-} + +-- | Convert 'Int' to 'Natural'. +-- Throws 'Control.Exception.Underflow' when passed a negative 'Int'. +intToNatural :: Int -> Natural +intToNatural (I# i#) + | isTrue# (i# <# 0#) = underflowError + | True = wordToNaturalBase (int2Word# i#) diff --git a/libraries/base/GHC/Num.hs b/libraries/base/GHC/Num.hs index fd98c19f20..1fa63fbb00 100644 --- a/libraries/base/GHC/Num.hs +++ b/libraries/base/GHC/Num.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -16,10 +16,17 @@ -- ----------------------------------------------------------------------------- -module GHC.Num (module GHC.Num, module GHC.Integer) where + +module GHC.Num (module GHC.Num, module GHC.Integer, module GHC.Natural) where + +#include "MachDeps.h" import GHC.Base import GHC.Integer +import GHC.Natural +#if !defined(MIN_VERSION_integer_gmp) +import {-# SOURCE #-} GHC.Exception.Type (underflowException) +#endif infixl 7 * infixl 6 +, - @@ -28,6 +35,23 @@ default () -- Double isn't available yet, -- and we shouldn't be using defaults anyway -- | Basic numeric class. +-- +-- The Haskell Report defines no laws for 'Num'. However, '(+)' and '(*)' are +-- customarily expected to define a ring and have the following properties: +-- +-- [__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@ +-- [__Commutativity of (+)__]: @x + y@ = @y + x@ +-- [__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@ +-- [__'negate' gives the additive inverse__]: @x + negate x@ = @fromInteger 0@ +-- [__Associativity of (*)__]: @(x * y) * z@ = @x * (y * z)@ +-- [__@fromInteger 1@ is the multiplicative identity__]: +-- @x * fromInteger 1@ = @x@ and @fromInteger 1 * x@ = @x@ +-- [__Distributivity of (*) with respect to (+)__]: +-- @a * (b + c)@ = @(a * b) + (a * c)@ and @(b + c) * a@ = @(b * a) + (c * a)@ +-- +-- Note that it /isn't/ customarily expected that a type instance of both 'Num' +-- and 'Ord' implement an ordered ring. Indeed, in @base@ only 'Integer' and +-- 'Data.Ratio.Rational' do. class Num a where {-# MINIMAL (+), (*), abs, signum, fromInteger, (negate | (-)) #-} @@ -100,3 +124,41 @@ instance Num Integer where abs = absInteger signum = signumInteger + +#if defined(MIN_VERSION_integer_gmp) +-- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an +-- additive inverse. It is a semiring though. +-- +-- @since 4.8.0.0 +instance Num Natural where + (+) = plusNatural + (-) = minusNatural + (*) = timesNatural + negate = negateNatural + fromInteger = naturalFromInteger + + abs = id + signum = signumNatural + +#else +-- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an +-- additive inverse. It is a semiring though. +-- +-- @since 4.8.0.0 +instance Num Natural where + Natural n + Natural m = Natural (n + m) + {-# INLINE (+) #-} + Natural n * Natural m = Natural (n * m) + {-# INLINE (*) #-} + Natural n - Natural m + | m > n = raise# underflowException + | otherwise = Natural (n - m) + {-# INLINE (-) #-} + abs (Natural n) = Natural n + {-# INLINE abs #-} + signum (Natural n) = Natural (signum n) + {-# INLINE signum #-} + fromInteger = naturalFromInteger + {-# INLINE fromInteger #-} + +#endif diff --git a/libraries/base/GHC/PArr.hs b/libraries/base/GHC/PArr.hs deleted file mode 100644 index 67d25bcb85..0000000000 --- a/libraries/base/GHC/PArr.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ParallelArrays, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.PArr --- Copyright : (c) 2001-2011 The Data Parallel Haskell team --- License : see libraries/base/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- BIG UGLY HACK: The desugarer special cases this module. Despite the uses of '-XParallelArrays', --- the desugarer does not load 'Data.Array.Parallel' into its global state. (Hence, --- the present module may not use any other piece of '-XParallelArray' syntax.) --- --- This will be cleaned up when we change the internal represention of '[::]' to not --- rely on a wired-in type constructor. - -module GHC.PArr where - -import GHC.Base - --- Representation of parallel arrays --- --- Vanilla representation of parallel Haskell based on standard GHC arrays that is used if the --- vectorised is /not/ used. --- --- NB: This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! --- -data [::] e = PArr !Int (Array# e) - -type PArr = [::] -- this synonym is to get access to '[::]' without using the special syntax diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs index 93f6d64ae5..f7caf164af 100644 --- a/libraries/base/GHC/Ptr.hs +++ b/libraries/base/GHC/Ptr.hs @@ -42,7 +42,10 @@ import Numeric ( showHex ) -- redundant role annotation checks that this doesn't change type role Ptr phantom -data Ptr a = Ptr Addr# deriving (Eq, Ord) +data Ptr a = Ptr Addr# + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) -- ^ A value of type @'Ptr' a@ represents a pointer to an object, or an -- array of objects, which may be marshalled to or from Haskell values -- of type @a@. diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc index 7bb10b60cb..12cb828e6a 100644 --- a/libraries/base/GHC/RTS/Flags.hsc +++ b/libraries/base/GHC/RTS/Flags.hsc @@ -51,7 +51,7 @@ import GHC.IO import GHC.Real import GHC.Show --- | @'Time'@ is defined as a @'StgWord64'@ in @stg/Types.h@ +-- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ -- -- @since 4.8.2.0 type RtsTime = Word64 @@ -66,7 +66,8 @@ data GiveGCStats | OneLineGCStats | SummaryGCStats | VerboseGCStats - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum GiveGCStats where @@ -115,7 +116,8 @@ data GCFlags = GCFlags , allocLimitGrace :: Word , numa :: Bool , numaMask :: Word - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters concerning context switching -- @@ -123,7 +125,8 @@ data GCFlags = GCFlags data ConcFlags = ConcFlags { ctxtSwitchTime :: RtsTime , ctxtSwitchTicks :: Int - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Miscellaneous parameters -- @@ -131,32 +134,38 @@ data ConcFlags = ConcFlags data MiscFlags = MiscFlags { tickInterval :: RtsTime , installSignalHandlers :: Bool + , installSEHHandlers :: Bool + , generateCrashDumpFile :: Bool + , generateStackTrace :: Bool , machineReadable :: Bool + , internalCounters :: Bool , linkerMemBase :: Word -- ^ address to ask the OS for memory for the linker, 0 ==> off - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Flags to control debugging output & extra checking in various -- subsystems. -- -- @since 4.8.0.0 data DebugFlags = DebugFlags - { scheduler :: Bool -- ^ 's' - , interpreter :: Bool -- ^ 'i' - , weak :: Bool -- ^ 'w' - , gccafs :: Bool -- ^ 'G' - , gc :: Bool -- ^ 'g' - , block_alloc :: Bool -- ^ 'b' - , sanity :: Bool -- ^ 'S' - , stable :: Bool -- ^ 't' - , prof :: Bool -- ^ 'p' - , linker :: Bool -- ^ 'l' the object linker - , apply :: Bool -- ^ 'a' - , stm :: Bool -- ^ 'm' - , squeeze :: Bool -- ^ 'z' stack squeezing & lazy blackholing - , hpc :: Bool -- ^ 'c' coverage - , sparks :: Bool -- ^ 'r' - } deriving (Show) + { scheduler :: Bool -- ^ @s@ + , interpreter :: Bool -- ^ @i@ + , weak :: Bool -- ^ @w@ + , gccafs :: Bool -- ^ @G@ + , gc :: Bool -- ^ @g@ + , block_alloc :: Bool -- ^ @b@ + , sanity :: Bool -- ^ @S@ + , stable :: Bool -- ^ @t@ + , prof :: Bool -- ^ @p@ + , linker :: Bool -- ^ @l@ the object linker + , apply :: Bool -- ^ @a@ + , stm :: Bool -- ^ @m@ + , squeeze :: Bool -- ^ @z@ stack squeezing & lazy blackholing + , hpc :: Bool -- ^ @c@ coverage + , sparks :: Bool -- ^ @r@ + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Should the RTS produce a cost-center summary? -- @@ -167,7 +176,8 @@ data DoCostCentres | CostCentresVerbose | CostCentresAll | CostCentresJSON - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoCostCentres where @@ -191,7 +201,8 @@ data CCFlags = CCFlags { doCostCentres :: DoCostCentres , profilerTicks :: Int , msecsPerTick :: Int - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | What sort of heap profile are we collecting? -- @@ -205,7 +216,8 @@ data DoHeapProfile | HeapByRetainer | HeapByLDV | HeapByClosureType - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoHeapProfile where @@ -246,7 +258,8 @@ data ProfFlags = ProfFlags , ccsSelector :: Maybe String , retainerSelector :: Maybe String , bioSelector :: Maybe String - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Is event tracing enabled? -- @@ -255,7 +268,8 @@ data DoTrace = TraceNone -- ^ no tracing | TraceEventLog -- ^ send tracing events to the event log | TraceStderr -- ^ send tracing events to @stderr@ - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoTrace where @@ -279,7 +293,8 @@ data TraceFlags = TraceFlags , sparksSampled :: Bool -- ^ trace spark events by a sampled method , sparksFull :: Bool -- ^ trace spark events 100% accurately , user :: Bool -- ^ trace user events (emitted from Haskell code) - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters pertaining to ticky-ticky profiler -- @@ -287,7 +302,8 @@ data TraceFlags = TraceFlags data TickyFlags = TickyFlags { showTickyStats :: Bool , tickyFile :: Maybe FilePath - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters pertaining to parallelism -- @@ -304,7 +320,8 @@ data ParFlags = ParFlags , parGcThreads :: Word32 , setAffinity :: Bool } - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters of the runtime system -- @@ -319,7 +336,8 @@ data RTSFlags = RTSFlags , traceFlags :: TraceFlags , tickyFlags :: TickyFlags , parFlags :: ParFlags - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) foreign import ccall "&RtsFlags" rtsFlagsPtr :: Ptr RTSFlags @@ -362,20 +380,27 @@ getGCFlags = do <*> #{peek GC_FLAGS, nurseryChunkSize} ptr <*> #{peek GC_FLAGS, minOldGenSize} ptr <*> #{peek GC_FLAGS, heapSizeSuggestion} ptr - <*> #{peek GC_FLAGS, heapSizeSuggestionAuto} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, heapSizeSuggestionAuto} ptr :: IO CBool)) <*> #{peek GC_FLAGS, oldGenFactor} ptr <*> #{peek GC_FLAGS, pcFreeHeap} ptr <*> #{peek GC_FLAGS, generations} ptr - <*> #{peek GC_FLAGS, squeezeUpdFrames} ptr - <*> #{peek GC_FLAGS, compact} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, squeezeUpdFrames} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek GC_FLAGS, compact} ptr :: IO CBool)) <*> #{peek GC_FLAGS, compactThreshold} ptr - <*> #{peek GC_FLAGS, sweep} ptr - <*> #{peek GC_FLAGS, ringBell} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, sweep} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek GC_FLAGS, ringBell} ptr :: IO CBool)) <*> #{peek GC_FLAGS, idleGCDelayTime} ptr - <*> #{peek GC_FLAGS, doIdleGC} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, doIdleGC} ptr :: IO CBool)) <*> #{peek GC_FLAGS, heapBase} ptr <*> #{peek GC_FLAGS, allocLimitGrace} ptr - <*> #{peek GC_FLAGS, numa} ptr + <*> (toBool <$> + (#{peek GC_FLAGS, numa} ptr :: IO CBool)) <*> #{peek GC_FLAGS, numaMask} ptr getParFlags :: IO ParFlags @@ -383,15 +408,19 @@ getParFlags = do let ptr = (#ptr RTS_FLAGS, ParFlags) rtsFlagsPtr ParFlags <$> #{peek PAR_FLAGS, nCapabilities} ptr - <*> #{peek PAR_FLAGS, migrate} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, migrate} ptr :: IO CBool)) <*> #{peek PAR_FLAGS, maxLocalSparks} ptr - <*> #{peek PAR_FLAGS, parGcEnabled} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, parGcEnabled} ptr :: IO CBool)) <*> #{peek PAR_FLAGS, parGcGen} ptr - <*> #{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr :: IO CBool)) <*> #{peek PAR_FLAGS, parGcLoadBalancingGen} ptr <*> #{peek PAR_FLAGS, parGcNoSyncWithIdle} ptr <*> #{peek PAR_FLAGS, parGcThreads} ptr - <*> #{peek PAR_FLAGS, setAffinity} ptr + <*> (toBool <$> + (#{peek PAR_FLAGS, setAffinity} ptr :: IO CBool)) getConcFlags :: IO ConcFlags getConcFlags = do @@ -403,28 +432,53 @@ getMiscFlags :: IO MiscFlags getMiscFlags = do let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr - <*> #{peek MISC_FLAGS, install_signal_handlers} ptr - <*> #{peek MISC_FLAGS, machineReadable} ptr + <*> (toBool <$> + (#{peek MISC_FLAGS, install_signal_handlers} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, install_seh_handlers} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, generate_dump_file} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, generate_stack_trace} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, machineReadable} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, internalCounters} ptr :: IO CBool)) <*> #{peek MISC_FLAGS, linkerMemBase} ptr getDebugFlags :: IO DebugFlags getDebugFlags = do let ptr = (#ptr RTS_FLAGS, DebugFlags) rtsFlagsPtr - DebugFlags <$> #{peek DEBUG_FLAGS, scheduler} ptr - <*> #{peek DEBUG_FLAGS, interpreter} ptr - <*> #{peek DEBUG_FLAGS, weak} ptr - <*> #{peek DEBUG_FLAGS, gccafs} ptr - <*> #{peek DEBUG_FLAGS, gc} ptr - <*> #{peek DEBUG_FLAGS, block_alloc} ptr - <*> #{peek DEBUG_FLAGS, sanity} ptr - <*> #{peek DEBUG_FLAGS, stable} ptr - <*> #{peek DEBUG_FLAGS, prof} ptr - <*> #{peek DEBUG_FLAGS, linker} ptr - <*> #{peek DEBUG_FLAGS, apply} ptr - <*> #{peek DEBUG_FLAGS, stm} ptr - <*> #{peek DEBUG_FLAGS, squeeze} ptr - <*> #{peek DEBUG_FLAGS, hpc} ptr - <*> #{peek DEBUG_FLAGS, sparks} ptr + DebugFlags <$> (toBool <$> + (#{peek DEBUG_FLAGS, scheduler} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, interpreter} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, weak} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, gccafs} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, gc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, block_alloc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, sanity} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, stable} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, prof} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, linker} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, apply} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, stm} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, squeeze} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool)) getCCFlags :: IO CCFlags getCCFlags = do @@ -440,8 +494,10 @@ getProfFlags = do ProfFlags <$> (toEnum <$> #{peek PROFILING_FLAGS, doHeapProfile} ptr) <*> #{peek PROFILING_FLAGS, heapProfileInterval} ptr <*> #{peek PROFILING_FLAGS, heapProfileIntervalTicks} ptr - <*> #{peek PROFILING_FLAGS, includeTSOs} ptr - <*> #{peek PROFILING_FLAGS, showCCSOnException} ptr + <*> (toBool <$> + (#{peek PROFILING_FLAGS, includeTSOs} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek PROFILING_FLAGS, showCCSOnException} ptr :: IO CBool)) <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr <*> #{peek PROFILING_FLAGS, ccsLength} ptr <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, modSelector} ptr) @@ -457,15 +513,22 @@ getTraceFlags = do let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr TraceFlags <$> (toEnum . fromIntegral <$> (#{peek TRACE_FLAGS, tracing} ptr :: IO CInt)) - <*> #{peek TRACE_FLAGS, timestamp} ptr - <*> #{peek TRACE_FLAGS, scheduler} ptr - <*> #{peek TRACE_FLAGS, gc} ptr - <*> #{peek TRACE_FLAGS, sparks_sampled} ptr - <*> #{peek TRACE_FLAGS, sparks_full} ptr - <*> #{peek TRACE_FLAGS, user} ptr + <*> (toBool <$> + (#{peek TRACE_FLAGS, timestamp} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, scheduler} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, gc} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, sparks_sampled} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, sparks_full} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek TRACE_FLAGS, user} ptr :: IO CBool)) getTickyFlags :: IO TickyFlags getTickyFlags = do let ptr = (#ptr RTS_FLAGS, TickyFlags) rtsFlagsPtr - TickyFlags <$> #{peek TICKY_FLAGS, showTickyStats} ptr + TickyFlags <$> (toBool <$> + (#{peek TICKY_FLAGS, showTickyStats} ptr :: IO CBool)) <*> (peekFilePath =<< #{peek TICKY_FLAGS, tickyFile} ptr) diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs index 49c0606878..ef9d8df2e5 100644 --- a/libraries/base/GHC/Read.hs +++ b/libraries/base/GHC/Read.hs @@ -36,6 +36,9 @@ module GHC.Read , choose , readListDefault, readListPrecDefault , readNumber + , readField + , readFieldHash + , readSymField -- Temporary , readParen @@ -69,6 +72,7 @@ import GHC.Show import GHC.Base import GHC.Arr import GHC.Word +import GHC.List (filter) -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with @@ -359,10 +363,71 @@ choose sps = foldr ((+++) . try_one) pfail sps L.Symbol s' | s==s' -> p _other -> pfail } +-- See Note [Why readField] + +-- | 'Read' parser for a record field, of the form @fieldName=value@. The +-- @fieldName@ must be an alphanumeric identifier; for symbols (operator-style) +-- field names, e.g. @(#)@, use 'readSymField'). The second argument is a +-- parser for the field value. +readField :: String -> ReadPrec a -> ReadPrec a +readField fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Punc "=") + readVal +{-# NOINLINE readField #-} + +-- See Note [Why readField] + +-- | 'Read' parser for a record field, of the form @fieldName#=value@. That is, +-- an alphanumeric identifier @fieldName@ followed by the symbol @#@. The +-- second argument is a parser for the field value. +-- +-- Note that 'readField' does not suffice for this purpose due to +-- <https://ghc.haskell.org/trac/ghc/ticket/5041 Trac #5041>. +readFieldHash :: String -> ReadPrec a -> ReadPrec a +readFieldHash fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Symbol "#") + expectP (L.Punc "=") + readVal +{-# NOINLINE readFieldHash #-} + +-- See Note [Why readField] + +-- | 'Read' parser for a symbol record field, of the form @(###)=value@ (where +-- @###@ is the field name). The field name must be a symbol (operator-style), +-- e.g. @(#)@. For regular (alphanumeric) field names, use 'readField'. The +-- second argument is a parser for the field value. +readSymField :: String -> ReadPrec a -> ReadPrec a +readSymField fieldName readVal = do + expectP (L.Punc "(") + expectP (L.Symbol fieldName) + expectP (L.Punc ")") + expectP (L.Punc "=") + readVal +{-# NOINLINE readSymField #-} + + +-- Note [Why readField] +-- +-- Previously, the code for automatically deriving Read instance (in +-- typecheck/TcGenDeriv.hs) would generate inline code for parsing fields; +-- this, however, turned out to produce massive amounts of intermediate code, +-- and produced a considerable performance hit in the code generator. +-- Since Read instances are not generally supposed to be perfomance critical, +-- the readField and readSymField functions have been factored out, and the +-- code generator now just generates calls rather than manually inlining the +-- parsers. For large record types (e.g. 500 fields), this produces a +-- significant performance boost. +-- +-- See also Trac #14364. + + -------------------------------------------------------------- -- Simple instances of Read -------------------------------------------------------------- +-- | @since 2.01 deriving instance Read GeneralCategory -- | @since 2.01 @@ -412,6 +477,9 @@ instance Read Ordering where readListPrec = readListPrecDefault readList = readListDefault +-- | @since 4.11.0.0 +deriving instance Read a => Read (NonEmpty a) + -------------------------------------------------------------- -- Structure instances of Read: Maybe, List etc -------------------------------------------------------------- @@ -549,6 +617,19 @@ instance Read Integer where readListPrec = readListPrecDefault readList = readListDefault + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (fromInteger n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#else +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (Natural n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#endif + -- | @since 2.01 instance Read Float where readPrec = readNumber convertFrac diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index 1154091dd5..c96959f55b 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -20,12 +20,16 @@ module GHC.Real where +#include "MachDeps.h" + import GHC.Base import GHC.Num import GHC.List import GHC.Enum import GHC.Show -import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException, ratioZeroDenomException ) +import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException + , underflowException + , ratioZeroDenomException ) #if defined(OPTIMISE_INTEGER_GCD_LCM) # if defined(MIN_VERSION_integer_gmp) @@ -61,12 +65,21 @@ ratioZeroDenominatorError = raise# ratioZeroDenomException overflowError :: a overflowError = raise# overflowException +{-# NOINLINE underflowError #-} +underflowError :: a +underflowError = raise# underflowException + + -------------------------------------------------------------- -- The Ratio and Rational types -------------------------------------------------------------- -- | Rational numbers, with numerator and denominator of some 'Integral' type. -data Ratio a = !a :% !a deriving (Eq) +-- +-- Note that `Ratio`'s instances inherit the deficiencies from the type +-- parameter's. For example, @Ratio Natural@'s 'Num' instance has similar +-- problems to `Numeric.Natural.Natural`'s. +data Ratio a = !a :% !a deriving Eq -- ^ @since 2.01 -- | Arbitrary-precision rational numbers, represented as a ratio of -- two 'Integer' values. A rational number may be constructed using @@ -122,6 +135,19 @@ class (Num a, Ord a) => Real a where toRational :: a -> Rational -- | Integral numbers, supporting integer division. +-- +-- The Haskell Report defines no laws for 'Integral'. However, 'Integral' +-- instances are customarily expected to define a Euclidean domain and have the +-- following properties for the 'div'/'mod' and 'quot'/'rem' pairs, given +-- suitable Euclidean functions @f@ and @g@: +-- +-- * @x@ = @y * quot x y + rem x y@ with @rem x y@ = @fromInteger 0@ or +-- @g (rem x y)@ < @g y@ +-- * @x@ = @y * div x y + mod x y@ with @mod x y@ = @fromInteger 0@ or +-- @f (mod x y)@ < @f y@ +-- +-- An example of a suitable Euclidean function, for `Integer`'s instance, is +-- 'abs'. class (Real a, Enum a) => Integral a where -- | integer division truncated toward zero quot :: a -> a -> a @@ -155,6 +181,16 @@ class (Real a, Enum a) => Integral a where where qr@(q,r) = quotRem n d -- | Fractional numbers, supporting real division. +-- +-- The Haskell Report defines no laws for 'Fractional'. However, '(+)' and +-- '(*)' are customarily expected to define a division ring and have the +-- following properties: +-- +-- [__'recip' gives the multiplicative inverse__]: +-- @x * recip x@ = @recip x * x@ = @fromInteger 1@ +-- +-- Note that it /isn't/ customarily expected that a type instance of +-- 'Fractional' implement a field. However, all instances in @base@ do. class (Num a) => Fractional a where {-# MINIMAL fromRational, (recip | (/)) #-} @@ -216,10 +252,19 @@ class (Real a, Fractional a) => RealFrac a where -- These 'numeric' enumerations come straight from the Report numericEnumFrom :: (Fractional a) => a -> [a] -numericEnumFrom n = n `seq` (n : numericEnumFrom (n + 1)) +numericEnumFrom n = go 0 + where + -- See Note [Numeric Stability of Enumerating Floating Numbers] + go !k = let !n' = n + k + in n' : go (k + 1) numericEnumFromThen :: (Fractional a) => a -> a -> [a] -numericEnumFromThen n m = n `seq` m `seq` (n : numericEnumFromThen m (m+m-n)) +numericEnumFromThen n m = go 0 + where + step = m - n + -- See Note [Numeric Stability of Enumerating Floating Numbers] + go !k = let !n' = n + k * step + in n' : go (k + 1) numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a] numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n) @@ -232,6 +277,49 @@ numericEnumFromThenTo e1 e2 e3 predicate | e2 >= e1 = (<= e3 + mid) | otherwise = (>= e3 + mid) +{- Note [Numeric Stability of Enumerating Floating Numbers] +----------------------------------------------------------- +When enumerate floating numbers, we could add the increment to the last number +at every run (as what we did previously): + + numericEnumFrom n = n `seq` (n : numericEnumFrom (n + 1)) + +This approach is concise and really fast, only needs an addition operation. +However when a floating number is large enough, for `n`, `n` and `n+1` will +have the same binary representation. For example (all number has type +`Double`): + + 9007199254740990 is: 0x433ffffffffffffe + 9007199254740990 + 1 is: 0x433fffffffffffff + (9007199254740990 + 1) + 1 is: 0x4340000000000000 + ((9007199254740990 + 1) + 1) + 1 is: 0x4340000000000000 + +When we evaluate ([9007199254740990..9007199254740991] :: Double), we would +never reach the condition in `numericEnumFromTo` + + 9007199254740990 + 1 + 1 + ... > 9007199254740991 + 1/2 + +We would fall into infinite loop (as reported in Trac #15081). + +To remedy the situation, we record the number of `1` that needed to be added +to the start number, rather than increasing `1` at every time. This approach +can improvement the numeric stability greatly at the cost of a multiplication. + +Furthermore, we use the type of the enumerated number, `Fractional a => a`, +as the type of multiplier. In rare situations, the multiplier could be very +large and will lead to the enumeration to infinite loop, too, which should +be very rare. Consider the following example: + + [1..9007199254740994] + +We could fix that by using an Integer as multiplier but we don't do that. +The benchmark on T7954.hs shows that this approach leads to significant +degeneration on performance (33% increase allocation and 300% increase on +elapsed time). + +See Trac #15081 and Phab:D4650 for the related discussion about this problem. +-} + -------------------------------------------------------------- -- Instances for Int -------------------------------------------------------------- @@ -324,6 +412,18 @@ instance Integral Word where instance Real Integer where toRational x = x :% 1 +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Real Natural where + toRational (NatS# w) = toRational (W# w) + toRational (NatJ# bn) = toRational (Jp# bn) +#else +-- | @since 4.8.0.0 +instance Real Natural where + toRational (Natural a) = toRational a + {-# INLINE toRational #-} +#endif + -- Note [Integer division constant folding] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -366,6 +466,39 @@ instance Integral Integer where n `quotRem` d = case n `quotRemInteger` d of (# q, r #) -> (q, r) +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Integral Natural where + toInteger = naturalToInteger + + divMod = quotRemNatural + div = quotNatural + mod = remNatural + + quotRem = quotRemNatural + quot = quotNatural + rem = remNatural +#else +-- | @since 4.8.0.0 +instance Integral Natural where + quot (Natural a) (Natural b) = Natural (quot a b) + {-# INLINE quot #-} + rem (Natural a) (Natural b) = Natural (rem a b) + {-# INLINE rem #-} + div (Natural a) (Natural b) = Natural (div a b) + {-# INLINE div #-} + mod (Natural a) (Natural b) = Natural (mod a b) + {-# INLINE mod #-} + divMod (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = divMod a b + {-# INLINE divMod #-} + quotRem (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = quotRem a b + {-# INLINE quotRem #-} + toInteger (Natural a) = a + {-# INLINE toInteger #-} +#endif + -------------------------------------------------------------- -- Instances for @Ratio@ -------------------------------------------------------------- @@ -454,6 +587,17 @@ fromIntegral = fromInteger . toInteger "fromIntegral/Word->Word" fromIntegral = id :: Word -> Word #-} +{-# RULES +"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural +"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer +"fromIntegral/Natural->Word" fromIntegral = naturalToWord + #-} + +{-# RULES +"fromIntegral/Word->Natural" fromIntegral = wordToNatural +"fromIntegral/Int->Natural" fromIntegral = intToNatural + #-} + -- | general coercion to fractional types realToFrac :: (Real a, Fractional b) => a -> b {-# NOINLINE [1] realToFrac #-} @@ -493,17 +637,23 @@ x0 ^ y0 | y0 < 0 = errorWithoutStackTrace "Negative exponent" where -- f : x0 ^ y0 = x ^ y f x y | even y = f (x * x) (y `quot` 2) | y == 1 = x - | otherwise = g (x * x) ((y - 1) `quot` 2) x + | otherwise = g (x * x) (y `quot` 2) x -- See Note [Half of y - 1] -- g : x0 ^ y0 = (x ^ y) * z g x y z | even y = g (x * x) (y `quot` 2) z | y == 1 = x * z - | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) + | otherwise = g (x * x) (y `quot` 2) (x * z) -- See Note [Half of y - 1] -- | raise a number to an integral power (^^) :: (Fractional a, Integral b) => a -> b -> a {-# INLINABLE [1] (^^) #-} -- See Note [Inlining (^) x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) +{- Note [Half of y - 1] + ~~~~~~~~~~~~~~~~~~~~~ + Since y is guaranteed to be odd and positive here, + half of y - 1 can be computed as y `quot` 2, optimising subtraction away. +-} + {- Note [Inlining (^) ~~~~~~~~~~~~~~~~~~~~~ The INLINABLE pragma allows (^) to be specialised at its call sites. @@ -527,9 +677,7 @@ x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) be statically resolved to 0 or 1 are rare. It might be desirable to have corresponding rules also for - exponents of other types, in particular Word, but we can't - have those rules here (importing GHC.Word or GHC.Int would - create a cyclic module dependency), and it's doubtful they + exponents of other types (e. g., Word), but it's doubtful they would fire, since the exponents of other types tend to get floated out before the rule has a chance to fire. @@ -631,6 +779,7 @@ gcd x y = gcd' (abs x) (abs y) -- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide. lcm :: (Integral a) => a -> a -> a {-# SPECIALISE lcm :: Int -> Int -> Int #-} +{-# SPECIALISE lcm :: Word -> Word -> Word #-} {-# NOINLINE [1] lcm #-} lcm _ 0 = 0 lcm 0 _ = 0 @@ -641,12 +790,13 @@ lcm x y = abs ((x `quot` (gcd x y)) * y) "gcd/Int->Int->Int" gcd = gcdInt' "gcd/Integer->Integer->Integer" gcd = gcdInteger "lcm/Integer->Integer->Integer" lcm = lcmInteger +"gcd/Natural->Natural->Natural" gcd = gcdNatural +"lcm/Natural->Natural->Natural" lcm = lcmNatural #-} gcdInt' :: Int -> Int -> Int gcdInt' (I# x) (I# y) = I# (gcdInt x y) -#if MIN_VERSION_integer_gmp(1,0,0) {-# RULES "gcd/Word->Word->Word" gcd = gcdWord' #-} @@ -654,7 +804,6 @@ gcdInt' (I# x) (I# y) = I# (gcdInt x y) gcdWord' :: Word -> Word -> Word gcdWord' (W# x) (W# y) = W# (gcdWord x y) #endif -#endif integralEnumFrom :: (Integral a, Bounded a) => a -> [a] integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)] diff --git a/libraries/base/GHC/Real.hs-boot b/libraries/base/GHC/Real.hs-boot new file mode 100644 index 0000000000..b462c1c299 --- /dev/null +++ b/libraries/base/GHC/Real.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Real where + +import GHC.Types () + +class Integral a diff --git a/libraries/base/GHC/ResponseFile.hs b/libraries/base/GHC/ResponseFile.hs new file mode 100644 index 0000000000..804bd44ff7 --- /dev/null +++ b/libraries/base/GHC/ResponseFile.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ResponseFile +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : portable +-- +-- GCC style response files. +-- +-- @since 4.12.0.0 +---------------------------------------------------------------------------- + +-- Migrated from Haddock. + +module GHC.ResponseFile ( + getArgsWithResponseFiles, + unescapeArgs, + escapeArgs, + expandResponse + ) where + +import Control.Exception +import Data.Char (isSpace) +import Data.Foldable (foldl') +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--\'two\' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\"" +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechasnism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\"" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like '@foo' will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs index 4e00c0e85f..ccc123d303 100644 --- a/libraries/base/GHC/ST.hs +++ b/libraries/base/GHC/ST.hs @@ -18,7 +18,7 @@ module GHC.ST ( ST(..), STret(..), STRep, - fixST, runST, + runST, -- * Unsafe functions liftST, unsafeInterleaveST, unsafeDupableInterleaveST @@ -26,16 +26,17 @@ module GHC.ST ( import GHC.Base import GHC.Show +import qualified Control.Monad.Fail as Fail default () --- The state-transformer monad proper. By default the monad is strict; +-- The 'ST' monad proper. By default the monad is strict; -- too many people got bitten by space leaks when it was lazy. --- | The strict state-transformer monad. --- A computation of type @'ST' s a@ transforms an internal state indexed --- by @s@, and returns a value of type @a@. --- The @s@ parameter is either +-- | The strict 'ST' monad. +-- The 'ST' monad allows for destructive updates, but is escapable (unlike IO). +-- A computation of type @'ST' s a@ returns a value of type @a@, and +-- execute in "thread" @s@. The @s@ parameter is either -- -- * an uninstantiated type variable (inside invocations of 'runST'), or -- @@ -77,10 +78,21 @@ instance Monad (ST s) where case (k r) of { ST k2 -> (k2 new_s) }}) +-- | @since 4.11.0.0 +instance Fail.MonadFail (ST s) where + fail s = errorWithoutStackTrace s + +-- | @since 4.11.0.0 +instance Semigroup a => Semigroup (ST s a) where + (<>) = liftA2 (<>) + +-- | @since 4.11.0.0 +instance Monoid a => Monoid (ST s a) where + mempty = pure mempty + data STret s a = STret (State# s) a --- liftST is useful when we want a lifted result from an ST computation. See --- fixST below. +-- liftST is useful when we want a lifted result from an ST computation. liftST :: ST s a -> State# s -> STret s a liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r @@ -113,23 +125,13 @@ unsafeDupableInterleaveST (ST m) = ST ( \ s -> (# s, r #) ) --- | Allow the result of a state transformer computation to be used (lazily) --- inside the computation. --- Note that if @f@ is strict, @'fixST' f = _|_@. -fixST :: (a -> ST s a) -> ST s a -fixST k = ST $ \ s -> - let ans = liftST (k r) s - STret _ r = ans - in - case ans of STret s' x -> (# s', x #) - -- | @since 2.01 instance Show (ST s a) where showsPrec _ _ = showString "<<ST action>>" showList = showList__ (showsPrec 0) {-# INLINE runST #-} --- | Return the value computed by a state transformer computation. +-- | Return the value computed by a state thread. -- The @forall@ ensures that the internal state used by the 'ST' -- computation is inaccessible to the rest of the program. runST :: (forall s. ST s a) -> a diff --git a/libraries/base/GHC/STRef.hs b/libraries/base/GHC/STRef.hs index a6e4292ddb..6ee9e7bab7 100644 --- a/libraries/base/GHC/STRef.hs +++ b/libraries/base/GHC/STRef.hs @@ -24,9 +24,21 @@ module GHC.STRef ( import GHC.ST import GHC.Base +-- $setup +-- import Prelude + data STRef s a = STRef (MutVar# s a) -- ^ a value of type @STRef s a@ is a mutable variable in state thread @s@, -- containing a value of type @a@ +-- +-- >>> :{ +-- runST (do +-- ref <- newSTRef "hello" +-- x <- readSTRef ref +-- writeSTRef ref (x ++ "world") +-- readSTRef ref ) +-- :} +-- "helloworld" -- |Build a new 'STRef' in the current state thread newSTRef :: a -> ST s (STRef s a) diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 6965335e64..a41bf81cb3 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -53,6 +53,8 @@ import GHC.Base import GHC.List ((!!), foldr1, break) import GHC.Num import GHC.Stack.Types +import GHC.Types (TypeLitSort (..)) + -- | The @shows@ functions return a function that prepends the -- output 'String' to an existing 'String'. This allows constant-time @@ -163,6 +165,7 @@ appPrec1 = I# 11# -- appPrec + 1 -- Simple Instances -------------------------------------------------------------- +-- | @since 2.01 deriving instance Show () -- | @since 2.01 @@ -172,7 +175,10 @@ instance Show a => Show [a] where {-# SPECIALISE instance Show [Int] #-} showsPrec _ = showList +-- | @since 2.01 deriving instance Show Bool + +-- | @since 2.01 deriving instance Show Ordering -- | @since 2.01 @@ -197,15 +203,19 @@ showWord w# cs c# -> showWord (w# `quotWord#` 10##) (C# c# : cs) +-- | @since 2.01 deriving instance Show a => Show (Maybe a) +-- | @since 4.11.0.0 +deriving instance Show a => Show (NonEmpty a) + -- | @since 2.01 instance Show TyCon where showsPrec p (TyCon _ _ _ tc_name _ _) = showsPrec p tc_name -- | @since 4.9.0.0 instance Show TrName where - showsPrec _ (TrNameS s) = showString (unpackCString# s) + showsPrec _ (TrNameS s) = showString (unpackCStringUtf8# s) showsPrec _ (TrNameD s) = showString s -- | @since 4.9.0.0 @@ -216,6 +226,7 @@ instance Show Module where instance Show CallStack where showsPrec _ = shows . getCallStack +-- | @since 4.9.0.0 deriving instance Show SrcLoc -------------------------------------------------------------- @@ -468,7 +479,14 @@ instance Show Integer where | otherwise = integerToString n r showList = showList__ (showsPrec 0) --- Divide an conquer implementation of string conversion +-- | @since 4.8.0.0 +instance Show Natural where +#if defined(MIN_VERSION_integer_gmp) + showsPrec p (NatS# w#) = showsPrec p (W# w#) +#endif + showsPrec p i = showsPrec p (naturalToInteger i) + +-- Divide and conquer implementation of string conversion integerToString :: Integer -> String -> String integerToString n0 cs0 | n0 < 0 = '-' : integerToString' (- n0) cs0 @@ -546,3 +564,46 @@ integerToString n0 cs0 c@(C# _) -> jblock' (d - 1) q (c : cs) where (q, r) = n `quotRemInt` 10 + +instance Show KindRep where + showsPrec d (KindRepVar v) = showParen (d > 10) $ + showString "KindRepVar " . showsPrec 11 v + showsPrec d (KindRepTyConApp p q) = showParen (d > 10) $ + showString "KindRepTyConApp " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + showsPrec d (KindRepApp p q) = showParen (d > 10) $ + showString "KindRepApp " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + showsPrec d (KindRepFun p q) = showParen (d > 10) $ + showString "KindRepFun " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + showsPrec d (KindRepTYPE rep) = showParen (d > 10) $ + showString "KindRepTYPE " . showsPrec 11 rep + showsPrec d (KindRepTypeLitS p q) = showParen (d > 10) $ + showString "KindRepTypeLitS " + . showsPrec 11 p + . showString " " + . showsPrec 11 (unpackCString# q) + showsPrec d (KindRepTypeLitD p q) = showParen (d > 10) $ + showString "KindRepTypeLitD " + . showsPrec 11 p + . showString " " + . showsPrec 11 q + +-- | @since 4.11.0.0 +deriving instance Show RuntimeRep + +-- | @since 4.11.0.0 +deriving instance Show VecCount + +-- | @since 4.11.0.0 +deriving instance Show VecElem + +-- | @since 4.11.0.0 +deriving instance Show TypeLitSort diff --git a/libraries/base/GHC/Stable.hs b/libraries/base/GHC/Stable.hs index 73095bd44a..dd585c363b 100644 --- a/libraries/base/GHC/Stable.hs +++ b/libraries/base/GHC/Stable.hs @@ -57,7 +57,7 @@ newStablePtr a = IO $ \ s -> -- | -- Obtain the Haskell value referenced by a stable pointer, i.e., the -- same value that was passed to the corresponding call to --- 'makeStablePtr'. If the argument to 'deRefStablePtr' has +-- 'newStablePtr'. If the argument to 'deRefStablePtr' has -- already been freed using 'freeStablePtr', the behaviour of -- 'deRefStablePtr' is undefined. -- @@ -101,7 +101,7 @@ castStablePtrToPtr (StablePtr s) = Ptr (unsafeCoerce# s) castPtrToStablePtr :: Ptr () -> StablePtr a castPtrToStablePtr (Ptr a) = StablePtr (unsafeCoerce# a) --- | @since 2.1 +-- | @since 2.01 instance Eq (StablePtr a) where (StablePtr sp1) == (StablePtr sp2) = case eqStablePtr# sp1 sp2 of diff --git a/libraries/base/GHC/StableName.hs b/libraries/base/GHC/StableName.hs new file mode 100644 index 0000000000..7369f41d72 --- /dev/null +++ b/libraries/base/GHC/StableName.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Mem.StableName +-- 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 +-- +-- Stable names are a way of performing fast (O(1)), not-quite-exact +-- comparison between objects. +-- +-- Stable names solve the following problem: suppose you want to build +-- a hash table with Haskell objects as keys, but you want to use +-- pointer equality for comparison; maybe because the keys are large +-- and hashing would be slow, or perhaps because the keys are infinite +-- in size. We can\'t build a hash table using the address of the +-- object as the key, because objects get moved around by the garbage +-- collector, meaning a re-hash would be necessary after every garbage +-- collection. +-- +------------------------------------------------------------------------------- + +module GHC.StableName ( + -- * Stable Names + StableName (..), + makeStableName, + hashStableName, + eqStableName + ) where + +import GHC.IO ( IO(..) ) +import GHC.Base ( Int(..), StableName#, makeStableName# + , eqStableName#, stableNameToInt# ) + +----------------------------------------------------------------------------- +-- Stable Names + +{-| + An abstract name for an object, that supports equality and hashing. + + Stable names have the following property: + + * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@ + then @sn1@ and @sn2@ were created by calls to @makeStableName@ on + the same object. + + The reverse is not necessarily true: if two stable names are not + equal, then the objects they name may still be equal. Note in particular + that `makeStableName` may return a different `StableName` after an + object is evaluated. + + Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), + but differ in the following ways: + + * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s. + Stable names are reclaimed by the runtime system when they are no + longer needed. + + * There is no @deRefStableName@ operation. You can\'t get back from + a stable name to the original Haskell object. The reason for + this is that the existence of a stable name for an object does not + guarantee the existence of the object itself; it can still be garbage + collected. +-} + +data StableName a = StableName (StableName# a) + +-- | Makes a 'StableName' for an arbitrary object. The object passed as +-- the first argument is not evaluated by 'makeStableName'. +makeStableName :: a -> IO (StableName a) +makeStableName a = IO $ \ s -> + case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) + +-- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not +-- necessarily unique; several 'StableName's may map to the same 'Int' +-- (in practice however, the chances of this are small, so the result +-- of 'hashStableName' makes a good hash key). +hashStableName :: StableName a -> Int +hashStableName (StableName sn) = I# (stableNameToInt# sn) + +-- | @since 2.01 +instance Eq (StableName a) where + (StableName sn1) == (StableName sn2) = + case eqStableName# sn1 sn2 of + 0# -> False + _ -> True + +-- | Equality on 'StableName' that does not require that the types of +-- the arguments match. +-- +-- @since 4.7.0.0 +eqStableName :: StableName a -> StableName b -> Bool +eqStableName (StableName sn1) (StableName sn2) = + case eqStableName# sn1 sn2 of + 0# -> False + _ -> True + -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to + -- use it for implementing observable sharing. + diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs index f5b175c0bb..1f102c9f9b 100644 --- a/libraries/base/GHC/Stack.hs +++ b/libraries/base/GHC/Stack.hs @@ -85,7 +85,10 @@ popCallStack stk = case stk of -- -- @since 4.9.0.0 callStack :: HasCallStack => CallStack -callStack = popCallStack ?callStack +callStack = + case ?callStack of + EmptyCallStack -> EmptyCallStack + _ -> popCallStack ?callStack {-# INLINE callStack #-} -- | Perform some computation without adding new entries to the 'CallStack'. diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc index 51eb6244a4..ba384a13b4 100644 --- a/libraries/base/GHC/Stack/CCS.hsc +++ b/libraries/base/GHC/Stack/CCS.hsc @@ -48,34 +48,50 @@ import GHC.List ( concatMap, reverse ) #define PROFILING #include "Rts.h" +-- | A cost-centre stack from GHC's cost-center profiler. data CostCentreStack + +-- | A cost-centre from GHC's cost-center profiler. data CostCentre +-- | Returns the current 'CostCentreStack' (value is @nullPtr@ if the current +-- program was not compiled with profiling support). Takes a dummy argument +-- which can be used to avoid the call to @getCurrentCCS@ being floated out by +-- the simplifier, which would result in an uninformative stack ("CAF"). getCurrentCCS :: dummy -> IO (Ptr CostCentreStack) getCurrentCCS dummy = IO $ \s -> case getCurrentCCS## dummy s of (## s', addr ##) -> (## s', Ptr addr ##) +-- | Get the 'CostCentreStack' associated with the given value. getCCSOf :: a -> IO (Ptr CostCentreStack) getCCSOf obj = IO $ \s -> case getCCSOf## obj s of (## s', addr ##) -> (## s', Ptr addr ##) +-- | Run a computation with an empty cost-center stack. For example, this is +-- used by the interpreter to run an interpreted computation without the call +-- stack showing that it was invoked from GHC. clearCCS :: IO a -> IO a clearCCS (IO m) = IO $ \s -> clearCCS## m s +-- | Get the 'CostCentre' at the head of a 'CostCentreStack'. ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) ccsCC p = (# peek CostCentreStack, cc) p +-- | Get the tail of a 'CostCentreStack'. ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack) ccsParent p = (# peek CostCentreStack, prevStack) p +-- | Get the label of a 'CostCentre'. ccLabel :: Ptr CostCentre -> IO CString ccLabel p = (# peek CostCentre, label) p +-- | Get the module of a 'CostCentre'. ccModule :: Ptr CostCentre -> IO CString ccModule p = (# peek CostCentre, module) p +-- | Get the source span of a 'CostCentre'. ccSrcSpan :: Ptr CostCentre -> IO CString ccSrcSpan p = (# peek CostCentre, srcloc) p @@ -92,6 +108,7 @@ ccSrcSpan p = (# peek CostCentre, srcloc) p currentCallStack :: IO [String] currentCallStack = ccsToStrings =<< getCurrentCCS () +-- | Format a 'CostCentreStack' as a list of lines. ccsToStrings :: Ptr CostCentreStack -> IO [String] ccsToStrings ccs0 = go ccs0 [] where diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs index 54352b19de..45b11216a5 100644 --- a/libraries/base/GHC/Stack/Types.hs +++ b/libraries/base/GHC/Stack/Types.hs @@ -51,8 +51,9 @@ import GHC.Classes (Eq) import GHC.Types (Char, Int) -- Make implicit dependency known to build system -import GHC.Tuple () -import GHC.Integer () +import GHC.Tuple () -- See Note [Depend on GHC.Tuple] in GHC.Base +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base +import GHC.Natural () -- See Note [Depend on GHC.Natural] in GHC.Base ---------------------------------------------------------------------- -- Explicit call-stacks built via ImplicitParams @@ -75,25 +76,28 @@ type HasCallStack = (?callStack :: CallStack) -- For example, we can define -- -- @ --- errorWithCallStack :: HasCallStack => String -> a +-- putStrLnWithCallStack :: HasCallStack => String -> IO () -- @ -- --- as a variant of @error@ that will get its call-site. We can access the --- call-stack inside @errorWithCallStack@ with 'GHC.Stack.callStack'. +-- as a variant of @putStrLn@ that will get its call-site and print it, +-- along with the string given as argument. We can access the +-- call-stack inside @putStrLnWithCallStack@ with 'GHC.Stack.callStack'. -- -- @ --- errorWithCallStack :: HasCallStack => String -> a --- errorWithCallStack msg = error (msg ++ "\n" ++ prettyCallStack callStack) +-- putStrLnWithCallStack :: HasCallStack => String -> IO () +-- putStrLnWithCallStack msg = do +-- putStrLn msg +-- putStrLn (prettyCallStack callStack) -- @ -- --- Thus, if we call @errorWithCallStack@ we will get a formatted call-stack --- alongside our error message. +-- Thus, if we call @putStrLnWithCallStack@ we will get a formatted call-stack +-- alongside our string. -- -- --- >>> errorWithCallStack "die" --- *** Exception: die +-- >>> putStrLnWithCallStack "hello" +-- hello -- CallStack (from HasCallStack): --- errorWithCallStack, called at <interactive>:2:1 in interactive:Ghci1 +-- putStrLnWithCallStack, called at <interactive>:2:1 in interactive:Ghci1 -- -- -- GHC solves 'HasCallStack' constraints in three steps: @@ -212,4 +216,4 @@ data SrcLoc = SrcLoc , srcLocStartCol :: Int , srcLocEndLine :: Int , srcLocEndCol :: Int - } deriving Eq + } deriving Eq -- ^ @since 4.9.0.0 diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs index 65ec483577..42ca0927dc 100644 --- a/libraries/base/GHC/StaticPtr.hs +++ b/libraries/base/GHC/StaticPtr.hs @@ -28,6 +28,11 @@ -- table is known as the Static Pointer Table. The reference can then be -- dereferenced to obtain the value. -- +-- The various communicating processes need to aggree on the keys used to refer +-- to the values in the Static Pointer Table, or lookups will fail. Only +-- processes launched from the same program binary are guaranteed to use the +-- same set of keys. +-- ----------------------------------------------------------------------------- module GHC.StaticPtr @@ -54,7 +59,7 @@ import GHC.Word (Word64(..)) #include "MachDeps.h" --- | A reference to a value of type 'a'. +-- | A reference to a value of type @a@. #if WORD_SIZE_IN_BITS < 64 data StaticPtr a = StaticPtr Word64# Word64# -- The flattened Fingerprint is -- convenient in the compiler. @@ -67,7 +72,7 @@ data StaticPtr a = StaticPtr Word# Word# deRefStaticPtr :: StaticPtr a -> a deRefStaticPtr (StaticPtr _ _ _ v) = v --- | A key for `StaticPtrs` that can be serialized and used with +-- | A key for 'StaticPtr's that can be serialized and used with -- 'unsafeLookupStaticPtr'. type StaticKey = Fingerprint @@ -110,7 +115,7 @@ data StaticPtrInfo = StaticPtrInfo -- @(Line, Column)@ pair. , spInfoSrcLoc :: (Int, Int) } - deriving (Show) + deriving Show -- ^ @since 4.8.0.0 -- | 'StaticPtrInfo' of the given 'StaticPtr'. staticPtrInfo :: StaticPtr a -> StaticPtrInfo diff --git a/libraries/base/GHC/Stats.hsc b/libraries/base/GHC/Stats.hsc index 58fb12592f..58b5e22d04 100644 --- a/libraries/base/GHC/Stats.hsc +++ b/libraries/base/GHC/Stats.hsc @@ -18,20 +18,12 @@ module GHC.Stats RTSStats(..), GCDetails(..), RtsTime , getRTSStats , getRTSStatsEnabled - - -- * DEPRECATED, don't use - , GCStats(..) - , getGCStats - , getGCStatsEnabled ) where -import Control.Applicative import Control.Monad import Data.Int import Data.Word import GHC.Base -import GHC.Num (Num(..)) -import GHC.Real (quot, fromIntegral, (/)) import GHC.Read ( Read ) import GHC.Show ( Show ) import GHC.IO.Exception @@ -45,14 +37,14 @@ foreign import ccall "getRTSStats" getRTSStats_ :: Ptr () -> IO () -- | Returns whether GC stats have been enabled (with @+RTS -T@, for example). -- --- @since 4.9.0.0 +-- @since 4.10.0.0 foreign import ccall "getRTSStatsEnabled" getRTSStatsEnabled :: IO Bool -- -- | Statistics about runtime activity since the start of the -- program. This is a mirror of the C @struct RTSStats@ in @RtsAPI.h@ -- --- @since 4.9.0.0 +-- @since 4.10.0.0 -- data RTSStats = RTSStats { -- ----------------------------------- @@ -64,7 +56,8 @@ data RTSStats = RTSStats { , major_gcs :: Word32 -- | Total bytes allocated , allocated_bytes :: Word64 - -- | Maximum live data (including large objects + compact regions) + -- | Maximum live data (including large objects + compact regions) in the + -- heap. Updated after a major GC. , max_live_bytes :: Word64 -- | Maximum live data in large objects , max_large_objects_bytes :: Word64 @@ -91,6 +84,12 @@ data RTSStats = RTSStats { -- (we use signed values here because due to inaccuracies in timers -- the values can occasionally go slightly negative) + -- | Total CPU time used by the init phase + -- @since 4.12.0.0 + , init_cpu_ns :: RtsTime + -- | Total elapsed time used by the init phase + -- @since 4.12.0.0 + , init_elapsed_ns :: RtsTime -- | Total CPU time used by the mutator , mutator_cpu_ns :: RtsTime -- | Total elapsed time used by the mutator @@ -106,7 +105,9 @@ data RTSStats = RTSStats { -- | Details about the most recent GC , gc :: GCDetails - } deriving (Read, Show) + } deriving ( Read -- ^ @since 4.10.0.0 + , Show -- ^ @since 4.10.0.0 + ) -- -- | Statistics about a single GC. This is a mirror of the C @struct @@ -120,7 +121,9 @@ data GCDetails = GCDetails { , gcdetails_threads :: Word32 -- | Number of bytes allocated since the previous GC , gcdetails_allocated_bytes :: Word64 - -- | Total amount of live data in the heap (incliudes large + compact data) + -- | Total amount of live data in the heap (incliudes large + compact data). + -- Updated after every GC. Data in uncollected generations (in minor GCs) + -- are considered live. , gcdetails_live_bytes :: Word64 -- | Total amount of live data in large objects , gcdetails_large_objects_bytes :: Word64 @@ -143,21 +146,25 @@ data GCDetails = GCDetails { , gcdetails_cpu_ns :: RtsTime -- | The time elapsed during GC itself , gcdetails_elapsed_ns :: RtsTime - } deriving (Read, Show) + } deriving ( Read -- ^ @since 4.10.0.0 + , Show -- ^ @since 4.10.0.0 + ) -- | Time values from the RTS, using a fixed resolution of nanoseconds. type RtsTime = Int64 --- @since 4.9.0.0 +-- | Get current runtime system statistics. +-- +-- @since 4.10.0.0 -- getRTSStats :: IO RTSStats getRTSStats = do - statsEnabled <- getGCStatsEnabled + statsEnabled <- getRTSStatsEnabled unless statsEnabled . ioError $ IOError Nothing UnsupportedOperation "" - "getGCStats: GC stats not enabled. Use `+RTS -T -RTS' to enable them." + "GHC.Stats.getRTSStats: GC stats not enabled. Use `+RTS -T -RTS' to enable them." Nothing Nothing allocaBytes (#size RTSStats) $ \p -> do @@ -177,6 +184,8 @@ getRTSStats = do (# peek RTSStats, cumulative_par_max_copied_bytes) p cumulative_par_balanced_copied_bytes <- (# peek RTSStats, cumulative_par_balanced_copied_bytes) p + init_cpu_ns <- (# peek RTSStats, init_cpu_ns) p + init_elapsed_ns <- (# peek RTSStats, init_elapsed_ns) p mutator_cpu_ns <- (# peek RTSStats, mutator_cpu_ns) p mutator_elapsed_ns <- (# peek RTSStats, mutator_elapsed_ns) p gc_cpu_ns <- (# peek RTSStats, gc_cpu_ns) p @@ -204,136 +213,3 @@ getRTSStats = do gcdetails_elapsed_ns <- (# peek GCDetails, elapsed_ns) pgc return GCDetails{..} return RTSStats{..} - --- ----------------------------------------------------------------------------- --- DEPRECATED API - --- I'm probably violating a bucket of constraints here... oops. - --- | Statistics about memory usage and the garbage collector. Apart from --- 'currentBytesUsed' and 'currentBytesSlop' all are cumulative values since --- the program started. --- --- @since 4.5.0.0 -{-# DEPRECATED GCStats "Use RTSStats instead. This will be removed in GHC 8.4.1" #-} -data GCStats = GCStats - { -- | Total number of bytes allocated - bytesAllocated :: !Int64 - -- | Number of garbage collections performed (any generation, major and - -- minor) - , numGcs :: !Int64 - -- | Maximum number of live bytes seen so far - , maxBytesUsed :: !Int64 - -- | Number of byte usage samples taken, or equivalently - -- the number of major GCs performed. - , numByteUsageSamples :: !Int64 - -- | Sum of all byte usage samples, can be used with - -- 'numByteUsageSamples' to calculate averages with - -- arbitrary weighting (if you are sampling this record multiple - -- times). - , cumulativeBytesUsed :: !Int64 - -- | Number of bytes copied during GC - , bytesCopied :: !Int64 - -- | Number of live bytes at the end of the last major GC - , currentBytesUsed :: !Int64 - -- | Current number of bytes lost to slop - , currentBytesSlop :: !Int64 - -- | Maximum number of bytes lost to slop at any one time so far - , maxBytesSlop :: !Int64 - -- | Maximum number of megabytes allocated - , peakMegabytesAllocated :: !Int64 - -- | CPU time spent running mutator threads. This does not include - -- any profiling overhead or initialization. - , mblocksAllocated :: !Int64 -- ^ Number of allocated megablocks - , mutatorCpuSeconds :: !Double - - -- | Wall clock time spent running mutator threads. This does not - -- include initialization. - , mutatorWallSeconds :: !Double - -- | CPU time spent running GC - , gcCpuSeconds :: !Double - -- | Wall clock time spent running GC - , gcWallSeconds :: !Double - -- | Total CPU time elapsed since program start - , cpuSeconds :: !Double - -- | Total wall clock time elapsed since start - , wallSeconds :: !Double - -- | Number of bytes copied during GC, minus space held by mutable - -- lists held by the capabilities. Can be used with - -- 'parMaxBytesCopied' to determine how well parallel GC utilized - -- all cores. - , parTotBytesCopied :: !Int64 - - -- | Sum of number of bytes copied each GC by the most active GC - -- 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. This is included for - -- backwards compatibility; to compute work balance use - -- `parBalancedBytesCopied`. - , parMaxBytesCopied :: !Int64 - - -- | Sum of number of balanced bytes copied on each thread of each GC. - -- Balanced bytes are those up to a - -- limit = (parTotBytesCopied / num_gc_threads). - -- This number is normalized so that when balance is perfect - -- @parBalancedBytesCopied = parTotBytesCopied@ and when all - -- gc is done by a single thread @parBalancedBytesCopied = 0@. - , parBalancedBytesCopied :: !Int64 - - } deriving (Show, Read) - --- | Retrieves garbage collection and memory statistics as of the last --- garbage collection. If you would like your statistics as recent as --- possible, first run a 'System.Mem.performGC'. --- --- @since 4.5.0.0 -{-# DEPRECATED getGCStats - "Use getRTSStats instead. This will be removed in GHC 8.4.1" #-} -getGCStats :: IO GCStats -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 RTSStats) $ \p -> do - getRTSStats_ p - bytesAllocated <- (# peek RTSStats, allocated_bytes) p - numGcs <- (# peek RTSStats, gcs ) p - numByteUsageSamples <- (# peek RTSStats, major_gcs ) p - maxBytesUsed <- (# peek RTSStats, max_live_bytes ) p - cumulativeBytesUsed <- (# peek RTSStats, cumulative_live_bytes ) p - bytesCopied <- (# peek RTSStats, copied_bytes ) p - currentBytesUsed <- (# peek RTSStats, gc.live_bytes ) p - currentBytesSlop <- (# peek RTSStats, gc.slop_bytes) p - maxBytesSlop <- (# peek RTSStats, max_slop_bytes) p - peakMegabytesAllocated <- do - bytes <- (# peek RTSStats, max_mem_in_use_bytes ) p - return (bytes `quot` (1024*1024)) - mblocksAllocated <- do - bytes <- (# peek RTSStats, gc.mem_in_use_bytes) p - return (bytes `quot` (1024*1024)) - mutatorCpuSeconds <- nsToSecs <$> (# peek RTSStats, mutator_cpu_ns) p - mutatorWallSeconds <- - nsToSecs <$> (# peek RTSStats, mutator_elapsed_ns) p - gcCpuSeconds <- nsToSecs <$> (# peek RTSStats, gc_cpu_ns) p - gcWallSeconds <- nsToSecs <$> (# peek RTSStats, gc_elapsed_ns) p - cpuSeconds <- nsToSecs <$> (# peek RTSStats, cpu_ns) p - wallSeconds <- nsToSecs <$> (# peek RTSStats, elapsed_ns) p - parTotBytesCopied <- (# peek RTSStats, par_copied_bytes) p - parMaxBytesCopied <- (# peek RTSStats, cumulative_par_max_copied_bytes) p - parBalancedBytesCopied <- - (# peek RTSStats, cumulative_par_balanced_copied_bytes) p - return GCStats { .. } - -nsToSecs :: Int64 -> Double -nsToSecs ns = fromIntegral ns / (# const TIME_RESOLUTION) - -{-# DEPRECATED getGCStatsEnabled - "use getRTSStatsEnabled instead. This will be removed in GHC 8.4.1" #-} -getGCStatsEnabled :: IO Bool -getGCStatsEnabled = getRTSStatsEnabled diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs index 0964db98ba..7e3e514be9 100644 --- a/libraries/base/GHC/TypeLits.hs +++ b/libraries/base/GHC/TypeLits.hs @@ -9,7 +9,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -- for compiling instances of (==) {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} @@ -35,6 +34,7 @@ module GHC.TypeLits -- * Functions on type literals , type (N.<=), type (N.<=?), type (N.+), type (N.*), type (N.^), type (N.-) + , type N.Div, type N.Mod, type N.Log2 , AppendSymbol , N.CmpNat, CmpSymbol @@ -44,7 +44,7 @@ module GHC.TypeLits ) where -import GHC.Base(Eq(..), Ord(..), Bool(True,False), Ordering(..), otherwise) +import GHC.Base(Eq(..), Ord(..), Ordering(..), otherwise) import GHC.Types( Nat, Symbol ) import GHC.Num(Integer, fromInteger) import GHC.Base(String) @@ -54,7 +54,7 @@ import GHC.Real(toInteger) import GHC.Prim(magicDict, Proxy#) import Data.Maybe(Maybe(..)) import Data.Proxy (Proxy(..)) -import Data.Type.Equality(type (==), (:~:)(Refl)) +import Data.Type.Equality((:~:)(Refl)) import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats (KnownNat) @@ -122,11 +122,6 @@ instance Show SomeSymbol where instance Read SomeSymbol where readsPrec p xs = [ (someSymbolVal a, ys) | (a,ys) <- readsPrec p xs ] -type family EqSymbol (a :: Symbol) (b :: Symbol) where - EqSymbol a a = 'True - EqSymbol a b = 'False -type instance a == b = EqSymbol a b - -------------------------------------------------------------------------------- -- | Comparison of type-level symbols, as a function. @@ -158,7 +153,7 @@ data {-kind-} ErrorMessage = Text Symbol infixl 5 :$$: infixl 6 :<>: --- | The type-level equivalent of 'error'. +-- | The type-level equivalent of 'Prelude.error'. -- -- The polymorphic kind of this type allows it to be used in several settings. -- For instance, it can be used as a constraint, e.g. to provide a better error diff --git a/libraries/base/GHC/TypeNats.hs b/libraries/base/GHC/TypeNats.hs index cb75367ac8..b78608af89 100644 --- a/libraries/base/GHC/TypeNats.hs +++ b/libraries/base/GHC/TypeNats.hs @@ -3,13 +3,13 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -- for compiling instances of (==) {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} @@ -34,10 +34,11 @@ module GHC.TypeNats -- * Functions on type literals , type (<=), type (<=?), type (+), type (*), type (^), type (-) , CmpNat + , Div, Mod, Log2 ) where -import GHC.Base(Eq(..), Ord(..), Bool(True,False), Ordering(..), otherwise) +import GHC.Base(Eq(..), Ord(..), Bool(True), Ordering(..), otherwise) import GHC.Types( Nat ) import GHC.Natural(Natural) import GHC.Show(Show(..)) @@ -45,7 +46,7 @@ import GHC.Read(Read(..)) import GHC.Prim(magicDict, Proxy#) import Data.Maybe(Maybe(..)) import Data.Proxy (Proxy(..)) -import Data.Type.Equality(type (==), (:~:)(Refl)) +import Data.Type.Equality((:~:)(Refl)) import Unsafe.Coerce(unsafeCoerce) -------------------------------------------------------------------------------- @@ -95,19 +96,16 @@ instance Read SomeNat where readsPrec p xs = do (a,ys) <- readsPrec p xs [(someNatVal a, ys)] -type family EqNat (a :: Nat) (b :: Nat) where - EqNat a a = 'True - EqNat a b = 'False -type instance a == b = EqNat a b - -------------------------------------------------------------------------------- infix 4 <=?, <= infixl 6 +, - -infixl 7 * +infixl 7 *, `Div`, `Mod` infixr 8 ^ -- | Comparison of type-level naturals, as a constraint. +-- +-- @since 4.7.0.0 type x <= y = (x <=? y) ~ 'True -- | Comparison of type-level naturals, as a function. @@ -122,12 +120,18 @@ Please let us know, if you encounter discrepancies between the two. -} type family (m :: Nat) <=? (n :: Nat) :: Bool -- | Addition of type-level naturals. +-- +-- @since 4.7.0.0 type family (m :: Nat) + (n :: Nat) :: Nat -- | Multiplication of type-level naturals. +-- +-- @since 4.7.0.0 type family (m :: Nat) * (n :: Nat) :: Nat -- | Exponentiation of type-level naturals. +-- +-- @since 4.7.0.0 type family (m :: Nat) ^ (n :: Nat) :: Nat -- | Subtraction of type-level naturals. @@ -135,6 +139,24 @@ type family (m :: Nat) ^ (n :: Nat) :: Nat -- @since 4.7.0.0 type family (m :: Nat) - (n :: Nat) :: Nat +-- | Division (round down) of natural numbers. +-- @Div x 0@ is undefined (i.e., it cannot be reduced). +-- +-- @since 4.11.0.0 +type family Div (m :: Nat) (n :: Nat) :: Nat + +-- | Modulus of natural numbers. +-- @Mod x 0@ is undefined (i.e., it cannot be reduced). +-- +-- @since 4.11.0.0 +type family Mod (m :: Nat) (n :: Nat) :: Nat + +-- | Log base 2 (round down) of natural numbers. +-- @Log 0@ is undefined (i.e., it cannot be reduced). +-- +-- @since 4.11.0.0 +type family Log2 (m :: Nat) :: Nat + -------------------------------------------------------------------------------- -- | We either get evidence that this function was instantiated with the diff --git a/libraries/base/GHC/Unicode.hs b/libraries/base/GHC/Unicode.hs index 0e2ce4c0ef..6d453cbc9a 100644 --- a/libraries/base/GHC/Unicode.hs +++ b/libraries/base/GHC/Unicode.hs @@ -7,7 +7,7 @@ -- Module : GHC.Unicode -- Copyright : (c) The University of Glasgow, 2003 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC extensions) @@ -71,7 +71,7 @@ import GHC.Show ( Show ) -- >>> enumFromTo ModifierLetter SpacingCombiningMark -- [ModifierLetter,OtherLetter,NonSpacingMark,SpacingCombiningMark] -- --- 'Read' instance: +-- 'Text.Read.Read' instance: -- -- >>> read "DashPunctuation" :: GeneralCategory -- DashPunctuation @@ -129,7 +129,13 @@ data GeneralCategory | Surrogate -- ^ Cs: Other, Surrogate | PrivateUse -- ^ Co: Other, Private Use | NotAssigned -- ^ Cn: Other, Not Assigned - deriving (Show, Eq, Ord, Enum, Bounded, Ix) + deriving ( Show -- ^ @since 2.01 + , Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Enum -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Ix -- ^ @since 2.01 + ) -- | The Unicode general category of the character. This relies on the -- 'Enum' instance of 'GeneralCategory', which must remain in the @@ -214,11 +220,12 @@ isLower :: Char -> Bool -- This function is equivalent to 'Data.Char.isLetter'. isAlpha :: Char -> Bool --- | Selects alphabetic or numeric digit Unicode characters. +-- | Selects alphabetic or numeric Unicode characters. -- --- Note that numeric digits outside the ASCII range are selected by this --- function but not by 'isDigit'. Such digits may be part of identifiers --- but are not used by the printer and reader to represent numbers. +-- Note that numeric digits outside the ASCII range, as well as numeric +-- characters which aren't digits, are selected by this function but not by +-- 'isDigit'. Such characters may be part of identifiers but are not used by +-- the printer and reader to represent numbers. isAlphaNum :: Char -> Bool -- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@. @@ -394,4 +401,3 @@ foreign import ccall unsafe "u_towtitle" foreign import ccall unsafe "u_gencat" wgencat :: Int -> Int - diff --git a/libraries/base/GHC/Weak.hs b/libraries/base/GHC/Weak.hs index 8f886a6d23..6a53096828 100644 --- a/libraries/base/GHC/Weak.hs +++ b/libraries/base/GHC/Weak.hs @@ -149,8 +149,9 @@ runFinalizerBatch (I# n) arr = 0# -> (# s, () #) _ -> let !m' = m -# 1# in case indexArray# arr m' of { (# io #) -> - case io s of { s' -> - unIO (go m') s' + case catch# (\p -> (# io p, () #)) + (\_ s'' -> (# s'', () #)) s of { + (# s', _ #) -> unIO (go m') s' }} in go n diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 1df9d14693..18cc4dbcc4 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -972,3 +972,33 @@ byteSwap64 (W64# w#) = W64# (byteSwap64# w#) byteSwap64 :: Word64 -> Word64 byteSwap64 (W64# w#) = W64# (byteSwap# w#) #endif + +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Word8" + fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord +"fromIntegral/Natural->Word16" + fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord +"fromIntegral/Natural->Word32" + fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord + #-} + +{-# RULES +"fromIntegral/Word8->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) +"fromIntegral/Word16->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) +"fromIntegral/Word32->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 +{-# RULES +"fromIntegral/Natural->Word64" + fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord +"fromIntegral/Word64->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) + #-} +#endif |