X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelBase.lhs;h=b74da36e63c5c2de7eb519f33f4fcacf0860dd3e;hb=01bd67ae7b70d9207867c422e1d335e535a64b27;hp=84b7a9ccaf456987217ad4ba4f0aab109adedc55;hpb=5ca77490a603e0175bb717343884533ad8de017d;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index 84b7a9c..b74da36 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,7 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelBase.lhs,v 1.55 2001/10/17 15:40:02 simonpj Exp $ % -% (c) The GRAP/AQUA Project, Glasgow University, 1992-1996 +% (c) The University of Glasgow, 1992-2000 % \section[PrelBase]{Module @PrelBase@} @@ -73,16 +75,18 @@ Other Prelude modules are much easier with fewer complex dependencies. \begin{code} {-# OPTIONS -fno-implicit-prelude #-} +#include "MachDeps.h" + module PrelBase ( module PrelBase, - module PrelGHC -- Re-export PrelGHC, to avoid lots of people - -- having to import it explicitly + module PrelGHC, -- Re-export PrelGHC and PrelErr, to avoid lots + module PrelErr -- of people having to import it explicitly ) where -import {-# SOURCE #-} PrelErr ( error ) import PrelGHC +import {-# SOURCE #-} PrelErr infixr 9 . infixr 5 ++, : @@ -98,40 +102,77 @@ default () -- Double isn't available yet %********************************************************* %* * +\subsection{DEBUGGING STUFF} +%* (for use when compiling PrelBase itself doesn't work) +%* * +%********************************************************* + +\begin{code} +{- +data Bool = False | True +data Ordering = LT | EQ | GT +data Char = C# Char# +type String = [Char] +data Int = I# Int# +data () = () +data [] a = MkNil + +not True = False +(&&) True True = True +otherwise = True + +build = error "urk" +foldr = error "urk" + +unpackCString# :: Addr# -> [Char] +unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a +unpackAppendCString# :: Addr# -> [Char] -> [Char] +unpackCStringUtf8# :: Addr# -> [Char] +unpackCString# a = error "urk" +unpackFoldrCString# a = error "urk" +unpackAppendCString# a = error "urk" +unpackCStringUtf8# a = error "urk" +-} +\end{code} + + +%********************************************************* +%* * \subsection{Standard classes @Eq@, @Ord@} %* * %********************************************************* \begin{code} class Eq a where - (==), (/=) :: a -> a -> Bool + (==), (/=) :: a -> a -> Bool - x /= y = not (x == y) - x == y = not (x /= y) + x /= y = not (x == y) + x == y = not (x /= y) class (Eq a) => Ord a where - compare :: a -> a -> Ordering - (<), (<=), (>=), (>):: a -> a -> Bool - max, min :: a -> a -> a + compare :: a -> a -> Ordering + (<), (<=), (>), (>=) :: a -> a -> Bool + max, min :: a -> a -> a + + -- An instance of Ord should define either 'compare' or '<='. + -- Using 'compare' can be more efficient for complex types. --- An instance of Ord should define either compare or <= --- Using compare can be more efficient for complex types. compare x y - | x == y = EQ - | x <= y = LT -- NB: must be '<=' not '<' to validate the - -- above claim about the minimal things that can - -- be defined for an instance of Ord - | otherwise = GT - - x <= y = case compare x y of { GT -> False; _other -> True } - x < y = case compare x y of { LT -> True; _other -> False } - x >= y = case compare x y of { LT -> False; _other -> True } - x > y = case compare x y of { GT -> True; _other -> False } - - -- These two default methods use '>' rather than compare + | x == y = EQ + | x <= y = LT -- NB: must be '<=' not '<' to validate the + -- above claim about the minimal things that + -- can be defined for an instance of Ord + | otherwise = GT + + x < y = case compare x y of { LT -> True; _other -> False } + x <= y = case compare x y of { GT -> False; _other -> True } + x > y = case compare x y of { GT -> True; _other -> False } + x >= y = case compare x y of { LT -> False; _other -> True } + + -- These two default methods use '<=' rather than 'compare' -- because the latter is often more expensive - max x y = if x > y then x else y - min x y = if x > y then y else x + max x y = if x <= y then y else x + min x y = if x <= y then x else y \end{code} %********************************************************* @@ -142,7 +183,7 @@ class (Eq a) => Ord a where \begin{code} class Functor f where - fmap :: (a -> b) -> f a -> f b + fmap :: (a -> b) -> f a -> f b class Monad m where (>>=) :: m a -> (a -> m b) -> m b @@ -150,9 +191,8 @@ 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} @@ -166,28 +206,21 @@ class Monad m where 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 + [] == [] = True (x:xs) == (y:ys) = x == y && xs == ys - _xs == _ys = False - - xs /= ys = if (xs == ys) then False else True + _xs == _ys = False instance (Ord a) => Ord [a] where {-# SPECIALISE instance Ord [Char] #-} - a < b = case compare a b of { LT -> True; EQ -> False; GT -> False } - a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False } - a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True } - a > b = case compare a b of { LT -> False; EQ -> False; GT -> True } - compare [] [] = EQ - compare (_:_) [] = GT compare [] (_:_) = LT + compare (_:_) [] = GT compare (x:xs) (y:ys) = case compare x y of - LT -> LT - GT -> GT - EQ -> compare xs ys + EQ -> compare xs ys + other -> other instance Functor [] where fmap = map @@ -210,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 (x:xs) = x `k` go xs + 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 @@ -241,7 +275,14 @@ augment g xs = g (:) xs "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) +-- 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/nil" forall k z. foldr k z [] = z "augment/build" forall (g::forall b. (a->b->b) -> b -> b) @@ -262,10 +303,11 @@ augment g xs = g (:) xs \begin{code} map :: (a -> b) -> [a] -> [b] -{-# INLINE map #-} -map f xs = build (\c n -> foldr (mapFB c f) n xs) +{-# NOINLINE [1] map #-} +map = mapList -- Note eta expanded +mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst mapFB c f x ys = c (f x) ys mapList :: (a -> b) -> [a] -> [b] @@ -273,9 +315,10 @@ mapList _ [] = [] mapList f (x:xs) = f x : mapList f xs {-# RULES +"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} @@ -284,8 +327,12 @@ mapList f (x:xs) = f x : mapList f xs ---------------------------------------------- \begin{code} (++) :: [a] -> [a] -> [a] -{-# INLINE (++) #-} -xs ++ ys = augment (\c n -> foldr c n xs) ys +{-# NOINLINE [1] (++) #-} +(++) = append + +{-# RULES +"++" forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys + #-} append :: [a] -> [a] -> [a] append [] ys = ys @@ -334,7 +381,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 @@ -370,7 +417,7 @@ data Ordering = LT | EQ | GT deriving (Eq, Ord) %********************************************************* \begin{code} -type String = [Char] +type String = [Char] data Char = C# Char# @@ -379,24 +426,44 @@ 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 <=# 255# = 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 [] [] = True +eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2 +eqString cs1 cs2 = False + +{-# RULES "eqString" (==) = eqString #-} \end{code} @@ -413,25 +480,38 @@ zeroInt, oneInt, twoInt, maxInt, minInt :: Int zeroInt = I# 0# oneInt = I# 1# twoInt = I# 2# -minInt = I# (-2147483648#) -- GHC <= 2.09 had this at -2147483647 -maxInt = I# 2147483647# + +{- 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 +minInt = I# (-0x8000000000000000#) +maxInt = I# 0x7FFFFFFFFFFFFFFF# +#endif instance Eq Int where - (==) x y = x `eqInt` y - (/=) x y = x `neInt` y + (==) = eqInt + (/=) = neInt instance Ord Int where - compare x y = compareInt x y - - (<) x y = ltInt x y - (<=) x y = leInt x y - (>=) x y = geInt x y - (>) x y = gtInt x y + compare = compareInt + (<) = ltInt + (<=) = leInt + (>=) = geInt + (>) = gtInt compareInt :: Int -> Int -> Ordering -(I# x) `compareInt` (I# y) | x <# y = LT - | x ==# y = EQ - | otherwise = GT +(I# x#) `compareInt` (I# y#) = compareInt# x# y# + +compareInt# :: Int# -> Int# -> Ordering +compareInt# x# y# + | x# <# y# = LT + | x# ==# y# = EQ + | otherwise = GT \end{code} @@ -461,6 +541,7 @@ flip f x y = f y x -- right-associating infix application operator (useful in continuation- -- passing style) +{-# INLINE ($) #-} ($) :: (a -> b) -> a -> b f $ x = f x @@ -491,19 +572,43 @@ instance CReturnable Char instance CCallable Int instance CReturnable Int --- DsCCall knows how to pass strings... -instance CCallable [Char] - instance CReturnable () -- Why, exactly? \end{code} %********************************************************* %* * +\subsection{Generics} +%* * +%********************************************************* + +\begin{code} +data Unit = Unit +data a :+: b = Inl a | Inr b +data a :*: b = a :*: b +\end{code} + + +%********************************************************* +%* * \subsection{Numeric primops} %* * %********************************************************* +\begin{code} +divInt#, modInt# :: Int# -> Int# -> Int# +x# `divInt#` y# + | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y# + | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y# + | otherwise = x# `quotInt#` y# +x# `modInt#` y# + | (x# ># 0#) && (y# <# 0#) || + (x# <# 0#) && (y# ># 0#) = if r# /=# 0# then r# +# y# else 0# + | otherwise = r# + where + r# = x# `remInt#` y# +\end{code} + Definitions of the boxed PrimOps; these will be used in the case of partial applications, etc. @@ -521,37 +626,68 @@ used in the case of partial applications, etc. {-# INLINE remInt #-} {-# INLINE negateInt #-} -plusInt, minusInt, timesInt, quotInt, remInt, gcdInt :: Int -> Int -> Int -plusInt (I# x) (I# y) = I# (x +# y) -minusInt(I# x) (I# y) = I# (x -# y) -timesInt(I# x) (I# y) = I# (x *# y) -quotInt (I# x) (I# y) = I# (quotInt# x y) -remInt (I# x) (I# y) = I# (remInt# x y) -gcdInt (I# a) (I# b) = I# (gcdInt# a b) +plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: 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) +(I# x) `quotInt` (I# y) = I# (x `quotInt#` y) +(I# x) `remInt` (I# y) = I# (x `remInt#` y) +(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 + 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) - -divInt, modInt :: Int -> Int -> Int -x `divInt` y - | x > zeroInt && y < zeroInt = quotInt ((x `minusInt` y) `minusInt` oneInt) y - | x < zeroInt && y > zeroInt = quotInt ((x `minusInt` y) `plusInt` oneInt) y - | otherwise = quotInt x y - -x `modInt` y - | x > zeroInt && y < zeroInt || - x < zeroInt && y > zeroInt = if r/=zeroInt then r `plusInt` y else zeroInt - | otherwise = r - where - r = remInt x y +negateInt (I# x) = I# (negateInt# x) gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool -gtInt (I# x) (I# y) = x ># y -geInt (I# x) (I# y) = x >=# y -eqInt (I# x) (I# y) = x ==# y -neInt (I# x) (I# y) = x /=# y -ltInt (I# x) (I# y) = x <# y -leInt (I# x) (I# y) = x <=# y +(I# x) `gtInt` (I# y) = x ># y +(I# x) `geInt` (I# y) = x >=# y +(I# x) `eqInt` (I# y) = x ==# y +(I# x) `neInt` (I# y) = x /=# y +(I# x) `ltInt` (I# y) = x <# y +(I# x) `leInt` (I# y) = x <=# y + +{-# RULES +"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 + #-} + +#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} @@ -565,11 +701,11 @@ This code is needed for virtually all programs, since it's used for unpacking the strings of error messages. \begin{code} -unpackCString# :: Addr# -> [Char] -{-# INLINE unpackCString# #-} -unpackCString# a = build (unpackFoldrCString# a) +unpackCString# :: Addr# -> [Char] +{-# NOINLINE [1] unpackCString# #-} +unpackCString# a = unpackCStringList# a -unpackCStringList# :: Addr# -> [Char] +unpackCStringList# :: Addr# -> [Char] unpackCStringList# addr = unpack 0# where @@ -589,7 +725,10 @@ unpackAppendCString# addr rest where ch = indexCharOffAddr# addr nh -unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a +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 @@ -599,11 +738,32 @@ unpackFoldrCString# addr f z where ch = indexCharOffAddr# addr nh -unpackNBytes# :: Addr# -> Int# -> [Char] - -- This one is called by the compiler to unpack literal - -- strings with NULs in them; rare. It's strict! - -- We don't try to do list deforestation for this one +unpackCStringUtf8# :: Addr# -> [Char] +unpackCStringUtf8# addr + = unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = [] + | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#) + | ch `leChar#` '\xDF'# = + C# (chr# ((ord# ch -# 0xC0#) `iShiftL#` 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# +# + (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# +# + (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : + unpack (nh +# 4#) + where + ch = indexCharOffAddr# addr nh +unpackNBytes# :: Addr# -> Int# -> [Char] unpackNBytes# _addr 0# = [] unpackNBytes# addr len# = unpack [] (len# -# 1#) where @@ -614,6 +774,7 @@ 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