diff options
Diffstat (limited to 'libraries')
42 files changed, 514 insertions, 292 deletions
diff --git a/libraries/Cabal b/libraries/Cabal -Subproject e6304ff660ca629b1b664f0848a601959e31cb3 +Subproject b083151f2a01ad7245f21502fd20f21189ab766 diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs index a2f342f83f..6770234926 100644 --- a/libraries/base/Control/Applicative.hs +++ b/libraries/base/Control/Applicative.hs @@ -96,7 +96,7 @@ instance Monad m => Functor (WrappedMonad m) where fmap f (WrapMonad v) = WrapMonad (liftM f v) instance Monad m => Applicative (WrappedMonad m) where - pure = WrapMonad . return + pure = WrapMonad . pure WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) instance MonadPlus m => Alternative (WrappedMonad m) where diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs index 9d09544eeb..1cc6062516 100644 --- a/libraries/base/Control/Arrow.hs +++ b/libraries/base/Control/Arrow.hs @@ -93,16 +93,14 @@ class Category a => Arrow a where -- | Send the first component of the input through the argument -- arrow, and copy the rest unchanged to the output. first :: a b c -> a (b,d) (c,d) + first = (*** id) -- | A mirror image of 'first'. -- -- The default definition may be overridden with a more efficient -- version if desired. second :: a b c -> a (d,b) (d,c) - second f = arr swap >>> first f >>> arr swap - where - swap :: (x,y) -> (y,x) - swap ~(x,y) = (y,x) + second = (id ***) -- | Split the input between the two argument arrows and combine -- their output. Note that this is in general not a functor. @@ -110,7 +108,8 @@ class Category a => Arrow a where -- The default definition may be overridden with a more efficient -- version if desired. (***) :: a b c -> a b' c' -> a (b,b') (c,c') - f *** g = first f >>> second g + f *** g = first f >>> arr swap >>> first g >>> arr swap + where swap ~(x,y) = (y,x) -- | Fanout: send the input to both argument arrows and combine -- their output. @@ -141,8 +140,6 @@ class Category a => Arrow a where instance Arrow (->) where arr f = f - first f = f *** id - second f = id *** f -- (f *** g) ~(x,y) = (f x, g y) -- sorry, although the above defn is fully H'98, nhc98 can't parse it. (***) f g ~(x,y) = (f x, g y) @@ -314,7 +311,6 @@ instance Arrow a => Applicative (ArrowMonad a) where ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id)) instance ArrowApply a => Monad (ArrowMonad a) where - return x = ArrowMonad (arr (\_ -> x)) ArrowMonad m >>= f = ArrowMonad $ m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index 35248bfba3..1786c3ded3 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -3,6 +3,7 @@ , MagicHash , UnboxedTuples , ScopedTypeVariables + , RankNTypes #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN @@ -73,6 +74,7 @@ module Control.Concurrent ( -- $boundthreads rtsSupportsBoundThreads, forkOS, + forkOSWithUnmask, isCurrentThreadBound, runInBoundThread, runInUnboundThread, @@ -180,7 +182,7 @@ attribute will block all other threads. -} --- | fork a thread and call the supplied function when the thread is about +-- | Fork a thread and call the supplied function when the thread is about -- to terminate, with an exception or a returned value. The function is -- called with asynchronous exceptions masked. -- @@ -316,6 +318,11 @@ forkOS action0 return tid | otherwise = failNonThreaded +-- | Like 'forkIOWithUnmask', but the child thread is a bound thread, +-- as with 'forkOS'. +forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkOSWithUnmask io = forkOS (io unsafeUnmask) + -- | Returns 'True' if the calling thread is /bound/, that is, if it is -- safe to use foreign libraries that rely on thread-local state from the -- calling thread. diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs index 55b28cfc9a..c99912e62d 100644 --- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs +++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs @@ -71,13 +71,11 @@ instance Functor (ST s) where (f r,new_s) instance Applicative (ST s) where - pure = return + pure a = ST $ \ s -> (a,s) (<*>) = ap instance Monad (ST s) where - return a = ST $ \ s -> (a,s) - m >> k = m >>= \ _ -> k fail s = error s (ST m) >>= k diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 84b1c031b1..9134e13ba8 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -515,11 +515,7 @@ instance Bits Integer where complement = complementInteger shift x i@(I# i#) | i >= 0 = shiftLInteger x i# | otherwise = shiftRInteger x (negateInt# i#) - shiftL x (I# i#) = shiftLInteger x i# - shiftR x (I# i#) = shiftRInteger x i# - testBit x (I# i) = testBitInteger x i - zeroBits = 0 #if HAVE_INTEGER_GMP1 diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs index 09314f163e..31550d5ac7 100644 --- a/libraries/base/Data/Complex.hs +++ b/libraries/base/Data/Complex.hs @@ -213,5 +213,4 @@ instance Applicative Complex where f :+ g <*> a :+ b = f a :+ g b instance Monad Complex where - return a = a :+ a a :+ b >>= f = realPart (f a) :+ imagPart (f b) diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs index d727e5219d..50e95824c8 100644 --- a/libraries/base/Data/Either.hs +++ b/libraries/base/Data/Either.hs @@ -134,7 +134,6 @@ instance Applicative (Either e) where Right f <*> r = fmap f r instance Monad (Either e) where - return = Right Left l >>= _ = Left l Right r >>= k = k r diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs index 9f7ae24e66..46fb66650c 100644 --- a/libraries/base/Data/Functor/Identity.hs +++ b/libraries/base/Data/Functor/Identity.hs @@ -88,7 +88,6 @@ instance Applicative Identity where (<*>) = coerce instance Monad Identity where - return = Identity m >>= k = k (runIdentity m) instance MonadFix Identity where diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs index 6698a0ba58..d8bad07c7b 100644 --- a/libraries/base/Data/List/NonEmpty.hs +++ b/libraries/base/Data/List/NonEmpty.hs @@ -189,7 +189,6 @@ instance Applicative NonEmpty where (<*>) = ap instance Monad NonEmpty where - return a = a :| [] ~(a :| as) >>= f = b :| (bs ++ bs') where b :| bs = f a bs' = as >>= toList . f diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index c5a4d8bdf9..eff3836396 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -82,7 +82,6 @@ instance Applicative Dual where (<*>) = coerce instance Monad Dual where - return = Dual m >>= k = k (getDual m) -- | The monoid of endomorphisms under composition. @@ -126,7 +125,6 @@ instance Applicative Sum where (<*>) = coerce instance Monad Sum where - return = Sum m >>= k = k (getSum m) -- | Monoid under multiplication. @@ -146,7 +144,6 @@ instance Applicative Product where (<*>) = coerce instance Monad Product where - return = Product m >>= k = k (getProduct m) -- $MaybeExamples diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs index a9146214c0..2dad8e4e78 100644 --- a/libraries/base/Data/Proxy.hs +++ b/libraries/base/Data/Proxy.hs @@ -90,8 +90,6 @@ instance Applicative Proxy where {-# INLINE (<*>) #-} instance Monad Proxy where - return _ = Proxy - {-# INLINE return #-} _ >>= _ = Proxy {-# INLINE (>>=) #-} diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs index 661e513cba..f3f9f0b326 100644 --- a/libraries/base/Data/Semigroup.hs +++ b/libraries/base/Data/Semigroup.hs @@ -332,8 +332,7 @@ instance Applicative Min where Min f <*> Min x = Min (f x) instance Monad Min where - return = Min - _ >> a = a + (>>) = (*>) Min a >>= f = f a instance MonadFix Min where @@ -389,8 +388,7 @@ instance Applicative Max where Max f <*> Max x = Max (f x) instance Monad Max where - return = Max - _ >> a = a + (>>) = (*>) Max a >>= f = f a instance MonadFix Max where @@ -476,8 +474,7 @@ instance Applicative First where First f <*> First x = First (f x) instance Monad First where - return = First - _ >> a = a + (>>) = (*>) First a >>= f = f a instance MonadFix First where @@ -523,8 +520,7 @@ instance Applicative Last where Last f <*> Last x = Last (f x) instance Monad Last where - return = Last - _ >> a = a + (>>) = (*>) Last a >>= f = f a instance MonadFix Last where @@ -584,14 +580,13 @@ instance Applicative Option where pure a = Option (Just a) Option a <*> Option b = Option (a <*> b) -instance Monad Option where - return = pure + Option Nothing *> _ = Option Nothing + _ *> b = b +instance Monad Option where Option (Just a) >>= k = k a _ >>= _ = Option Nothing - - Option Nothing >> _ = Option Nothing - _ >> b = b + (>>) = (*>) instance Alternative Option where empty = Option Nothing diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs index 81e639cf37..9da76c6a34 100644 --- a/libraries/base/Data/Traversable.hs +++ b/libraries/base/Data/Traversable.hs @@ -196,9 +196,9 @@ instance Traversable Proxy where {-# INLINE traverse #-} sequenceA _ = pure Proxy {-# INLINE sequenceA #-} - mapM _ _ = return Proxy + mapM _ _ = pure Proxy {-# INLINE mapM #-} - sequence _ = return Proxy + sequence _ = pure Proxy {-# INLINE sequence #-} instance Traversable (Const m) where diff --git a/libraries/base/Data/Version.hs b/libraries/base/Data/Version.hs index aba8cf7f74..414b2aa859 100644 --- a/libraries/base/Data/Version.hs +++ b/libraries/base/Data/Version.hs @@ -36,7 +36,8 @@ module Data.Version ( makeVersion ) where -import Control.Monad ( Monad(..), liftM ) +import Data.Functor ( Functor(..) ) +import Control.Applicative ( Applicative(..) ) import Data.Bool ( (&&) ) import Data.Char ( isDigit, isAlphaNum ) import Data.Eq @@ -120,9 +121,9 @@ showVersion (Version branch tags) -- | A parser for versions in the format produced by 'showVersion'. -- parseVersion :: ReadP Version -parseVersion = do branch <- sepBy1 (liftM read (munch1 isDigit)) (char '.') - tags <- many (char '-' >> munch1 isAlphaNum) - return Version{versionBranch=branch, versionTags=tags} +parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.') + tags <- many (char '-' *> munch1 isAlphaNum) + pure Version{versionBranch=branch, versionTags=tags} -- | Construct tag-less 'Version' -- diff --git a/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs index 26a19d8f71..653dcab055 100644 --- a/libraries/base/Debug/Trace.hs +++ b/libraries/base/Debug/Trace.hs @@ -150,8 +150,14 @@ traceShowId a = trace (show a) a {-| Like 'trace' but returning unit in an arbitrary 'Applicative' context. Allows -for convenient use in do-notation. Note that the application of 'trace' is not -an action in the 'Applicative' context, as 'traceIO' is in the 'IO' type. +for convenient use in do-notation. + +Note that the application of 'traceM' is not an action in the 'Applicative' +context, as 'traceIO' is in the 'IO' type. While the fresh bindings in the +following example will force the 'traceM' expressions to be reduced every time +the @do@-block is executed, @traceM "not crashed"@ would only be reduced once, +and the message would only be printed once. If your monad is in 'MonadIO', +@liftIO . traceIO@ may be a better option. > ... = do > x <- ... diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 9bd6124e6a..273950b1fb 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -309,7 +309,6 @@ instance Monoid a => Applicative ((,) a) where (u, f) <*> (v, x) = (u `mappend` v, f x) instance Monoid a => Monad ((,) a) where - return x = (mempty, x) (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b) instance Monoid a => Monoid (IO a) where @@ -626,7 +625,6 @@ instance Applicative ((->) a) where (<*>) f g x = f x (g x) instance Monad ((->) r) where - return = const f >>= k = \ r -> k (f r) r instance Functor ((,) a) where @@ -652,7 +650,6 @@ instance Monad Maybe where (>>) = (*>) - return = Just fail _ = Nothing -- ----------------------------------------------------------------------------- @@ -735,8 +732,6 @@ instance Monad [] where xs >>= f = [y | x <- xs, y <- f x] {-# INLINE (>>) #-} (>>) = (*>) - {-# INLINE return #-} - return x = [x] {-# INLINE fail #-} fail _ = [] @@ -1063,18 +1058,19 @@ asTypeOf = const ---------------------------------------------- instance Functor IO where - fmap f x = x >>= (return . f) + fmap f x = x >>= (pure . f) instance Applicative IO where - pure = return - (<*>) = ap + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure = returnIO + m *> k = m >>= \ _ -> k + (<*>) = ap instance Monad IO where - {-# INLINE return #-} {-# INLINE (>>) #-} {-# INLINE (>>=) #-} - m >> k = m >>= \ _ -> k - return = returnIO + (>>) = (*>) (>>=) = bindIO fail s = failIO s diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index db6f841851..83934fe05a 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -626,19 +626,19 @@ unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #)) unSTM (STM a) = a instance Functor STM where - fmap f x = x >>= (return . f) + fmap f x = x >>= (pure . f) instance Applicative STM where - pure = return + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure x = returnSTM x (<*>) = ap + m *> k = thenSTM m k instance Monad STM where - {-# INLINE return #-} - {-# INLINE (>>) #-} {-# INLINE (>>=) #-} - m >> k = thenSTM m k - return x = returnSTM x m >>= k = bindSTM m k + (>>) = (*>) bindSTM :: STM a -> (a -> STM b) -> STM b bindSTM (STM m) k = STM ( \s -> diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index 8cdb10709d..6c40cba570 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -23,7 +23,8 @@ module GHC.Err( absentErr, error, undefined ) where import GHC.CString () -import GHC.Types +import GHC.Types (Char) +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 diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index 3fbae05c9a..02c6cfa54f 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -37,6 +37,7 @@ import Data.Typeable (Typeable, cast) -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show +import GHC.Stack.Types {- | The @SomeException@ type is the root of the exception type hierarchy. diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot index 594f2665e8..f89fed1aa2 100644 --- a/libraries/base/GHC/Exception.hs-boot +++ b/libraries/base/GHC/Exception.hs-boot @@ -28,7 +28,8 @@ module GHC.Exception ( SomeException, errorCallException, errorCallWithCallStackException, divZeroException, overflowException, ratioZeroDenomException ) where -import GHC.Types( Char, CallStack ) +import GHC.Types ( Char ) +import GHC.Stack.Types ( CallStack ) data SomeException divZeroException, overflowException, ratioZeroDenomException :: SomeException diff --git a/libraries/base/GHC/GHCi.hs b/libraries/base/GHC/GHCi.hs index c11863520c..56874a5a12 100644 --- a/libraries/base/GHC/GHCi.hs +++ b/libraries/base/GHC/GHCi.hs @@ -38,11 +38,10 @@ instance Functor NoIO where fmap f (NoIO a) = NoIO (fmap f a) instance Applicative NoIO where - pure = return + pure a = NoIO (pure a) (<*>) = ap instance Monad NoIO where - return a = NoIO (return a) (>>=) k f = NoIO (noio k >>= noio . f) instance GHCiSandboxIO NoIO where diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs index d98533b5b2..3e38930261 100644 --- a/libraries/base/GHC/Generics.hs +++ b/libraries/base/GHC/Generics.hs @@ -8,6 +8,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- | @@ -532,6 +533,65 @@ module GHC.Generics ( -- @ -- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } -- @ + +-- *** Representation of unlifted types +-- +-- | +-- +-- If one were to attempt to derive a Generic instance for a datatype with an +-- unlifted argument (for example, 'Int#'), one might expect the occurrence of +-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, +-- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. +-- In fact, polymorphism over unlifted types is disallowed completely. +-- +-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' +-- instead. With this approach, however, the programmer has no way of knowing +-- whether the 'Int' is actually an 'Int#' in disguise. +-- +-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark +-- occurrences of common unlifted types: +-- +-- @ +-- data family URec a p +-- +-- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } +-- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } +-- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } +-- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } +-- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } +-- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } +-- @ +-- +-- Several type synonyms are provided for convenience: +-- +-- @ +-- type 'UAddr' = 'URec' ('Ptr' ()) +-- type 'UChar' = 'URec' 'Char' +-- type 'UDouble' = 'URec' 'Double' +-- type 'UFloat' = 'URec' 'Float' +-- type 'UInt' = 'URec' 'Int' +-- type 'UWord' = 'URec' 'Word' +-- @ +-- +-- The declaration +-- +-- @ +-- data IntHash = IntHash Int# +-- deriving 'Generic' +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic' IntHash where +-- type 'Rep' IntHash = +-- 'D1' D1IntHash +-- ('C1' C1_0IntHash +-- ('S1' 'NoSelector' 'UInt')) +-- @ +-- +-- Currently, only the six unlifted types listed above are generated, but this +-- may be extended to encompass more unlifted types in the future. #if 0 -- *** Limitations -- @@ -548,6 +608,11 @@ module GHC.Generics ( V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..) + -- ** Unboxed representation types + , URec(..) + , type UAddr, type UChar, type UDouble + , type UFloat, type UInt, type UWord + -- ** Synonyms for convenience , Rec0, Par0, R, P , D1, C1, S1, D, C, S @@ -562,6 +627,8 @@ module GHC.Generics ( ) where -- We use some base types +import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) +import GHC.Ptr ( Ptr ) import GHC.Types import Data.Maybe ( Maybe(..) ) import Data.Either ( Either(..) ) @@ -614,6 +681,46 @@ infixr 7 :.: newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) } deriving (Eq, Ord, Read, Show, Generic) +-- | Constants of kind @#@ +data family URec (a :: *) (p :: *) + +-- | Used for marking occurrences of 'Addr#' +data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } + deriving (Eq, Ord, Generic) + +-- | Used for marking occurrences of 'Char#' +data instance URec Char p = UChar { uChar# :: Char# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Double#' +data instance URec Double p = UDouble { uDouble# :: Double# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Float#' +data instance URec Float p = UFloat { uFloat# :: Float# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Int#' +data instance URec Int p = UInt { uInt# :: Int# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Word#' +data instance URec Word p = UWord { uWord# :: Word# } + deriving (Eq, Ord, Show, Generic) + +-- | Type synonym for 'URec': 'Addr#' +type UAddr = URec (Ptr ()) +-- | Type synonym for 'URec': 'Char#' +type UChar = URec Char +-- | Type synonym for 'URec': 'Double#' +type UDouble = URec Double +-- | Type synonym for 'URec': 'Float#' +type UFloat = URec Float +-- | Type synonym for 'URec': 'Int#' +type UInt = URec Int +-- | Type synonym for 'URec': 'Word#' +type UWord = URec Word + -- | Tag for K1: recursion (of kind *) data R -- | Tag for K1: parameters (other than the last) @@ -642,7 +749,6 @@ type C1 = M1 C -- | Type synonym for encoding meta-information for record selectors type S1 = M1 S - -- | Class for datatypes that represent datatypes class Datatype (d :: *) where -- | The name of the datatype (unqualified) diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs index d5320522a5..46c5196c9e 100644 --- a/libraries/base/GHC/ST.hs +++ b/libraries/base/GHC/ST.hs @@ -58,16 +58,15 @@ instance Functor (ST s) where (# new_s, f r #) } instance Applicative (ST s) where - pure = return + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure x = ST (\ s -> (# s, x #)) + m *> k = m >>= \ _ -> k (<*>) = ap instance Monad (ST s) where - {-# INLINE return #-} - {-# INLINE (>>) #-} {-# INLINE (>>=) #-} - return x = ST (\ s -> (# s, x #)) - m >> k = m >>= \ _ -> k - + (>>) = (*>) (ST m) >>= k = ST (\ s -> case (m s) of { (# new_s, r #) -> diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc index a2283ff656..6ef1fa5d25 100644 --- a/libraries/base/GHC/Stack.hsc +++ b/libraries/base/GHC/Stack.hsc @@ -22,6 +22,9 @@ module GHC.Stack ( whoCreated, errorWithStackTrace, + -- * Implicit parameter call stacks + SrcLoc(..), CallStack(..), + -- * Internals CostCentreStack, CostCentre, diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs new file mode 100644 index 0000000000..5c37f64713 --- /dev/null +++ b/libraries/base/GHC/Stack/Types.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Stack.Types +-- Copyright : (c) The University of Glasgow 2015 +-- License : see libraries/ghc-prim/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- type definitions for call-stacks via implicit parameters. +-- Use GHC.Exts from the base package instead of importing this +-- module directly. +-- +----------------------------------------------------------------------------- + +module GHC.Stack.Types ( + -- * Implicit parameter call stacks + SrcLoc(..), CallStack(..), + ) where + +import GHC.Types + +-- Make implicit dependency known to build system +import GHC.Tuple () +import GHC.Integer () + +---------------------------------------------------------------------- +-- Explicit call-stacks built via ImplicitParams +---------------------------------------------------------------------- + +-- | @CallStack@s are an alternate method of obtaining the call stack at a given +-- point in the program. +-- +-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will +-- solve it with the current location. If another @CallStack@ implicit-parameter +-- is in-scope (e.g. as a function argument), the new location will be appended +-- to the one in-scope, creating an explicit call-stack. For example, +-- +-- @ +-- myerror :: (?loc :: CallStack) => String -> a +-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) +-- @ +-- ghci> myerror "die" +-- *** Exception: die +-- CallStack: +-- ?loc, called at MyError.hs:7:51 in main:MyError +-- myerror, called at <interactive>:2:1 in interactive:Ghci1 +-- +-- @CallStack@s do not interact with the RTS and do not require compilation with +-- @-prof@. On the other hand, as they are built up explicitly using +-- implicit-parameters, they will generally not contain as much information as +-- the simulated call-stacks maintained by the RTS. +-- +-- A @CallStack@ is a @[(String, SrcLoc)]@. The @String@ is the name of +-- function that was called, the 'SrcLoc' is the call-site. The list is +-- ordered with the most recently called function at the head. +-- +-- @since 4.8.2.0 +data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] } + -- See Note [Overview of implicit CallStacks] + +-- | A single location in the source code. +-- +-- @since 4.8.2.0 +data SrcLoc = SrcLoc + { srcLocPackage :: [Char] + , srcLocModule :: [Char] + , srcLocFile :: [Char] + , srcLocStartLine :: Int + , srcLocStartCol :: Int + , srcLocEndLine :: Int + , srcLocEndCol :: Int + } diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs index 302d027c0a..117d70525a 100644 --- a/libraries/base/GHC/StaticPtr.hs +++ b/libraries/base/GHC/StaticPtr.hs @@ -83,7 +83,7 @@ foreign import ccall unsafe hs_spt_lookup :: Ptr () -> IO (Ptr a) -- | Miscelaneous information available for debugging purposes. data StaticPtrInfo = StaticPtrInfo { -- | Package key of the package where the static pointer is defined - spInfoPackageKey :: String + spInfoUnitId :: String -- | Name of the module where the static pointer is defined , spInfoModuleName :: String -- | An internal name that is distinct for every static pointer defined in diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs index 034411d6bf..bae2abc90e 100644 --- a/libraries/base/Text/ParserCombinators/ReadP.hs +++ b/libraries/base/Text/ParserCombinators/ReadP.hs @@ -103,7 +103,7 @@ data P a -- Monad, MonadPlus instance Applicative P where - pure = return + pure x = Result x Fail (<*>) = ap instance MonadPlus P where @@ -111,8 +111,6 @@ instance MonadPlus P where mplus = (<|>) instance Monad P where - return x = Result x Fail - (Get f) >>= k = Get (\c -> f c >>= k) (Look f) >>= k = Look (\s -> f s >>= k) Fail >>= _ = Fail @@ -161,11 +159,10 @@ instance Functor ReadP where fmap h (R f) = R (\k -> f (k . h)) instance Applicative ReadP where - pure = return + pure x = R (\k -> k x) (<*>) = ap instance Monad ReadP where - return x = R (\k -> k x) fail _ = R (\_ -> Fail) R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs index 027648d9e8..02268364ca 100644 --- a/libraries/base/Text/ParserCombinators/ReadPrec.hs +++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs @@ -75,11 +75,10 @@ instance Functor ReadPrec where fmap h (P f) = P (\n -> fmap h (f n)) instance Applicative ReadPrec where - pure = return + pure x = P (\_ -> pure x) (<*>) = ap instance Monad ReadPrec where - return x = P (\_ -> return x) fail s = P (\_ -> fail s) P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 662f2747d7..326f4579fd 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -252,6 +252,7 @@ Library GHC.Show GHC.Stable GHC.Stack + GHC.Stack.Types GHC.Stats GHC.Storable GHC.TopHandler @@ -341,6 +342,6 @@ Library GHC.Event.TimerManager GHC.Event.Unique - -- We need to set the package key to base (without a version number) + -- We need to set the unit id to base (without a version number) -- as it's magic. ghc-options: -this-package-key base diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index b40bfefe91..24a6e7fd5c 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -62,6 +62,17 @@ super-class of `Monoid` in the future). These modules were provided by the `semigroups` package previously. (#10365) + * Add `URec`, `UAddr`, `UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord` to + `GHC.Generics` as part of making GHC generics capable of handling + unlifted types (#10868) + + * Keep `shift{L,R}` on `Integer` with negative shift-arguments from + segfaulting (#10571) + + * Add `forkOSWithUnmask` to `Control.Concurrent`, which is like + `forkIOWithUnmask`, but the child is run in a bound thread. + + ## 4.8.1.0 *Jul 2015* * Bundled with GHC 7.10.2 diff --git a/libraries/ghc-boot/GHC/Lexeme.hs b/libraries/ghc-boot/GHC/Lexeme.hs new file mode 100644 index 0000000000..677c9a65e6 --- /dev/null +++ b/libraries/ghc-boot/GHC/Lexeme.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Lexeme +-- Copyright : (c) The GHC Team +-- +-- Maintainer : ghc-devs@haskell.org +-- Portability : portable +-- +-- Functions to evaluate whether or not a string is a valid identifier. +-- +module GHC.Lexeme ( + -- * Lexical characteristics of Haskell names + startsVarSym, startsVarId, startsConSym, startsConId, + startsVarSymASCII, isVarSymChar + ) where + +import Data.Char + +startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool +startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids +startsConSym c = c == ':' -- Infix data constructors +startsVarId c = c == '_' || case generalCategory c of -- Ordinary Ids + LowercaseLetter -> True + OtherLetter -> True -- See #1103 + _ -> False +startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors + +startsVarSymASCII :: Char -> Bool +startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" + +isVarSymChar :: Char -> Bool +isVarSymChar c = c == ':' || startsVarSym c diff --git a/libraries/bin-package-db/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs index 672b7ebbe3..fcb24d8a46 100644 --- a/libraries/bin-package-db/GHC/PackageDb.hs +++ b/libraries/ghc-boot/GHC/PackageDb.hs @@ -68,12 +68,13 @@ import System.Directory -- data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename = InstalledPackageInfo { - installedPackageId :: instpkgid, + componentId :: instpkgid, sourcePackageId :: srcpkgid, packageName :: srcpkgname, packageVersion :: Version, - packageKey :: pkgkey, - depends :: [instpkgid], + unitId :: pkgkey, + abiHash :: String, + depends :: [pkgkey], importDirs :: [FilePath], hsLibraries :: [String], extraLibraries :: [String], @@ -87,9 +88,9 @@ data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename includeDirs :: [FilePath], haddockInterfaces :: [FilePath], haddockHTMLs :: [FilePath], - exposedModules :: [ExposedModule instpkgid modulename], + exposedModules :: [ExposedModule pkgkey modulename], hiddenModules :: [modulename], - instantiatedWith :: [(modulename,OriginalModule instpkgid modulename)], + instantiatedWith :: [(modulename,OriginalModule pkgkey modulename)], exposed :: Bool, trusted :: Bool } @@ -99,9 +100,9 @@ data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename -- plus module name) representing where a module was *originally* defined -- (i.e., the 'exposedReexport' field of the original ExposedModule entry should -- be 'Nothing'). Invariant: an OriginalModule never points to a reexport. -data OriginalModule instpkgid modulename +data OriginalModule pkgkey modulename = OriginalModule { - originalPackageId :: instpkgid, + originalPackageId :: pkgkey, originalModuleName :: modulename } deriving (Eq, Show) @@ -128,11 +129,11 @@ data OriginalModule instpkgid modulename -- We use two 'Maybe' data types instead of an ADT with four branches or -- four fields because this representation allows us to treat -- reexports/signatures uniformly. -data ExposedModule instpkgid modulename +data ExposedModule pkgkey modulename = ExposedModule { exposedName :: modulename, - exposedReexport :: Maybe (OriginalModule instpkgid modulename), - exposedSignature :: Maybe (OriginalModule instpkgid modulename) + exposedReexport :: Maybe (OriginalModule pkgkey modulename), + exposedSignature :: Maybe (OriginalModule pkgkey modulename) } deriving (Eq, Show) @@ -145,11 +146,12 @@ emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, => InstalledPackageInfo a b c d e emptyInstalledPackageInfo = InstalledPackageInfo { - installedPackageId = fromStringRep BS.empty, + componentId = fromStringRep BS.empty, sourcePackageId = fromStringRep BS.empty, packageName = fromStringRep BS.empty, packageVersion = Version [] [], - packageKey = fromStringRep BS.empty, + unitId = fromStringRep BS.empty, + abiHash = "", depends = [], importDirs = [], hsLibraries = [], @@ -299,9 +301,9 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, BinaryStringRep d, BinaryStringRep e) => Binary (InstalledPackageInfo a b c d e) where put (InstalledPackageInfo - installedPackageId sourcePackageId - packageName packageVersion packageKey - depends importDirs + componentId sourcePackageId + packageName packageVersion unitId + abiHash depends importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs frameworks frameworkDirs ldOptions ccOptions @@ -309,11 +311,12 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, haddockInterfaces haddockHTMLs exposedModules hiddenModules instantiatedWith exposed trusted) = do - put (toStringRep installedPackageId) + put (toStringRep componentId) put (toStringRep sourcePackageId) put (toStringRep packageName) put packageVersion - put (toStringRep packageKey) + put (toStringRep unitId) + put abiHash put (map toStringRep depends) put importDirs put hsLibraries @@ -335,11 +338,12 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, put trusted get = do - installedPackageId <- get + componentId <- get sourcePackageId <- get packageName <- get packageVersion <- get - packageKey <- get + unitId <- get + abiHash <- get depends <- get importDirs <- get hsLibraries <- get @@ -360,10 +364,11 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, exposed <- get trusted <- get return (InstalledPackageInfo - (fromStringRep installedPackageId) + (fromStringRep componentId) (fromStringRep sourcePackageId) (fromStringRep packageName) packageVersion - (fromStringRep packageKey) + (fromStringRep unitId) + abiHash (map fromStringRep depends) importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs diff --git a/libraries/bin-package-db/LICENSE b/libraries/ghc-boot/LICENSE index b5059b71f6..b5059b71f6 100644 --- a/libraries/bin-package-db/LICENSE +++ b/libraries/ghc-boot/LICENSE diff --git a/libraries/bin-package-db/bin-package-db.cabal b/libraries/ghc-boot/ghc-boot.cabal index a54fe16449..98929b7f83 100644 --- a/libraries/bin-package-db/bin-package-db.cabal +++ b/libraries/ghc-boot/ghc-boot.cabal @@ -1,17 +1,17 @@ -name: bin-package-db +name: ghc-boot version: 0.0.0.0 license: BSD3 maintainer: ghc-devs@haskell.org bug-reports: glasgow-haskell-bugs@haskell.org -synopsis: The GHC compiler's view of the GHC package database format -description: This library is shared between GHC and ghc-pkg and is used by - GHC to read package databases. +synopsis: Shared functionality between GHC and its boot libraries +description: This library is shared between GHC, ghc-pkg, and other boot + libraries. . - It only deals with the subset of the package database that the - compiler cares about: modules paths etc and not package - metadata like description, authors etc. It is thus not a - library interface to ghc-pkg and is *not* suitable for - modifying GHC package databases. + A note about "GHC.PackageDb": it only deals with the subset of + the package database that the compiler cares about: modules + paths etc and not package metadata like description, authors + etc. It is thus not a library interface to ghc-pkg and is *not* + suitable for modifying GHC package databases. . The package database format and this library are constructed in such a way that while ghc-pkg depends on Cabal, the GHC library @@ -22,7 +22,7 @@ build-type: Simple source-repository head type: git location: http://git.haskell.org/ghc.git - subdir: libraries/bin-package-db + subdir: libraries/ghc-boot Library default-language: Haskell2010 @@ -34,6 +34,7 @@ Library TypeSynonymInstances exposed-modules: + GHC.Lexeme GHC.PackageDb build-depends: base >= 4 && < 5, diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 6dcd5f1a7f..294f15e6e4 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -29,8 +29,7 @@ module GHC.Types ( isTrue#, SPEC(..), Nat, Symbol, - Coercible, - SrcLoc(..), CallStack(..) + Coercible ) where import GHC.Prim @@ -309,51 +308,3 @@ you're reading this in 2023 then things went wrong). See #8326. -- Libraries can specify this by using 'SPEC' data type to inform which -- loops should be aggressively specialized. data SPEC = SPEC | SPEC2 - --- | A single location in the source code. --- --- @since 4.8.2.0 -data SrcLoc = SrcLoc - { srcLocPackage :: [Char] - , srcLocModule :: [Char] - , srcLocFile :: [Char] - , srcLocStartLine :: Int - , srcLocStartCol :: Int - , srcLocEndLine :: Int - , srcLocEndCol :: Int - } - ----------------------------------------------------------------------- --- Explicit call-stacks built via ImplicitParams ----------------------------------------------------------------------- - --- | @CallStack@s are an alternate method of obtaining the call stack at a given --- point in the program. --- --- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will --- solve it with the current location. If another @CallStack@ implicit-parameter --- is in-scope (e.g. as a function argument), the new location will be appended --- to the one in-scope, creating an explicit call-stack. For example, --- --- @ --- myerror :: (?loc :: CallStack) => String -> a --- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) --- @ --- ghci> myerror "die" --- *** Exception: die --- CallStack: --- ?loc, called at MyError.hs:7:51 in main:MyError --- myerror, called at <interactive>:2:1 in interactive:Ghci1 --- --- @CallStack@s do not interact with the RTS and do not require compilation with --- @-prof@. On the other hand, as they are built up explicitly using --- implicit-parameters, they will generally not contain as much information as --- the simulated call-stacks maintained by the RTS. --- --- A @CallStack@ is a @[(String, SrcLoc)]@. The @String@ is the name of --- function that was called, the 'SrcLoc' is the call-site. The list is --- ordered with the most recently called function at the head. --- --- @since 4.8.2.0 -data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] } - -- See Note [Overview of implicit CallStacks] diff --git a/libraries/ghc-prim/cbits/atomic.c b/libraries/ghc-prim/cbits/atomic.c index 01cc458e82..2ecbf3461a 100644 --- a/libraries/ghc-prim/cbits/atomic.c +++ b/libraries/ghc-prim/cbits/atomic.c @@ -11,97 +11,97 @@ // FetchAddByteArrayOp_Int -extern StgWord hs_atomic_add8(volatile StgWord8 *x, StgWord val); +extern StgWord hs_atomic_add8(StgWord x, StgWord val); StgWord -hs_atomic_add8(volatile StgWord8 *x, StgWord val) +hs_atomic_add8(StgWord x, StgWord val) { - return __sync_fetch_and_add(x, (StgWord8) val); + return __sync_fetch_and_add((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_add16(volatile StgWord16 *x, StgWord val); +extern StgWord hs_atomic_add16(StgWord x, StgWord val); StgWord -hs_atomic_add16(volatile StgWord16 *x, StgWord val) +hs_atomic_add16(StgWord x, StgWord val) { - return __sync_fetch_and_add(x, (StgWord16) val); + return __sync_fetch_and_add((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_add32(volatile StgWord32 *x, StgWord val); +extern StgWord hs_atomic_add32(StgWord x, StgWord val); StgWord -hs_atomic_add32(volatile StgWord32 *x, StgWord val) +hs_atomic_add32(StgWord x, StgWord val) { - return __sync_fetch_and_add(x, (StgWord32) val); + return __sync_fetch_and_add((volatile StgWord32 *) x, (StgWord32) val); } #if WORD_SIZE_IN_BITS == 64 -extern StgWord64 hs_atomic_add64(volatile StgWord64 *x, StgWord64 val); +extern StgWord64 hs_atomic_add64(StgWord x, StgWord64 val); StgWord64 -hs_atomic_add64(volatile StgWord64 *x, StgWord64 val) +hs_atomic_add64(StgWord x, StgWord64 val) { - return __sync_fetch_and_add(x, val); + return __sync_fetch_and_add((volatile StgWord64 *) x, val); } #endif // FetchSubByteArrayOp_Int -extern StgWord hs_atomic_sub8(volatile StgWord8 *x, StgWord val); +extern StgWord hs_atomic_sub8(StgWord x, StgWord val); StgWord -hs_atomic_sub8(volatile StgWord8 *x, StgWord val) +hs_atomic_sub8(StgWord x, StgWord val) { - return __sync_fetch_and_sub(x, (StgWord8) val); + return __sync_fetch_and_sub((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_sub16(volatile StgWord16 *x, StgWord val); +extern StgWord hs_atomic_sub16(StgWord x, StgWord val); StgWord -hs_atomic_sub16(volatile StgWord16 *x, StgWord val) +hs_atomic_sub16(StgWord x, StgWord val) { - return __sync_fetch_and_sub(x, (StgWord16) val); + return __sync_fetch_and_sub((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_sub32(volatile StgWord32 *x, StgWord val); +extern StgWord hs_atomic_sub32(StgWord x, StgWord val); StgWord -hs_atomic_sub32(volatile StgWord32 *x, StgWord val) +hs_atomic_sub32(StgWord x, StgWord val) { - return __sync_fetch_and_sub(x, (StgWord32) val); + return __sync_fetch_and_sub((volatile StgWord32 *) x, (StgWord32) val); } #if WORD_SIZE_IN_BITS == 64 -extern StgWord64 hs_atomic_sub64(volatile StgWord64 *x, StgWord64 val); +extern StgWord64 hs_atomic_sub64(StgWord x, StgWord64 val); StgWord64 -hs_atomic_sub64(volatile StgWord64 *x, StgWord64 val) +hs_atomic_sub64(StgWord x, StgWord64 val) { - return __sync_fetch_and_sub(x, val); + return __sync_fetch_and_sub((volatile StgWord64 *) x, val); } #endif // FetchAndByteArrayOp_Int -extern StgWord hs_atomic_and8(volatile StgWord8 *x, StgWord val); +extern StgWord hs_atomic_and8(StgWord x, StgWord val); StgWord -hs_atomic_and8(volatile StgWord8 *x, StgWord val) +hs_atomic_and8(StgWord x, StgWord val) { - return __sync_fetch_and_and(x, (StgWord8) val); + return __sync_fetch_and_and((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_and16(volatile StgWord16 *x, StgWord val); +extern StgWord hs_atomic_and16(StgWord x, StgWord val); StgWord -hs_atomic_and16(volatile StgWord16 *x, StgWord val) +hs_atomic_and16(StgWord x, StgWord val) { - return __sync_fetch_and_and(x, (StgWord16) val); + return __sync_fetch_and_and((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_and32(volatile StgWord32 *x, StgWord val); +extern StgWord hs_atomic_and32(StgWord x, StgWord val); StgWord -hs_atomic_and32(volatile StgWord32 *x, StgWord val) +hs_atomic_and32(StgWord x, StgWord val) { - return __sync_fetch_and_and(x, (StgWord32) val); + return __sync_fetch_and_and((volatile StgWord32 *) x, (StgWord32) val); } #if WORD_SIZE_IN_BITS == 64 -extern StgWord64 hs_atomic_and64(volatile StgWord64 *x, StgWord64 val); +extern StgWord64 hs_atomic_and64(StgWord x, StgWord64 val); StgWord64 -hs_atomic_and64(volatile StgWord64 *x, StgWord64 val) +hs_atomic_and64(StgWord x, StgWord64 val) { - return __sync_fetch_and_and(x, val); + return __sync_fetch_and_and((volatile StgWord64 *) x, val); } #endif @@ -117,204 +117,204 @@ hs_atomic_and64(volatile StgWord64 *x, StgWord64 val) return tmp; \ } -extern StgWord hs_atomic_nand8(volatile StgWord8 *x, StgWord val); +extern StgWord hs_atomic_nand8(StgWord x, StgWord val); StgWord -hs_atomic_nand8(volatile StgWord8 *x, StgWord val) +hs_atomic_nand8(StgWord x, StgWord val) { #ifdef __clang__ - CAS_NAND(x, (StgWord8) val) + CAS_NAND((volatile StgWord8 *) x, (StgWord8) val) #else - return __sync_fetch_and_nand(x, (StgWord8) val); + return __sync_fetch_and_nand((volatile StgWord8 *) x, (StgWord8) val); #endif } -extern StgWord hs_atomic_nand16(volatile StgWord16 *x, StgWord val); +extern StgWord hs_atomic_nand16(StgWord x, StgWord val); StgWord -hs_atomic_nand16(volatile StgWord16 *x, StgWord val) +hs_atomic_nand16(StgWord x, StgWord val) { #ifdef __clang__ - CAS_NAND(x, (StgWord16) val); + CAS_NAND((volatile StgWord16 *) x, (StgWord16) val); #else - return __sync_fetch_and_nand(x, (StgWord16) val); + return __sync_fetch_and_nand((volatile StgWord16 *) x, (StgWord16) val); #endif } -extern StgWord hs_atomic_nand32(volatile StgWord32 *x, StgWord val); +extern StgWord hs_atomic_nand32(StgWord x, StgWord val); StgWord -hs_atomic_nand32(volatile StgWord32 *x, StgWord val) +hs_atomic_nand32(StgWord x, StgWord val) { #ifdef __clang__ - CAS_NAND(x, (StgWord32) val); + CAS_NAND((volatile StgWord32 *) x, (StgWord32) val); #else - return __sync_fetch_and_nand(x, (StgWord32) val); + return __sync_fetch_and_nand((volatile StgWord32 *) x, (StgWord32) val); #endif } #if WORD_SIZE_IN_BITS == 64 -extern StgWord64 hs_atomic_nand64(volatile StgWord64 *x, StgWord64 val); +extern StgWord64 hs_atomic_nand64(StgWord x, StgWord64 val); StgWord64 -hs_atomic_nand64(volatile StgWord64 *x, StgWord64 val) +hs_atomic_nand64(StgWord x, StgWord64 val) { #ifdef __clang__ - CAS_NAND(x, val); + CAS_NAND((volatile StgWord64 *) x, val); #else - return __sync_fetch_and_nand(x, val); + return __sync_fetch_and_nand((volatile StgWord64 *) x, val); #endif } #endif // FetchOrByteArrayOp_Int -extern StgWord hs_atomic_or8(volatile StgWord8 *x, StgWord val); +extern StgWord hs_atomic_or8(StgWord x, StgWord val); StgWord -hs_atomic_or8(volatile StgWord8 *x, StgWord val) +hs_atomic_or8(StgWord x, StgWord val) { - return __sync_fetch_and_or(x, (StgWord8) val); + return __sync_fetch_and_or((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_or16(volatile StgWord16 *x, StgWord val); +extern StgWord hs_atomic_or16(StgWord x, StgWord val); StgWord -hs_atomic_or16(volatile StgWord16 *x, StgWord val) +hs_atomic_or16(StgWord x, StgWord val) { - return __sync_fetch_and_or(x, (StgWord16) val); + return __sync_fetch_and_or((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_or32(volatile StgWord32 *x, StgWord val); +extern StgWord hs_atomic_or32(StgWord x, StgWord val); StgWord -hs_atomic_or32(volatile StgWord32 *x, StgWord val) +hs_atomic_or32(StgWord x, StgWord val) { - return __sync_fetch_and_or(x, (StgWord32) val); + return __sync_fetch_and_or((volatile StgWord32 *) x, (StgWord32) val); } #if WORD_SIZE_IN_BITS == 64 -extern StgWord64 hs_atomic_or64(volatile StgWord64 *x, StgWord64 val); +extern StgWord64 hs_atomic_or64(StgWord x, StgWord64 val); StgWord64 -hs_atomic_or64(volatile StgWord64 *x, StgWord64 val) +hs_atomic_or64(StgWord x, StgWord64 val) { - return __sync_fetch_and_or(x, val); + return __sync_fetch_and_or((volatile StgWord64 *) x, val); } #endif // FetchXorByteArrayOp_Int -extern StgWord hs_atomic_xor8(volatile StgWord8 *x, StgWord val); +extern StgWord hs_atomic_xor8(StgWord x, StgWord val); StgWord -hs_atomic_xor8(volatile StgWord8 *x, StgWord val) +hs_atomic_xor8(StgWord x, StgWord val) { - return __sync_fetch_and_xor(x, (StgWord8) val); + return __sync_fetch_and_xor((volatile StgWord8 *) x, (StgWord8) val); } -extern StgWord hs_atomic_xor16(volatile StgWord16 *x, StgWord val); +extern StgWord hs_atomic_xor16(StgWord x, StgWord val); StgWord -hs_atomic_xor16(volatile StgWord16 *x, StgWord val) +hs_atomic_xor16(StgWord x, StgWord val) { - return __sync_fetch_and_xor(x, (StgWord16) val); + return __sync_fetch_and_xor((volatile StgWord16 *) x, (StgWord16) val); } -extern StgWord hs_atomic_xor32(volatile StgWord32 *x, StgWord val); +extern StgWord hs_atomic_xor32(StgWord x, StgWord val); StgWord -hs_atomic_xor32(volatile StgWord32 *x, StgWord val) +hs_atomic_xor32(StgWord x, StgWord val) { - return __sync_fetch_and_xor(x, (StgWord32) val); + return __sync_fetch_and_xor((volatile StgWord32 *) x, (StgWord32) val); } #if WORD_SIZE_IN_BITS == 64 -extern StgWord64 hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val); +extern StgWord64 hs_atomic_xor64(StgWord x, StgWord64 val); StgWord64 -hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val) +hs_atomic_xor64(StgWord x, StgWord64 val) { - return __sync_fetch_and_xor(x, val); + return __sync_fetch_and_xor((volatile StgWord64 *) x, val); } #endif // CasByteArrayOp_Int -extern StgWord hs_cmpxchg8(volatile StgWord8 *x, StgWord old, StgWord new); +extern StgWord hs_cmpxchg8(StgWord x, StgWord old, StgWord new); StgWord -hs_cmpxchg8(volatile StgWord8 *x, StgWord old, StgWord new) +hs_cmpxchg8(StgWord x, StgWord old, StgWord new) { - return __sync_val_compare_and_swap(x, (StgWord8) old, (StgWord8) new); + return __sync_val_compare_and_swap((volatile StgWord8 *) x, (StgWord8) old, (StgWord8) new); } -extern StgWord hs_cmpxchg16(volatile StgWord16 *x, StgWord old, StgWord new); +extern StgWord hs_cmpxchg16(StgWord x, StgWord old, StgWord new); StgWord -hs_cmpxchg16(volatile StgWord16 *x, StgWord old, StgWord new) +hs_cmpxchg16(StgWord x, StgWord old, StgWord new) { - return __sync_val_compare_and_swap(x, (StgWord16) old, (StgWord16) new); + return __sync_val_compare_and_swap((volatile StgWord16 *) x, (StgWord16) old, (StgWord16) new); } -extern StgWord hs_cmpxchg32(volatile StgWord32 *x, StgWord old, StgWord new); +extern StgWord hs_cmpxchg32(StgWord x, StgWord old, StgWord new); StgWord -hs_cmpxchg32(volatile StgWord32 *x, StgWord old, StgWord new) +hs_cmpxchg32(StgWord x, StgWord old, StgWord new) { - return __sync_val_compare_and_swap(x, (StgWord32) old, (StgWord32) new); + return __sync_val_compare_and_swap((volatile StgWord32 *) x, (StgWord32) old, (StgWord32) new); } #if WORD_SIZE_IN_BITS == 64 -extern StgWord hs_cmpxchg64(volatile StgWord64 *x, StgWord64 old, StgWord64 new); +extern StgWord hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new); StgWord -hs_cmpxchg64(volatile StgWord64 *x, StgWord64 old, StgWord64 new) +hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new) { - return __sync_val_compare_and_swap(x, old, new); + return __sync_val_compare_and_swap((volatile StgWord64 *) x, old, new); } #endif // AtomicReadByteArrayOp_Int -extern StgWord hs_atomicread8(volatile StgWord8 *x); +extern StgWord hs_atomicread8(StgWord x); StgWord -hs_atomicread8(volatile StgWord8 *x) +hs_atomicread8(StgWord x) { - return *x; + return *(volatile StgWord8 *) x; } -extern StgWord hs_atomicread16(volatile StgWord16 *x); +extern StgWord hs_atomicread16(StgWord x); StgWord -hs_atomicread16(volatile StgWord16 *x) +hs_atomicread16(StgWord x) { - return *x; + return *(volatile StgWord16 *) x; } -extern StgWord hs_atomicread32(volatile StgWord32 *x); +extern StgWord hs_atomicread32(StgWord x); StgWord -hs_atomicread32(volatile StgWord32 *x) +hs_atomicread32(StgWord x) { - return *x; + return *(volatile StgWord32 *) x; } -extern StgWord64 hs_atomicread64(volatile StgWord64 *x); +extern StgWord64 hs_atomicread64(StgWord x); StgWord64 -hs_atomicread64(volatile StgWord64 *x) +hs_atomicread64(StgWord x) { - return *x; + return *(volatile StgWord64 *) x; } // AtomicWriteByteArrayOp_Int -extern void hs_atomicwrite8(volatile StgWord8 *x, StgWord val); +extern void hs_atomicwrite8(StgWord x, StgWord val); void -hs_atomicwrite8(volatile StgWord8 *x, StgWord val) +hs_atomicwrite8(StgWord x, StgWord val) { - *x = (StgWord8) val; + *(volatile StgWord8 *) x = (StgWord8) val; } -extern void hs_atomicwrite16(volatile StgWord16 *x, StgWord val); +extern void hs_atomicwrite16(StgWord x, StgWord val); void -hs_atomicwrite16(volatile StgWord16 *x, StgWord val) +hs_atomicwrite16(StgWord x, StgWord val) { - *x = (StgWord16) val; + *(volatile StgWord16 *) x = (StgWord16) val; } -extern void hs_atomicwrite32(volatile StgWord32 *x, StgWord val); +extern void hs_atomicwrite32(StgWord x, StgWord val); void -hs_atomicwrite32(volatile StgWord32 *x, StgWord val) +hs_atomicwrite32(StgWord x, StgWord val) { - *x = (StgWord32) val; + *(volatile StgWord32 *) x = (StgWord32) val; } -extern void hs_atomicwrite64(volatile StgWord64 *x, StgWord64 val); +extern void hs_atomicwrite64(StgWord x, StgWord64 val); void -hs_atomicwrite64(volatile StgWord64 *x, StgWord64 val) +hs_atomicwrite64(StgWord x, StgWord64 val) { - *x = (StgWord64) val; + *(volatile StgWord64 *) x = (StgWord64) val; } diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index 58b6ee0a03..ab59a938d4 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -64,6 +64,6 @@ Library cbits/popcnt.c cbits/word2float.c - -- We need to set the package key to ghc-prim (without a version number) + -- We need to set the unit ID to ghc-prim (without a version number) -- as it's magic. ghc-options: -this-package-key ghc-prim diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index bce8bf5ddb..49038816e7 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -51,6 +51,7 @@ module Language.Haskell.TH( nameBase, -- :: Name -> String nameModule, -- :: Name -> Maybe String namePackage, -- :: Name -> Maybe String + nameSpace, -- :: Name -> Maybe NameSpace -- ** Built-in names tupleTypeName, tupleDataName, -- Int -> Name unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index b64dfffb93..97c379d407 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -38,6 +38,7 @@ import Data.Int import Data.Word import Data.Ratio import GHC.Generics ( Generic ) +import GHC.Lexeme ( startsVarSym, startsVarId ) #ifdef HAS_NATURAL import Numeric.Natural @@ -645,10 +646,10 @@ dataToQa mkCon mkLit appCon antiQ t = Nothing -> case constrRep constr of AlgConstr _ -> - appCon (mkCon conName) conArgs + appCon (mkCon funOrConName) conArgs where - conName :: Name - conName = + funOrConName :: Name + funOrConName = case showConstr constr of "(:)" -> Name (mkOccName ":") (NameG DataName @@ -662,13 +663,23 @@ dataToQa mkCon mkLit appCon antiQ t = (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Tuple")) - con -> mkNameG_d (tyConPackage tycon) - (tyConModule tycon) - con + -- It is possible for a Data instance to be defined such + -- that toConstr uses a Constr defined using a function, + -- not a data constructor. In such a case, we must take + -- care to build the Name using mkNameG_v (for values), + -- not mkNameG_d (for data constructors). + -- See Trac #10796. + fun@(x:_) | startsVarSym x || startsVarId x + -> mkNameG_v tyconPkg tyconMod fun + con -> mkNameG_d tyconPkg tyconMod con where tycon :: TyCon tycon = (typeRepTyCon . typeOf) t + tyconPkg, tyconMod :: String + tyconPkg = tyConPackage tycon + tyconMod = tyConModule tycon + conArgs :: [Q q] conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t IntConstr n -> @@ -691,8 +702,17 @@ dataToExpQ :: Data a => (forall b . Data b => b -> Maybe (Q Exp)) -> a -> Q Exp -dataToExpQ = dataToQa conE litE (foldl appE) - where conE s = return (ConE s) +dataToExpQ = dataToQa varOrConE litE (foldl appE) + where + -- Make sure that VarE is used if the Constr value relies on a + -- function underneath the surface (instead of a constructor). + -- See Trac #10796. + varOrConE s = + case nameSpace s of + Just VarName -> return (VarE s) + Just DataName -> return (ConE s) + _ -> fail $ "Can't construct an expression from name " + ++ showName s appE x y = do { a <- x; b <- y; return (AppE a b)} litE c = return (LitE c) @@ -710,8 +730,13 @@ dataToPatQ :: Data a -> Q Pat dataToPatQ = dataToQa id litP conP where litP l = return (LitP l) - conP n ps = do ps' <- sequence ps - return (ConP n ps') + conP n ps = + case nameSpace n of + Just DataName -> do + ps' <- sequence ps + return (ConP n ps') + _ -> fail $ "Can't construct a pattern from name " + ++ showName n ----------------------------------------------------- -- Names and uniques @@ -855,13 +880,13 @@ data NameFlavour -- An original name (occurrences only, not binders) -- Need the namespace too to be sure which -- thing we are naming - deriving ( Typeable, Data, Eq, Ord, Generic ) + deriving ( Typeable, Data, Eq, Ord, Show, Generic ) data NameSpace = VarName -- ^ Variables | DataName -- ^ Data constructors | TcClsName -- ^ Type constructors and classes; Haskell has them -- in the same name space for now. - deriving( Eq, Ord, Data, Typeable, Generic ) + deriving( Eq, Ord, Show, Data, Typeable, Generic ) type Uniq = Int @@ -907,6 +932,26 @@ namePackage :: Name -> Maybe String namePackage (Name _ (NameG _ p _)) = Just (pkgString p) namePackage _ = Nothing +-- | Returns whether a name represents an occurrence of a top-level variable +-- ('VarName'), data constructor ('DataName'), type constructor, or type class +-- ('TcClsName'). If we can't be sure, it returns 'Nothing'. +-- +-- ==== __Examples__ +-- +-- >>> nameSpace 'Prelude.id +-- Just VarName +-- >>> nameSpace (mkName "id") +-- Nothing -- only works for top-level variable names +-- >>> nameSpace 'Data.Maybe.Just +-- Just DataName +-- >>> nameSpace ''Data.Maybe.Maybe +-- Just TcClsName +-- >>> nameSpace ''Data.Ord.Ord +-- Just TcClsName +nameSpace :: Name -> Maybe NameSpace +nameSpace (Name _ (NameG ns _ _)) = Just ns +nameSpace _ = Nothing + {- | Generate a capturable name. Occurrences of such names will be resolved according to the Haskell scoping rules at the occurrence diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index fb701abf47..e4edf63f42 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -10,7 +10,13 @@ according to the fixities of the operators. The `ParensT` constructor can be used to explicitly group expressions. - * Add `namePackage` + * Add `namePackage` and `nameSpace` + + * Make `dataToQa` and `dataToExpQ` able to handle `Data` instances whose + `toConstr` implementation relies on a function instead of a data + constructor (#10796) + + * Add `Show` instances for `NameFlavour` and `NameSpace` * TODO: document API changes and important bugfixes diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal index 4bfd1a96a7..f1265d494e 100644 --- a/libraries/template-haskell/template-haskell.cabal +++ b/libraries/template-haskell/template-haskell.cabal @@ -48,9 +48,10 @@ Library build-depends: base >= 4.6 && < 4.9, + ghc-boot, pretty == 1.1.* - -- We need to set the package key to template-haskell (without a + -- We need to set the unit ID to template-haskell (without a -- version number) as it's magic. ghc-options: -Wall |