import GHC.Generics
import GHC.Ordering
import GHC.Prim
+import {-# SOURCE #-} GHC.Show
import {-# SOURCE #-} GHC.Err
+import {-# SOURCE #-} GHC.IO (failIO)
+
+-- These two are not strictly speaking required by this module, but they are
+-- implicit dependencies whenever () or tuples are mentioned, so adding them
+-- as imports here helps to get the dependencies right in the new build system.
+import GHC.Tuple ()
+import GHC.Unit ()
infixr 9 .
infixr 5 ++
----------------------------------------------
-- foldr/build/augment
----------------------------------------------
-
-Note [Inlining for foldr]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Inline foldr only in the final stage (0), after the foldr rules
-have had a chance
-
-Notice that we write foldr with just *two* arguments so that it'll inline
-when given just those two arguments. Those are the ones that allow it to
-be specialised for its argument functions. If you give it *three* args
-then a definition like
- unpack = foldr unpk_fn unpk_arg
-does not get foldr inlined. But now 'unpack' will probably be inlined at
-every call site (being small and arity 1), and *that* will make foldr inline!
-So we get a copy of foldr at every call of unpack. This is particularly
-bad for literal strings.
\begin{code}
-- | 'foldr', applied to a binary operator, a starting value (typically
foldr :: (a -> b -> b) -> b -> [a] -> b
-- foldr _ z [] = z
-- foldr f z (x:xs) = f x (foldr f z xs)
-{-# INLINE [0] foldr #-} -- See Note [Inlining for foldr]
-foldr k z = go
- where
+{-# INLINE [0] foldr #-}
+-- Inline only in the final stage, after the foldr/cons rule has had a chance
+foldr k z xs = go xs
+ where
go [] = z
go (y:ys) = y `k` go ys
-- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.
chr :: Int -> Char
-chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
- | otherwise = error "Prelude.chr: bad argument"
+chr i@(I# i#)
+ | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
+ | otherwise
+ = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
unsafeChr :: Int -> Char
unsafeChr (I# i#) = C# (chr# i#)
-- | Function composition.
{-# INLINE (.) #-}
(.) :: (b -> c) -> (a -> b) -> a -> c
-(.) f g = \x -> f (g x)
+(.) f g x = f (g x)
-- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@.
flip :: (a -> b -> c) -> b -> a -> c
%*********************************************************
%* *
+\subsection{@Functor@ and @Monad@ instances for @IO@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Functor IO where
+ fmap f x = x >>= (return . f)
+
+instance Monad IO where
+ {-# INLINE return #-}
+ {-# INLINE (>>) #-}
+ {-# INLINE (>>=) #-}
+ m >> k = m >>= \ _ -> k
+ return = returnIO
+ (>>=) = bindIO
+ fail s = GHC.IO.failIO s
+
+returnIO :: a -> IO a
+returnIO x = IO $ \ s -> (# s, x #)
+
+bindIO :: IO a -> (a -> IO b) -> IO b
+bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s
+
+thenIO :: IO a -> IO b -> IO b
+thenIO (IO m) k = IO $ \ s -> case m s of (# new_s, _ #) -> unIO k new_s
+
+unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
+unIO (IO a) = a
+\end{code}
+
+%*********************************************************
+%* *
\subsection{@getTag@}
%* *
%*********************************************************
(x# <# 0#) && (y# ># 0#) = if r# /=# 0# then r# +# y# else 0#
| otherwise = r#
where
- r# = x# `remInt#` y#
+ !r# = x# `remInt#` y#
\end{code}
Definitions of the boxed PrimOps; these will be
{-# INLINE remInt #-}
{-# INLINE negateInt #-}
-plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int
+plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt :: Int -> Int -> Int
(I# x) `plusInt` (I# y) = I# (x +# y)
(I# x) `minusInt` (I# y) = I# (x -# y)
(I# x) `timesInt` (I# y) = I# (x *# y)
"1# *# x#" forall x#. 1# *# x# = x#
#-}
-gcdInt (I# a) (I# b) = g a b
- where g 0# 0# = error "GHC.Base.gcdInt: gcd 0 0 is undefined"
- g 0# _ = I# absB
- g _ 0# = I# absA
- g _ _ = I# (gcdInt# absA absB)
-
- absInt x = if x <# 0# then negateInt# x else x
-
- absA = absInt a
- absB = absInt b
-
negateInt :: Int -> Int
negateInt (I# x) = I# (negateInt# x)
This code is needed for virtually all programs, since it's used for
unpacking the strings of error messages.
-Note [Inlining for unpacking C strings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We use NOINLINE on unpackCString# and unpackFoldrCString# because
-there is little or no gain from inlining them -- and there may be a
-lot of calls (one for each literal string).
-
\begin{code}
unpackCString# :: Addr# -> [Char]
{-# NOINLINE unpackCString# #-}
--- See Note [Inlining for unpacking C strings]
+ -- There's really no point in inlining this, ever, cos
+ -- the loop doesn't specialise in an interesting
+ -- But it's pretty small, so there's a danger that
+ -- it'll be inlined at every literal, which is a waste
unpackCString# addr
= unpack 0#
where
| ch `eqChar#` '\0'# = []
| otherwise = C# ch : unpack (nh +# 1#)
where
- ch = indexCharOffAddr# addr nh
+ !ch = indexCharOffAddr# addr nh
unpackAppendCString# :: Addr# -> [Char] -> [Char]
+{-# NOINLINE unpackAppendCString# #-}
+ -- See the NOINLINE note on unpackCString#
unpackAppendCString# addr rest
= unpack 0#
where
| ch `eqChar#` '\0'# = rest
| otherwise = C# ch : unpack (nh +# 1#)
where
- ch = indexCharOffAddr# addr nh
+ !ch = indexCharOffAddr# addr nh
unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
-{-# NOINLINE unpackFoldrCString# #-}
--- See Note [Inlining for unpacking C strings]
--- Usually the unpack-list rule turns it into unpackCString#
+{-# NOINLINE [0] unpackFoldrCString# #-}
+-- Unlike unpackCString#, there *is* some point in inlining unpackFoldrCString#,
+-- because we get better code for the function call.
+-- However, don't inline till right at the end;
+-- usually the unpack-list rule turns it into unpackCStringList
-- It also has a BuiltInRule in PrelRules.lhs:
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
-- = unpackFoldrCString# "foobaz" c n
| ch `eqChar#` '\0'# = z
| otherwise = C# ch `f` unpack (nh +# 1#)
where
- ch = indexCharOffAddr# addr nh
+ !ch = indexCharOffAddr# addr nh
unpackCStringUtf8# :: Addr# -> [Char]
unpackCStringUtf8# addr
(ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :
unpack (nh +# 4#)
where
- ch = indexCharOffAddr# addr nh
+ !ch = indexCharOffAddr# addr nh
unpackNBytes# :: Addr# -> Int# -> [Char]
unpackNBytes# _addr 0# = []
projects / ghc-base.git / blobdiff