X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelBase.lhs;h=e9160ea9a4b0a348686764264e5fccd1fb6fb18b;hb=65884f1ee21fef547b958f89eaf935a9f3683b51;hp=b48a3e619b6c9a850730742c4df9439a21e32b43;hpb=9d38678ea60ff32f756390a30c659daa22c98c93;p=ghc-hetmet.git

diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs
index b48a3e6..e9160ea 100644
--- a/ghc/lib/std/PrelBase.lhs
+++ b/ghc/lib/std/PrelBase.lhs
@@ -4,8 +4,74 @@
 \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 #-}
+{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude #-}
 
 module PrelBase
 	(
@@ -25,6 +91,44 @@ infixr 3  &&
 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]
+unpackNBytes#      :: Addr# -> Int#   -> [Char]
+unpackNBytes# a b = error "urk"
+unpackCString# a = error "urk"
+unpackFoldrCString# a = error "urk"
+unpackAppendCString# a = error "urk"
+-}
 \end{code}
 
 
@@ -38,8 +142,11 @@ infixr 0  $
 class  Eq a  where
     (==), (/=)		:: a -> a -> Bool
 
-    x /= y		=  not (x == y)
-    x == y		= not  (x /= y)
+--    x /= y		= not (x == y)
+--    x == y		= not (x /= y)
+--    x /= y		=  True
+    (/=) x y            = not  ((==) x y)
+    x == y		=  True
 
 class  (Eq a) => Ord a  where
     compare             :: a -> a -> Ordering
@@ -98,8 +205,11 @@ 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
+{-
     {-# SPECIALISE instance Eq [Char] #-}
+-}
     []     == []     = True	
     (x:xs) == (y:ys) = x == y && xs == ys
     _xs    == _ys    = False			
@@ -107,7 +217,9 @@ instance (Eq a) => Eq [a]  where
     xs     /= ys     = if (xs == ys) then False else True
 
 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  }
@@ -149,30 +261,42 @@ foldr k z xs = go xs
 	       go (x:xs) = x `k` go xs
 
 build 	:: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
-{-# INLINE build #-}
+{-# INLINE 2 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
+
 build g = g (:) []
 
 augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
-{-# INLINE augment #-}
+{-# INLINE 2 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/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/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)
+		       (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}
 
 
@@ -182,8 +306,7 @@ 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)
+map = mapList
 
 -- Note eta expanded
 mapFB c f x ys = c (f x) ys
@@ -193,7 +316,8 @@ mapList _ []     = []
 mapList f (x:xs) = f x : mapList f xs
 
 {-# RULES
-"mapFB"	    forall c,f,g.	mapFB (mapFB c f) g	= mapFB c (f.g) 
+"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}
@@ -204,8 +328,11 @@ 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
+(++) = append
+
+{-# RULES
+  "++"	forall xs ys. (++) xs ys = augment (\c n -> foldr c n xs) ys
+ #-}
 
 append :: [a] -> [a] -> [a]
 append []     ys = ys
@@ -357,33 +484,6 @@ compareInt :: Int -> Int -> Ordering
 
 %*********************************************************
 %*							*
-\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#
-\end{code}
-
-
-%*********************************************************
-%*							*
 \subsection{The function type}
 %*							*
 %*********************************************************
@@ -425,6 +525,25 @@ asTypeOf		=  const
 
 %*********************************************************
 %*							*
+\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{Numeric primops}
 %*							*
 %*********************************************************
@@ -446,16 +565,30 @@ used in the case of partial applications, etc.
 {-# INLINE remInt #-}
 {-# INLINE negateInt #-}
 
-plusInt, minusInt, timesInt, quotInt, remInt :: Int -> Int -> Int
+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)
 
 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
+
 gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool
 gtInt	(I# x) (I# y) = x ># y
 geInt	(I# x) (I# y) = x >=# y
@@ -465,14 +598,72 @@ ltInt	(I# x) (I# y) = x <# y
 leInt	(I# x) (I# y) = x <=# y
 \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]
+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 
+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
+
+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
+
+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"	 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
+
+-- There's a built-in rule (in PrelRules.lhs) for
+-- 	unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n
+
+  #-}
+
 \end{code}