X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelBase.lhs;h=f883948d7a04603d0a96434ca06b18ed0bc21063;hb=2f874c4c1d0cc861a8f72585a3e6f9673105b766;hp=fde9554ae68dbf4377574dee11bc7e6d0572a855;hpb=8eda4709fdb427ad135776c9584afff102246174;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index fde9554..f883948 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.44 2001/04/03 15:05:52 simonmar Exp $ +% $Id: PrelBase.lhs,v 1.61 2002/02/12 03:52:09 chak Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -191,7 +191,7 @@ class Monad m where return :: a -> m a fail :: String -> m a - m >> k = m >>= \_ -> k + m >> k = m >>= \_ -> k fail s = error s \end{code} @@ -207,7 +207,7 @@ data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) -- 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 @@ -215,7 +215,6 @@ instance (Eq a) => Eq [a] where instance (Ord a) => Ord [a] where {-# SPECIALISE instance Ord [Char] #-} - compare [] [] = EQ compare [] (_:_) = LT compare (_:_) [] = GT @@ -244,25 +243,26 @@ The rest of the prelude list functions are in PrelList. 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 @@ -272,11 +272,21 @@ augment g xs = g (:) xs "foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) . foldr k z (augment g xs) = g k (foldr k z xs) -"foldr/id" foldr (:) [] = \x->x -"foldr/app" forall xs ys. foldr (:) ys xs = append xs ys +"foldr/id" foldr (:) [] = \x->x +"foldr/app" [1] forall xs ys. foldr (:) ys xs = xs ++ ys + -- Only activate this from phase 1, because that's + -- when we disable the rule that expands (++) into foldr + +-- 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/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 +"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) . @@ -296,21 +306,37 @@ augment g xs = g (:) xs \begin{code} map :: (a -> b) -> [a] -> [b] -map = mapList +map _ [] = [] +map f (x:xs) = f x : map f xs -- Note eta expanded mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst +{-# INLINE [0] mapFB #-} mapFB c f x ys = c (f x) ys -mapList :: (a -> b) -> [a] -> [b] -mapList _ [] = [] -mapList f (x:xs) = f x : mapList f xs +-- The rules for map work like this. +-- +-- Up to (but not including) phase 1, we use the "map" rule to +-- rewrite all saturated applications of map with its build/fold +-- form, hoping for fusion to happen. +-- In phase 1 and 0, we switch off that rule, inline build, and +-- switch on the "mapList" rule, which rewrites the foldr/mapFB +-- thing back into plain map. +-- +-- It's important that these two rules aren't both active at once +-- (along with build's unfolding) else we'd get an infinite loop +-- in the rules. Hence the activation control below. +-- +-- The "mapFB" rule optimises compositions of map. +-- +-- This same pattern is followed by many other functions: +-- e.g. append, filter, iterate, repeat, etc. {-# RULES -"map" forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) +"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) +"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f "mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g) -"mapList" forall f. foldr (mapFB (:) f) [] = mapList f - #-} + #-} \end{code} @@ -319,15 +345,13 @@ mapList f (x:xs) = f x : mapList f xs ---------------------------------------------- \begin{code} (++) :: [a] -> [a] -> [a] -(++) = append +(++) [] ys = ys +(++) (x:xs) ys = x : xs ++ ys {-# RULES - "++" forall xs ys. (++) xs ys = augment (\c n -> foldr c n xs) ys - #-} +"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys + #-} -append :: [a] -> [a] -> [a] -append [] ys = ys -append (x:xs) ys = x : append xs ys \end{code} @@ -372,7 +396,7 @@ need (). (We could arrange suck in () only if -fglasgow-exts, but putting it here seems more direct.) \begin{code} -data () = () +data () = () instance Eq () where () == () = True @@ -417,33 +441,47 @@ data Char = C# Char# -- '>' 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 + +{-# RULES +"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) | i >=# 0# && i <=# 0x10FFFF# = C# (chr# i) - | otherwise = error "Prelude.chr: bad argument" +chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#) + | otherwise = error "Prelude.chr: bad argument" unsafeChr :: Int -> Char -unsafeChr (I# i) = C# (chr# i) +unsafeChr (I# i#) = C# (chr# i#) ord :: Char -> Int -ord (C# c) = I# (ord# c) +ord (C# c#) = I# (ord# c#) \end{code} String equality is used when desugaring pattern-matches against strings. \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@} @@ -457,10 +495,15 @@ zeroInt, oneInt, twoInt, maxInt, minInt :: 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 @@ -471,20 +514,19 @@ instance Eq Int where 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} @@ -557,8 +599,8 @@ instance CReturnable () -- Why, exactly? \begin{code} data Unit = Unit -data a :+: b = Inl a | Inr b -data a :*: b = a :*: b +data (:+:) a b = Inl a | Inr b +data (:*:) a b = a :*: b \end{code} @@ -608,6 +650,17 @@ plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> I (I# x) `divInt` (I# y) = I# (x `divInt#` y) (I# x) `modInt` (I# y) = I# (x `modInt#` y) +{-# RULES +"x# +# 0#" forall x#. x# +# 0# = x# +"0# +# x#" forall x#. 0# +# x# = x# +"x# -# 0#" forall x#. x# -# 0# = x# +"x# -# x#" forall x#. x# -# x# = 0# +"x# *# 0#" forall x#. x# *# 0# = 0# +"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" g 0# _ = I# absB @@ -630,17 +683,53 @@ gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool (I# x) `ltInt` (I# y) = x <# y (I# x) `leInt` (I# y) = x <=# y -#if WORD_SIZE_IN_BYTES == 4 {-# RULES -"intToInt32#" forall x#. intToInt32# x# = x# -"wordToWord32#" forall x#. wordToWord32# x# = x# - #-} +"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# = 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 + +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 +"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} @@ -655,6 +744,7 @@ unpacking the strings of error messages. \begin{code} unpackCString# :: Addr# -> [Char] +{-# NOINLINE [1] unpackCString# #-} unpackCString# a = unpackCStringList# a unpackCStringList# :: Addr# -> [Char] @@ -678,6 +768,9 @@ unpackAppendCString# addr rest 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 @@ -695,18 +788,18 @@ unpackCStringUtf8# addr | 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 @@ -723,9 +816,9 @@ unpackNBytes# addr len# = unpack [] (len# -# 1#) ch -> unpack (C# ch : acc) (i# -# 1#) {-# RULES -"unpack" forall a . unpackCString# a = build (unpackFoldrCString# a) -"unpack-list" forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a -"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n +"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) +"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a +"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n -- There's a built-in rule (in PrelRules.lhs) for -- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n