+% -----------------------------------------------------------------------------
+% $Id: PrelBase.lhs,v 1.61 2002/02/12 03:52:09 chak Exp $
%
-% (c) The GRAP/AQUA Project, Glasgow University, 1992-1996
+% (c) The University of Glasgow, 1992-2000
%
\section[PrelBase]{Module @PrelBase@}
+The overall structure of the GHC Prelude is a bit tricky.
+
+ 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
+
+So the rough structure is as follows, in (linearised) dependency order
+
+
+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
+
+ Classes: CCallable, CReturnable
+
+PrelBase Classes: Eq, Ord, Functor, Monad
+ Types: list, (), Int, Bool, Ordering, Char, String
+
+PrelTup Types: tuples, plus instances for PrelBase classes
+
+PrelShow Class: Show, plus instances for PrelBase/PrelTup types
+
+PrelEnum Class: Enum, plus instances for PrelBase/PrelTup types
+
+PrelMaybe Type: Maybe, plus instances for PrelBase classes
+
+PrelNum Class: Num, plus instances for Int
+ Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show)
+
+ Integer is needed here because it is mentioned in the signature
+ of 'fromInteger' in class Num
+
+PrelReal Classes: Real, Integral, Fractional, RealFrac
+ plus instances for Int, Integer
+ Types: Ratio, Rational
+ plus intances for classes so far
+
+ 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
+
+PrelArr Types: Array, MutableArray, MutableVar
+
+ Does *not* contain any ByteArray stuff (see PrelByteArr)
+ Arrays are used by a function in PrelFloat
+
+PrelFloat Classes: Floating, RealFloat
+ Types: Float, Double, plus instances of all classes so far
+
+ 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
+
+PrelByteArr Types: ByteArray, MutableByteArray
+
+ We want this one to be after PrelFloat, because it defines arrays
+ of unboxed floats.
+
+
+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 ++, :
infixr 2 ||
infixl 1 >>, >>=
infixr 0 $
+
+default () -- Double isn't available yet
+\end{code}
+
+
+%*********************************************************
+%* *
+\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}
\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}
%*********************************************************
\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
return :: a -> m a
fail :: String -> m a
- m >> k = m >>= \_ -> k
+ m >> k = m >>= \_ -> k
fail s = error s
-
\end{code}
data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
-- to avoid weird names like con2tag_[]#
-instance (Eq a) => Eq [a] where
- [] == [] = True
- (x:xs) == (y:ys) = x == y && xs == ys
- _xs == _ys = False
- xs /= ys = if (xs == ys) then False else True
+instance (Eq a) => Eq [a] where
+ {-# SPECIALISE instance Eq [Char] #-}
+ [] == [] = True
+ (x:xs) == (y:ys) = x == y && xs == ys
+ _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 }
-
+ {-# SPECIALISE instance Ord [Char] #-}
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
\begin{code}
foldr :: (a -> b -> b) -> b -> [a] -> b
-foldr _ z [] = z
-foldr f z (x:xs) = f x (foldr f z xs)
+-- 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 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 "1" says to inline in phase 1
+
build g = g (:) []
augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
-{-# INLINE augment #-}
+{-# INLINE [1] augment #-}
augment g xs = g (:) xs
{-# RULES
-"fold/build" forall k,z,g::forall b. (a->b->b) -> b -> b .
+"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/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/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/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}
\begin{code}
map :: (a -> b) -> [a] -> [b]
-{-# INLINE map #-}
-map f xs = build (\c n -> foldr (mapFB c f) n xs)
-
-mapFB c f xs = c (f xs)
-
-mapList :: (a -> b) -> [a] -> [b]
-mapList _ [] = []
-mapList f (x:xs) = f x : mapList f xs
+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
-"mapFB" forall c,f,g. mapFB (mapFB c f) g = mapFB c (f.g)
-"mapList" forall f. foldr (mapFB (:) f) [] = mapList f
- #-}
+"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}
----------------------------------------------
\begin{code}
(++) :: [a] -> [a] -> [a]
-{-# INLINE (++) #-}
-xs ++ ys = augment (\c n -> foldr c n xs) ys
+(++) [] ys = ys
+(++) (x:xs) ys = x : xs ++ ys
+
+{-# RULES
+"++" [~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}
it here seems more direct.)
\begin{code}
-data () = ()
+data () = ()
instance Eq () where
() == () = True
%*********************************************************
\begin{code}
-type String = [Char]
+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
-data Char = C# Char# deriving (Eq, Ord)
+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) | 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}
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
-\end{code}
-
+(I# x#) `compareInt` (I# y#) = compareInt# x# y#
-%*********************************************************
-%* *
-\subsection{Type @Integer@, @Float@, @Double@}
-%* *
-%*********************************************************
-
-\begin{code}
-data Float = F# Float#
-data Double = D# Double#
-
-data Integer
- = S# Int# -- small integers
- | J# Int# ByteArray# -- large integers
-
-instance Eq Integer where
- (S# i) == (S# j) = i ==# j
- (S# i) == (J# s d) = cmpIntegerInt# s d i ==# 0#
- (J# s d) == (S# i) = cmpIntegerInt# s d i ==# 0#
- (J# s1 d1) == (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0#
-
- (S# i) /= (S# j) = i /=# j
- (S# i) /= (J# s d) = cmpIntegerInt# s d i /=# 0#
- (J# s d) /= (S# i) = cmpIntegerInt# s d i /=# 0#
- (J# s1 d1) /= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0#
+compareInt# :: Int# -> Int# -> Ordering
+compareInt# x# y#
+ | x# <# y# = LT
+ | x# ==# y# = EQ
+ | otherwise = GT
\end{code}
-- right-associating infix application operator (useful in continuation-
-- passing style)
+{-# INLINE ($) #-}
($) :: (a -> b) -> a -> b
f $ x = f x
%*********************************************************
%* *
+\subsection{CCallable instances}
+%* *
+%*********************************************************
+
+Defined here to avoid orphans
+
+\begin{code}
+instance CCallable Char
+instance CReturnable Char
+
+instance CCallable Int
+instance CReturnable Int
+
+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.
{-# INLINE remInt #-}
{-# INLINE negateInt #-}
-plusInt, minusInt, timesInt, quotInt, remInt :: 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)
+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)
+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
+ #-}
+
+-- 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}
-Convenient boxed Integer PrimOps. These are 'thin-air' Ids, so
-it's nice to have them in PrelBase.
+
+%********************************************************
+%* *
+\subsection{Unpacking C strings}
+%* *
+%********************************************************
+
+This code is needed for virtually all programs, since it's used for
+unpacking the strings of error messages.
\begin{code}
-{-# INLINE int2Integer #-}
-{-# INLINE addr2Integer #-}
-int2Integer :: Int# -> Integer
-int2Integer i = S# i
-addr2Integer :: Addr# -> Integer
-addr2Integer x = case addr2Integer# x of (# s, d #) -> J# s d
+unpackCString# :: Addr# -> [Char]
+{-# NOINLINE [1] unpackCString# #-}
+unpackCString# a = unpackCStringList# a
+
+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}
projects / ghc-hetmet.git / blobdiff