X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelBase.lhs;h=f883948d7a04603d0a96434ca06b18ed0bc21063;hb=2f874c4c1d0cc861a8f72585a3e6f9673105b766;hp=2d504bceff0c4a0c2eaf66890fbb9527b51bd50c;hpb=f6b00c00c72d62b34520244d8ca8aa1c638830db;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index 2d504bc..f883948 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,261 +1,201 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelBase.lhs,v 1.61 2002/02/12 03:52:09 chak Exp $ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The University of Glasgow, 1992-2000 % \section[PrelBase]{Module @PrelBase@} -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelBase( - module PrelBase, - module PrelGHC -- Re-export PrelGHC, to avoid lots of people - -- having to import it explicitly - ) where - -import {-# SOURCE #-} PrelErr ( error ) -import PrelGHC - -infixr 9 . -infixl 9 !! -infixl 7 * -infixl 6 +, - -infixr 5 ++, : -infix 4 ==, /=, <, <=, >=, > -infixr 3 && -infixr 2 || -infixl 1 >>, >>= -infixr 0 $ -\end{code} - - -\begin{code} -{- -class Eval a -data Bool = False | True -data Int = I# Int# -data Double = D# Double# -data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) - -- (avoids weird-named functions, e.g., con2tag_()# - -data Maybe a = Nothing | Just a -data Ordering = LT | EQ | GT deriving( Eq ) - -type String = [Char] +The overall structure of the GHC Prelude is a bit tricky. -data Char = C# Char# -data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) - -- to avoid weird names like con2tag_[]# + a) We want to avoid "orphan modules", i.e. ones with instance + decls that don't belong either to a tycon or a class + defined in the same module + b) We want to avoid giant modules --------------- Stage 2 ----------------------- -not True = False -not False = True -True && x = x -False && x = False -otherwise = True +So the rough structure is as follows, in (linearised) dependency order -maybe :: b -> (a -> b) -> Maybe a -> b -maybe n f Nothing = n -maybe n f (Just x) = f x --------------- Stage 3 ----------------------- -class Eq a where - (==), (/=) :: a -> a -> Bool +PrelGHC Has no implementation. It defines built-in things, and + by importing it you bring them into scope. + The source file is PrelGHC.hi-boot, which is just + copied to make PrelGHC.hi - x /= y = not (x == y) + Classes: CCallable, CReturnable --- f :: Eq a => a -> a -> Bool -f x y = x == y +PrelBase Classes: Eq, Ord, Functor, Monad + Types: list, (), Int, Bool, Ordering, Char, String -g :: Eq a => a -> a -> Bool -g x y = f x y +PrelTup Types: tuples, plus instances for PrelBase classes --------------- Stage 4 ----------------------- +PrelShow Class: Show, plus instances for PrelBase/PrelTup types -class (Eq a) => Ord a where - compare :: a -> a -> Ordering - (<), (<=), (>=), (>):: a -> a -> Bool - max, min :: a -> a -> a +PrelEnum Class: Enum, plus instances for PrelBase/PrelTup 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 - | otherwise = GT +PrelMaybe Type: Maybe, plus instances for PrelBase classes - x <= y = compare x y /= GT - x < y = compare x y == LT - x >= y = compare x y /= LT - x > y = compare x y == GT - max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x } - min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y } +PrelNum Class: Num, plus instances for Int + Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show) -eqInt (I# x) (I# y) = x ==# y + Integer is needed here because it is mentioned in the signature + of 'fromInteger' in class Num -instance Eq Int where - (==) x y = x `eqInt` y +PrelReal Classes: Real, Integral, Fractional, RealFrac + plus instances for Int, Integer + Types: Ratio, Rational + plus intances for classes so far -instance Ord Int where - compare x y = error "help" - -class Bounded a where - minBound, maxBound :: a + Rational is needed here because it is mentioned in the signature + of 'toRational' in class Real +Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples -type ShowS = String -> String +PrelArr Types: Array, MutableArray, MutableVar -class Show a where - showsPrec :: Bool -> a -> ShowS - showList :: [a] -> ShowS + Does *not* contain any ByteArray stuff (see PrelByteArr) + Arrays are used by a function in PrelFloat - showList ls = showList__ (showsPrec True) ls +PrelFloat Classes: Floating, RealFloat + Types: Float, Double, plus instances of all classes so far -showList__ :: (a -> ShowS) -> [a] -> ShowS -showList__ showx [] = showString "[]" + This module contains everything to do with floating point. + It is a big module (900 lines) + With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi -showString :: String -> ShowS -showString = (++) +PrelByteArr Types: ByteArray, MutableByteArray + + We want this one to be after PrelFloat, because it defines arrays + of unboxed floats. -[] ++ [] = [] -shows :: (Show a) => a -> ShowS -shows = showsPrec True - --- show :: (Show a) => a -> String ---show x = shows x "" --} -\end{code} +Other Prelude modules are much easier with fewer complex dependencies. -%********************************************************* -%* * -\subsection{Standard classes @Eq@, @Ord@, @Bounded@, @Eval@} -%* * -%********************************************************* - \begin{code} -class Eq a where - (==), (/=) :: a -> a -> Bool - - x /= y = not (x == y) +{-# OPTIONS -fno-implicit-prelude #-} -class (Eq a) => Ord a where - compare :: a -> a -> Ordering - (<), (<=), (>=), (>):: a -> a -> Bool - max, min :: a -> a -> a +#include "MachDeps.h" --- 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 - | otherwise = GT +module PrelBase + ( + module PrelBase, + module PrelGHC, -- Re-export PrelGHC and PrelErr, to avoid lots + module PrelErr -- of people having to import it explicitly + ) + where - x <= y = compare x y /= GT - x < y = compare x y == LT - x >= y = compare x y /= LT - x > y = compare x y == GT - max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x } - min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y } +import PrelGHC +import {-# SOURCE #-} PrelErr -class Bounded a where - minBound, maxBound :: a +infixr 9 . +infixr 5 ++, : +infix 4 ==, /=, <, <=, >=, > +infixr 3 && +infixr 2 || +infixl 1 >>, >>= +infixr 0 $ -class Eval a +default () -- Double isn't available yet \end{code} + %********************************************************* %* * -\subsection{Monadic classes @Functor@, @Monad@, @MonadZero@, @MonadPlus@} +\subsection{DEBUGGING STUFF} +%* (for use when compiling PrelBase itself doesn't work) %* * %********************************************************* \begin{code} -class Functor f where - map :: (a -> b) -> f a -> f b - -class Monad m where - (>>=) :: m a -> (a -> m b) -> m b - (>>) :: m a -> m b -> m b - return :: a -> m a - - m >> k = m >>= \_ -> k +{- +data Bool = False | True +data Ordering = LT | EQ | GT +data Char = C# Char# +type String = [Char] +data Int = I# Int# +data () = () +data [] a = MkNil -class (Monad m) => MonadZero m where - zero :: m a +not True = False +(&&) True True = True +otherwise = True -class (MonadZero m) => MonadPlus m where - (++) :: m a -> m a -> m a +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{Classes @Num@ and @Enum@} +\subsection{Standard classes @Eq@, @Ord@} %* * %********************************************************* \begin{code} -class Enum a where - toEnum :: Int -> a - fromEnum :: a -> Int - enumFrom :: a -> [a] -- [n..] - enumFromThen :: a -> a -> [a] -- [n,n'..] - enumFromTo :: a -> a -> [a] -- [n..m] - enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] - - enumFromTo n m = map toEnum [fromEnum n .. fromEnum m] - enumFromThenTo n n' m - = map toEnum [fromEnum n, fromEnum n' .. fromEnum m] - -class (Eq a, Show a, Eval a) => Num a where - (+), (-), (*) :: a -> a -> a - negate :: a -> a - abs, signum :: a -> a - fromInteger :: Integer -> a - fromInt :: Int -> a -- partain: Glasgow extension - - x - y = x + negate y - fromInt (I# i#) = fromInteger (int2Integer# i#) - -- Go via the standard class-op if the - -- non-standard one ain't provided -\end{code} +class Eq a where + (==), (/=) :: a -> a -> Bool -\begin{code} -succ, pred :: Enum a => a -> a -succ = toEnum . (+1) . fromEnum -pred = toEnum . (subtract 1) . fromEnum + x /= y = not (x == y) + x == y = not (x /= y) -chr = (toEnum :: Int -> Char) -ord = (fromEnum :: Char -> Int) +class (Eq a) => Ord a where + compare :: a -> a -> Ordering + (<), (<=), (>), (>=) :: a -> a -> Bool + max, min :: a -> a -> a -ord_0 :: Num a => a -ord_0 = fromInt (ord '0') + -- An instance of Ord should define either 'compare' or '<='. + -- Using 'compare' can be more efficient for complex types. -{-# GENERATE_SPECS subtract a{Int#,Double#,Int,Double,Complex(Double#),Complex(Double)} #-} -subtract :: (Num a) => a -> a -> a -subtract x y = y - x + 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 { 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 y else x + min x y = if x <= y then x else y \end{code} - %********************************************************* %* * -\subsection{The @Show@ class} +\subsection{Monadic classes @Functor@, @Monad@ } %* * %********************************************************* \begin{code} -type ShowS = String -> String +class Functor f where + fmap :: (a -> b) -> f a -> f b -class Show a where - showsPrec :: Int -> a -> ShowS - showList :: [a] -> ShowS +class Monad m where + (>>=) :: m a -> (a -> m b) -> m b + (>>) :: m a -> m b -> m b + return :: a -> m a + fail :: String -> m a - showList ls = showList__ (showsPrec 0) ls + m >> k = m >>= \_ -> k + fail s = error s \end{code} + %********************************************************* %* * \subsection{The list type} @@ -266,119 +206,152 @@ class Show a where data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) -- to avoid weird names like con2tag_[]# -instance (Eq a) => Eq [a] where - [] == [] = True + +instance (Eq a) => Eq [a] where + {-# SPECIALISE instance Eq [Char] #-} + [] == [] = 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 - 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 } - - max a b = case compare a b of { LT -> b; EQ -> a; GT -> a } - min a b = case compare a b of { LT -> a; EQ -> a; GT -> b } - + {-# SPECIALISE instance Ord [Char] #-} compare [] [] = EQ - compare (x:xs) [] = GT - compare [] (y:ys) = LT + 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 - map f [] = [] - map f (x:xs) = f x : map f xs + fmap = map instance Monad [] where m >>= k = foldr ((++) . k) [] m m >> k = foldr ((++) . (\ _ -> k)) [] m return x = [x] - -instance MonadZero [] where - zero = [] - -instance MonadPlus [] where -#ifdef USE_REPORT_PRELUDE - xs ++ ys = foldr (:) ys xs -#else - [] ++ ys = ys - (x:xs) ++ ys = x : (xs ++ ys) -#endif - -instance (Show a) => Show [a] where - showsPrec p = showList - showList ls = showList__ (showsPrec 0) ls -\end{code} - + fail _ = [] \end{code} A few list functions that appear here because they are used here. The rest of the prelude list functions are in PrelList. +---------------------------------------------- +-- foldr/build/augment +---------------------------------------------- + \begin{code} -foldr :: (a -> b -> b) -> b -> [a] -> b -foldr f z [] = z -foldr f z (x:xs) = f x (foldr f z xs) - --- takeWhile, applied to a predicate p and a list xs, returns the longest --- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs --- returns the remaining suffix. Span p xs is equivalent to --- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. - -takeWhile :: (a -> Bool) -> [a] -> [a] -takeWhile p [] = [] -takeWhile p (x:xs) - | p x = x : takeWhile p xs - | otherwise = [] - -dropWhile :: (a -> Bool) -> [a] -> [a] -dropWhile p [] = [] -dropWhile p xs@(x:xs') - | p x = dropWhile p xs' - | otherwise = xs - --- List index (subscript) operator, 0-origin -(!!) :: [a] -> Int -> a -#ifdef USE_REPORT_PRELUDE -(x:_) !! 0 = x -(_:xs) !! n | n > 0 = xs !! (n-1) -(_:_) !! _ = error "PreludeList.!!: negative index" -[] !! _ = error "PreludeList.!!: index too large" -#else --- HBC version (stolen), then unboxified --- The semantics is not quite the same for error conditions --- in the more efficient version. --- -_ !! n | n < 0 = error "(!!){PreludeList}: negative index\n" -xs !! n = sub xs (case n of { I# n# -> n# }) - where sub :: [a] -> Int# -> a - sub [] _ = error "(!!){PreludeList}: index too large\n" - sub (x:xs) n# = if n# ==# 0# - then x - else sub xs (n# -# 1#) -#endif +foldr :: (a -> b -> b) -> b -> [a] -> b +-- foldr _ z [] = z +-- foldr f z (x:xs) = f x (foldr f z xs) +{-# 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 [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 "1" says to inline in phase 1 + +build g = g (:) [] + +augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a] +{-# INLINE [1] augment #-} +augment g xs = g (:) xs + +{-# RULES +"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) . + foldr k z (build g) = g k z + +"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" [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/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) . + augment g (build h) = build (\c n -> g c (h c n)) +"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) . + augment g [] = build g + #-} + +-- This rule is true, but not (I think) useful: +-- augment g (augment h t) = augment (\cn -> g c (h c n)) t \end{code} -%********************************************************* -%* * -\subsection{Type @Void@} -%* * -%********************************************************* +---------------------------------------------- +-- map +---------------------------------------------- + +\begin{code} +map :: (a -> b) -> [a] -> [b] +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 + +-- 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" [~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) + #-} +\end{code} -The type @Void@ is built in, but it needs a @Show@ instance. +---------------------------------------------- +-- append +---------------------------------------------- \begin{code} -void :: Void -void = error "You tried to evaluate void" +(++) :: [a] -> [a] -> [a] +(++) [] ys = ys +(++) (x:xs) ys = x : xs ++ ys + +{-# RULES +"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys + #-} -instance Show Void where - showsPrec p f = showString "<>" - showList ls = showList__ (showsPrec 0) ls \end{code} @@ -389,14 +362,15 @@ instance Show Void where %********************************************************* \begin{code} -data Bool = False | True deriving (Eq, Ord, Enum, Bounded, Show {- Read -}) +data Bool = False | True deriving (Eq, Ord) + -- Read in PrelRead, Show in PrelShow -- Boolean functions (&&), (||) :: Bool -> Bool -> Bool True && x = x -False && x = False -True || x = True +False && _ = False +True || _ = True False || x = x not :: Bool -> Bool @@ -419,11 +393,10 @@ some programs may get away without consulting PrelTup). Furthermore, the renamer currently *always* asks for () to be in scope, so that ccalls can use () as their default type; so when compiling PrelBase we need (). (We could arrange suck in () only if -fglasgow-exts, but putting -it here seems more direct. +it here seems more direct.) \begin{code} -data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) - -- (avoids weird-named functions, e.g., con2tag_()# +data () = () instance Eq () where () == () = True @@ -437,21 +410,9 @@ instance Ord () where max () () = () min () () = () compare () () = EQ - -instance Enum () where - toEnum 0 = () - toEnum _ = error "Prelude.Enum.().toEnum: argument not 0" - fromEnum () = 0 - enumFrom () = [()] - enumFromThen () () = [()] - enumFromTo () () = [()] - enumFromThenTo () () () = [()] - -instance Show () where - showsPrec p () = showString "()" - showList ls = showList__ (showsPrec 0) ls \end{code} + %********************************************************* %* * \subsection{Type @Ordering@} @@ -459,7 +420,8 @@ instance Show () where %********************************************************* \begin{code} -data Ordering = LT | EQ | GT deriving (Eq, Ord, Enum, Bounded, Show {- Read -}) +data Ordering = LT | EQ | GT deriving (Eq, Ord) + -- Read in PrelRead, Show in PrelShow \end{code} @@ -470,99 +432,56 @@ data Ordering = LT | EQ | GT deriving (Eq, Ord, Enum, Bounded, Show {- Read -}) %********************************************************* \begin{code} -type String = [Char] - -data Char = C# Char# deriving (Eq, Ord) - -instance Enum Char where - toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i) - | otherwise = error ("Prelude.Enum.Char.toEnum:out of range: " ++ show (I# i)) - fromEnum (C# c) = I# (ord# c) - - enumFrom (C# c) = efttCh (ord# c) 1# (># 255#) - enumFromTo (C# c1) (C# c2) = efttCh (ord# c1) 1# (># (ord# c2)) - - enumFromThen (C# c1) (C# c2) - | c1 `leChar#` c2 = efttCh (ord# c1) (ord# c2 -# ord# c1) (># 255#) - | otherwise = efttCh (ord# c1) (ord# c2 -# ord# c1) (<# 0#) - - enumFromThenTo (C# c1) (C# c2) (C# c3) - | c1 `leChar#` c2 = efttCh (ord# c1) (ord# c2 -# ord# c1) (># (ord# c3)) - | otherwise = efttCh (ord# c1) (ord# c2 -# ord# c1) (<# (ord# c3)) - -efttCh :: Int# -> Int# -> (Int# -> Bool) -> [Char] -efttCh now step done - = go now - where - go now | done now = [] - | otherwise = C# (chr# now) : go (now +# step) - -instance Show Char where - showsPrec p '\'' = showString "'\\''" - showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' - - showList cs = showChar '"' . showl cs - where showl "" = showChar '"' - showl ('"':cs) = showString "\\\"" . showl cs - showl (c:cs) = showLitChar c . showl cs +type String = [Char] + +data Char = C# Char# + +-- We don't use deriving for Eq and Ord, because for Ord the derived +-- instance defines only compare, which takes two primops. Then +-- '>' 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 + +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 + +{-# 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#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#) + | otherwise = error "Prelude.chr: bad argument" + +unsafeChr :: Int -> Char +unsafeChr (I# i#) = C# (chr# i#) + +ord :: Char -> Int +ord (C# c#) = I# (ord# c#) \end{code} +String equality is used when desugaring pattern-matches against strings. \begin{code} -isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, - isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool -isAscii c = fromEnum c < 128 -isLatin1 c = c <= '\xff' -isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f' -isPrint c = not (isControl c) - --- isSpace includes non-breaking space --- Done with explicit equalities both for efficiency, and to avoid a tiresome --- recursion with PrelList elem -isSpace c = c == ' ' || - c == '\t' || - c == '\n' || - c == '\r' || - c == '\f' || - c == '\v' || - c == '\xa0' - --- The upper case ISO characters have the multiplication sign dumped --- randomly in the middle of the range. Go figure. -isUpper c = c >= 'A' && c <= 'Z' || - c >= '\xC0' && c <= '\xD6' || - c >= '\xD8' && c <= '\xDE' --- The lower case ISO characters have the division sign dumped --- randomly in the middle of the range. Go figure. -isLower c = c >= 'a' && c <= 'z' || - c >= '\xDF' && c <= '\xF6' || - c >= '\xF8' && c <= '\xFF' -isAlpha c = isLower c || isUpper c -isDigit c = c >= '0' && c <= '9' -isOctDigit c = c >= '0' && c <= '7' -isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || - c >= 'a' && c <= 'f' -isAlphanum c = isAlpha c || isDigit c - --- Case-changing operations - -toUpper, toLower :: Char -> Char -toUpper c | isLower c && c /= '\xDF' && c /= '\xFF' - = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A') - | otherwise = c - -toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' - + fromEnum 'a') - | otherwise = c - -asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ') - ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", - "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", - "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", - "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", - "SP"] +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} + %********************************************************* %* * \subsection{Type @Int@} @@ -572,96 +491,42 @@ asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ') \begin{code} data Int = I# Int# -instance Eq Int where - (==) x y = x `eqInt` y - (/=) x y = x `neInt` y - -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 - max x y = case (compareInt x y) of { LT -> y ; EQ -> x ; GT -> x } - min x y = case (compareInt x y) of { LT -> x ; EQ -> x ; GT -> y } - -(I# x) `compareInt` (I# y) | x <# y = LT - | x ==# y = EQ - | otherwise = GT - -instance Enum Int where - toEnum x = x - fromEnum x = x - -#ifndef USE_FOLDR_BUILD - enumFrom (I# c) = eftInt c 1# - enumFromTo (I# c1) (I# c2) = efttInt c1 1# (># c2) - enumFromThen (I# c1) (I# c2) = eftInt c1 (c2 -# c1) - - enumFromThenTo (I# c1) (I# c2) (I# c3) - | c1 <=# c2 = efttInt c1 (c2 -# c1) (># c3) - | otherwise = efttInt c1 (c2 -# c1) (<# c3) - -#else - {-# INLINE enumFrom #-} - {-# INLINE enumFromTo #-} - enumFrom x = build (\ c _ -> - let g x = x `c` g (x `plusInt` 1) in g x) - enumFromTo x y = build (\ c n -> - let g x = if x <= y then x `c` g (x `plusInt` 1) else n in g x) +zeroInt, oneInt, twoInt, maxInt, minInt :: Int +zeroInt = I# 0# +oneInt = I# 1# +twoInt = I# 2# + +{- 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 -efttInt :: Int# -> Int# -> (Int# -> Bool) -> [Int] -efttInt now step done - = go now - where - go now | done now = [] - | otherwise = I# now : go (now +# step) - -eftInt :: Int# -> Int# -> [Int] -eftInt now step - = go now - where - go now = I# now : go (now +# step) - - -instance Num Int where - (+) x y = plusInt x y - (-) x y = minusInt x y - negate x = negateInt x - (*) x y = timesInt x y - abs n = if n `geInt` 0 then n else (negateInt n) - - signum n | n `ltInt` 0 = negateInt 1 - | n `eqInt` 0 = 0 - | otherwise = 1 - - fromInteger (J# a# s# d#) - = case (integer2Int# a# s# d#) of { i# -> I# i# } - - fromInt n = n - -instance Show Int where - showsPrec p n = showSignedInt p n - showList ls = showList__ (showsPrec 0) ls -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Integer@, @Float@, @Double@} -%* * -%********************************************************* - -Just the type declarations. If we don't actually use any @Integers@ we'd -rather not link the @Integer@ module at all; and the default-decl stuff -in the renamer tends to slurp in @Double@ regardless. +instance Eq Int where + (==) = eqInt + (/=) = neInt -\begin{code} -data Float = F# Float# -data Double = D# Double# -data Integer = J# Int# Int# ByteArray# +instance Ord Int where + compare = compareInt + (<) = ltInt + (<=) = leInt + (>=) = geInt + (>) = gtInt + +compareInt :: Int -> Int -> Ordering +(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} @@ -672,13 +537,6 @@ data Integer = J# Int# Int# ByteArray# %********************************************************* \begin{code} -instance Eval (a -> b) - -instance Show (a -> b) where - showsPrec p f = showString "<>" - showList ls = showList__ (showsPrec 0) ls - - -- identity function id :: a -> a id x = x @@ -689,7 +547,6 @@ const x _ = x -- function composition {-# INLINE (.) #-} -{-# GENERATE_SPECS (.) a b c #-} (.) :: (b -> c) -> (a -> b) -> a -> c (.) f g x = f (g x) @@ -699,6 +556,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 @@ -714,137 +572,256 @@ asTypeOf :: a -> a -> a asTypeOf = const \end{code} - %********************************************************* %* * -\subsection{Miscellaneous} +\subsection{CCallable instances} %* * %********************************************************* +Defined here to avoid orphans \begin{code} -data Lift a = Lift a -{-# GENERATE_SPECS data a :: Lift a #-} -\end{code} +instance CCallable Char +instance CReturnable Char +instance CCallable Int +instance CReturnable Int +instance CReturnable () -- Why, exactly? +\end{code} %********************************************************* %* * -\subsection{Support code for @Show@} +\subsection{Generics} %* * %********************************************************* \begin{code} -shows :: (Show a) => a -> ShowS -shows = showsPrec 0 +data Unit = Unit +data (:+:) a b = Inl a | Inr b +data (:*:) a b = a :*: b +\end{code} -show :: (Show a) => a -> String -show x = shows x "" -showChar :: Char -> ShowS -showChar = (:) +%********************************************************* +%* * +\subsection{Numeric primops} +%* * +%********************************************************* -showString :: String -> ShowS -showString = (++) +\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} -showParen :: Bool -> ShowS -> ShowS -showParen b p = if b then showChar '(' . p . showChar ')' else p +Definitions of the boxed PrimOps; these will be +used in the case of partial applications, etc. -{-# GENERATE_SPECS showList__ a #-} -showList__ :: (a -> ShowS) -> [a] -> ShowS +\begin{code} +{-# INLINE eqInt #-} +{-# INLINE neInt #-} +{-# INLINE gtInt #-} +{-# INLINE geInt #-} +{-# INLINE ltInt #-} +{-# INLINE leInt #-} +{-# INLINE plusInt #-} +{-# INLINE minusInt #-} +{-# INLINE timesInt #-} +{-# INLINE quotInt #-} +{-# INLINE remInt #-} +{-# INLINE negateInt #-} + +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) + +gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool +(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 + #-} + +-- 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. -showList__ showx [] = showString "[]" -showList__ showx (x:xs) = showChar '[' . showx x . showl xs - where - showl [] = showChar ']' - showl (x:xs) = showString ", " . showx x . showl xs +shiftL#, shiftRL# :: Word# -> Int# -> Word# -showSpace :: ShowS -showSpace = {-showChar ' '-} \ xs -> ' ' : xs -\end{code} +a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# + | otherwise = a `uncheckedShiftL#` b -Code specific for characters +a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# + | otherwise = a `uncheckedShiftRL#` b -\begin{code} -showLitChar :: Char -> ShowS -showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c)) -showLitChar '\DEL' = showString "\\DEL" -showLitChar '\\' = showString "\\\\" -showLitChar c | c >= ' ' = showChar c -showLitChar '\a' = showString "\\a" -showLitChar '\b' = showString "\\b" -showLitChar '\f' = showString "\\f" -showLitChar '\n' = showString "\\n" -showLitChar '\r' = showString "\\r" -showLitChar '\t' = showString "\\t" -showLitChar '\v' = showString "\\v" -showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO") -showLitChar c = showString ('\\' : asciiTab!!ord c) - -protectEsc p f = f . cont - where cont s@(c:_) | p c = "\\&" ++ s - cont s = s - -intToDigit :: Int -> Char -intToDigit i - | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i) - | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i -10) - | otherwise = error ("Char.intToDigit: not a digit" ++ show i) +iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int# -\end{code} +a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0# + | otherwise = a `uncheckedIShiftL#` b -Code specific for Ints. +a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0# + | otherwise = a `uncheckedIShiftRA#` b -\begin{code} -showSignedInt :: Int -> Int -> ShowS -showSignedInt p (I# n) r - = -- from HBC version; support code follows - if n <# 0# && p > 6 then '(':itos n++(')':r) else itos n ++ r - -itos :: Int# -> String -itos n = - if n <# 0# then - if negateInt# n <# 0# then - -- n is minInt, a difficult number - itos (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) [] - else - '-':itos' (negateInt# n) [] - else - itos' n [] - where - itos' :: Int# -> String -> String - itos' n cs = - if n <# 10# then - C# (chr# (n +# ord# '0'#)) : cs - else - itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# +# ord# '0'#)) : cs) +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} -%********************************************************* + +%******************************************************** %* * -\subsection{Numeric primops} +\subsection{Unpacking C strings} %* * -%********************************************************* +%******************************************************** -Definitions of the boxed PrimOps; these will be -used in the case of partial applications, etc. +This code is needed for virtually all programs, since it's used for +unpacking the strings of error messages. \begin{code} -{-# INLINE eqInt #-} -{-# INLINE neInt #-} +unpackCString# :: Addr# -> [Char] +{-# NOINLINE [1] unpackCString# #-} +unpackCString# a = unpackCStringList# a -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) -negateInt (I# x) = I# (negateInt# x) -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 +unpackCStringList# :: Addr# -> [Char] +unpackCStringList# addr + = unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh + +unpackAppendCString# :: Addr# -> [Char] -> [Char] +unpackAppendCString# addr rest + = unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = rest + | otherwise = C# ch : unpack (nh +# 1#) + where + 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 + unpack nh + | ch `eqChar#` '\0'# = z + | otherwise = C# ch `f` unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh + +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#) `uncheckedIShiftL#` 6# +# + (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) : + unpack (nh +# 2#) + | ch `leChar#` '\xEF'# = + 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#) `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 + ch = indexCharOffAddr# addr nh + +unpackNBytes# :: Addr# -> Int# -> [Char] +unpackNBytes# _addr 0# = [] +unpackNBytes# addr len# = unpack [] (len# -# 1#) + where + unpack acc i# + | i# <# 0# = acc + | otherwise = + case indexCharOffAddr# addr i# of + ch -> unpack (C# ch : acc) (i# -# 1#) + +{-# RULES +"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 + + #-} \end{code}