% -----------------------------------------------------------------------------
-% $Id: PrelBase.lhs,v 1.47 2001/04/28 04:44:05 qrczak Exp $
+% $Id: PrelBase.lhs,v 1.59 2001/12/14 17:24:19 simonpj Exp $
%
% (c) The University of Glasgow, 1992-2000
%
return :: a -> m a
fail :: String -> m a
- m >> k = m >>= \_ -> k
+ m >> k = m >>= \_ -> k
fail s = error s
\end{code}
-- to avoid weird names like con2tag_[]#
-instance (Eq a) => Eq [a] where
+instance (Eq a) => Eq [a] where
{-# SPECIALISE instance Eq [Char] #-}
[] == [] = True
(x:xs) == (y:ys) = x == y && xs == ys
instance (Ord a) => Ord [a] where
{-# SPECIALISE instance Ord [Char] #-}
-
compare [] [] = EQ
compare [] (_:_) = LT
compare (_:_) [] = GT
foldr :: (a -> b -> b) -> b -> [a] -> b
-- foldr _ z [] = z
-- foldr f z (x:xs) = f x (foldr f z xs)
-{-# INLINE foldr #-}
+{-# 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
build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
-{-# INLINE 2 build #-}
+{-# INLINE [1] build #-}
-- The INLINE is important, even though build is tiny,
-- because it prevents [] getting inlined in the version that
-- appears in the interface file. If [] *is* inlined, it
-- won't match with [] appearing in rules in an importing module.
--
- -- The "2" says to inline in phase 2
+ -- The "1" says to inline in phase 1
build g = g (:) []
augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
-{-# INLINE 2 augment #-}
+{-# INLINE [1] augment #-}
augment g xs = g (:) xs
{-# RULES
"foldr/id" foldr (:) [] = \x->x
"foldr/app" forall xs ys. foldr (:) ys xs = append xs ys
-"foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
-"foldr/nil" forall k z. foldr k z [] = z
+-- The foldr/cons rule looks nice, but it can give disastrously
+-- bloated code when commpiling
+-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
+-- i.e. when there are very very long literal lists
+-- So I've disabled it for now. We could have special cases
+-- for short lists, I suppose.
+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
+
+"foldr/single" forall k z x. foldr k z [x] = k x z
+"foldr/nil" forall k z. foldr k z [] = z
"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
(h::forall b. (a->b->b) -> b -> b) .
\begin{code}
map :: (a -> b) -> [a] -> [b]
+{-# NOINLINE [1] map #-}
map = mapList
-- Note eta expanded
"map" forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
"mapList" forall f. foldr (mapFB (:) f) [] = mapList f
- #-}
+ #-}
\end{code}
----------------------------------------------
\begin{code}
(++) :: [a] -> [a] -> [a]
+{-# NOINLINE [1] (++) #-}
(++) = append
{-# RULES
- "++" forall xs ys. (++) xs ys = augment (\c n -> foldr c n xs) ys
- #-}
+"++" forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
+ #-}
append :: [a] -> [a] -> [a]
append [] ys = ys
it here seems more direct.)
\begin{code}
-data () = ()
+data () = ()
instance Eq () where
() == () = True
-- '>' uses compare, and therefore takes two primops instead of one.
instance Eq Char where
- (C# c1) == (C# c2) = c1 `eqChar#` c2
- (C# c1) /= (C# c2) = c1 `neChar#` c2
+ (C# c1) == (C# c2) = c1 `eqChar#` c2
+ (C# c1) /= (C# c2) = c1 `neChar#` c2
instance Ord Char where
- (C# c1) > (C# c2) = c1 `gtChar#` c2
- (C# c1) >= (C# c2) = c1 `geChar#` c2
- (C# c1) <= (C# c2) = c1 `leChar#` c2
- (C# c1) < (C# c2) = c1 `ltChar#` c2
+ (C# c1) > (C# c2) = c1 `gtChar#` c2
+ (C# c1) >= (C# c2) = c1 `geChar#` c2
+ (C# c1) <= (C# c2) = c1 `leChar#` c2
+ (C# c1) < (C# c2) = c1 `ltChar#` c2
-{- XXX
{-# RULES
-"x# `eqChar#` x#" forall x#. eqChar# x# x# = True
-"x# `neChar#` x#" forall x#. neChar# x# x# = False
-"x# `gtChar#` x#" forall x#. gtChar# x# x# = False
-"x# `geChar#` x#" forall x#. geChar# x# x# = True
-"x# `leChar#` x#" forall x#. leChar# x# x# = True
-"x# `ltChar#` x#" forall x#. ltChar# x# x# = False
- #-}
--}
+"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True
+"x# `neChar#` x#" forall x#. x# `neChar#` x# = False
+"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False
+"x# `geChar#` x#" forall x#. x# `geChar#` x# = True
+"x# `leChar#` x#" forall x#. x# `leChar#` x# = True
+"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False
+ #-}
chr :: Int -> Char
chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
\begin{code}
eqString :: String -> String -> Bool
-eqString = (==)
+eqString [] [] = True
+eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2
+eqString cs1 cs2 = False
+
+{-# RULES "eqString" (==) = eqString #-}
\end{code}
+
%*********************************************************
%* *
\subsection{Type @Int@}
zeroInt = I# 0#
oneInt = I# 1#
twoInt = I# 2#
-#if WORD_SIZE_IN_BYTES == 4
+
+{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -}
+#if WORD_SIZE_IN_BITS == 31
+minInt = I# (-0x40000000#)
+maxInt = I# 0x3FFFFFFF#
+#elif WORD_SIZE_IN_BITS == 32
minInt = I# (-0x80000000#)
maxInt = I# 0x7FFFFFFF#
-#else
+#else
minInt = I# (-0x8000000000000000#)
maxInt = I# 0x7FFFFFFFFFFFFFFF#
#endif
instance Ord Int where
compare = compareInt
-
- (<) = ltInt
- (<=) = leInt
- (>=) = geInt
- (>) = gtInt
+ (<) = ltInt
+ (<=) = leInt
+ (>=) = geInt
+ (>) = gtInt
compareInt :: Int -> Int -> Ordering
-(I# x) `compareInt` (I# y) = compareInt# x y
+(I# x#) `compareInt` (I# y#) = compareInt# x# y#
compareInt# :: Int# -> Int# -> Ordering
compareInt# x# y#
- | x# <# y# = LT
- | x# ==# y# = EQ
- | otherwise = GT
+ | x# <# y# = LT
+ | x# ==# y# = EQ
+ | otherwise = GT
\end{code}
(I# x) `divInt` (I# y) = I# (x `divInt#` y)
(I# x) `modInt` (I# y) = I# (x `modInt#` y)
-{- XXX
{-# RULES
"x# +# 0#" forall x#. x# +# 0# = x#
"0# +# x#" forall x#. 0# +# x# = x#
"0# *# x#" forall x#. 0# *# x# = 0#
"x# *# 1#" forall x#. x# *# 1# = x#
"1# *# x#" forall x#. 1# *# x# = x#
- #-}
--}
+ #-}
gcdInt (I# a) (I# b) = g a b
where g 0# 0# = error "PrelBase.gcdInt: gcd 0 0 is undefined"
(I# x) `ltInt` (I# y) = x <# y
(I# x) `leInt` (I# y) = x <=# y
-{- XXX
{-# RULES
-"x# ># x#" forall x#. x# ># x# = False
+"x# ># x#" forall x#. x# ># x# = False
"x# >=# x#" forall x#. x# >=# x# = True
"x# ==# x#" forall x#. x# ==# x# = True
"x# /=# x#" forall x#. x# /=# x# = False
-"x# <# x#" forall x#. x# <# x# = False
+"x# <# x#" forall x#. x# <# x# = False
"x# <=# x#" forall x#. x# <=# x# = True
- #-}
+ #-}
+
+-- Wrappers for the shift operations. The uncheckedShift# family are
+-- undefined when the amount being shifted by is greater than the size
+-- in bits of Int#, so these wrappers perform a check and return
+-- either zero or -1 appropriately.
+--
+-- Note that these wrappers still produce undefined results when the
+-- second argument (the shift amount) is negative.
+
+shiftL#, shiftRL# :: Word# -> Int# -> Word#
+
+a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
+ | otherwise = a `uncheckedShiftL#` b
+
+a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#
+ | otherwise = a `uncheckedShiftRL#` b
-#if WORD_SIZE_IN_BYTES == 4
+iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int#
+
+a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0#
+ | otherwise = a `uncheckedIShiftL#` b
+
+a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0#
+ | otherwise = a `uncheckedIShiftRA#` b
+
+a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0#
+ | otherwise = a `uncheckedIShiftRL#` b
+
+#if WORD_SIZE_IN_BITS == 32
{-# RULES
-"intToInt32#" forall x#. intToInt32# x# = x#
-"wordToWord32#" forall x#. wordToWord32# x# = x#
- #-}
+"narrow32Int#" forall x#. narrow32Int# x# = x#
+"narrow32Word#" forall x#. narrow32Word# x# = x#
+ #-}
#endif
{-# RULES
"int2Word2Int" forall x#. int2Word# (word2Int# x#) = x#
"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#
- #-}
--}
+ #-}
\end{code}
\begin{code}
unpackCString# :: Addr# -> [Char]
+{-# NOINLINE [1] unpackCString# #-}
unpackCString# a = unpackCStringList# a
unpackCStringList# :: Addr# -> [Char]
ch = indexCharOffAddr# addr nh
unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
+{-# NOINLINE [0] unpackFoldrCString# #-}
+-- Don't inline till right at the end;
+-- usually the unpack-list rule turns it into unpackCStringList
unpackFoldrCString# addr f z
= unpack 0#
where
| ch `eqChar#` '\0'# = []
| ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)
| ch `leChar#` '\xDF'# =
- C# (chr# ((ord# ch -# 0xC0#) `iShiftL#` 6# +#
+ C# (chr# ((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6# +#
(ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
unpack (nh +# 2#)
| ch `leChar#` '\xEF'# =
- C# (chr# ((ord# ch -# 0xE0#) `iShiftL#` 12# +#
- (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 6# +#
+ C# (chr# ((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6# +#
(ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
unpack (nh +# 3#)
| otherwise =
- C# (chr# ((ord# ch -# 0xF0#) `iShiftL#` 18# +#
- (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 12# +#
- (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `iShiftL#` 6# +#
+ C# (chr# ((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6# +#
(ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :
unpack (nh +# 4#)
where
projects / ghc-hetmet.git / blobdiff