X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=6d51f3aaf2c56aca8d4f509df673a52cf8073d9d;hp=0ce1f4992188c87fab686ce366fbd019d35bc9be;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 0ce1f49..6d51f3a 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -9,12 +9,16 @@
 # define IF_NOT_GHC(a) {--}
 #else
 # define panic error
-# define TAG_ _CMP_TAG
-# define LT_ _LT
-# define EQ_ _EQ
-# define GT_ _GT
+# define TAG_ Ordering
+# define LT_ LT
+# define EQ_ EQ
+# define GT_ GT
+# define _LT LT
+# define _EQ EQ
+# define _GT GT
 # define GT__ _
-# define tagCmp_ _tagCmp
+# define tagCmp_ compare
+# define _tagCmp compare
 # define FAST_STRING String
 # define ASSERT(x) {-nothing-}
 # define IF_NOT_GHC(a) a
@@ -39,10 +43,10 @@ module Util (
 	IF_NOT_GHC(forall COMMA exists COMMA)
 	zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
         zipLazy,
-	mapAndUnzip,
+	mapAndUnzip, mapAndUnzip3,
 	nOfThem, lengthExceeds, isSingleton,
-	startsWith, endsWith,
 #if defined(COMPILING_GHC)
+	startsWith, endsWith,
 	isIn, isn'tIn,
 #endif
 
@@ -65,13 +69,13 @@ module Util (
 	mapAccumL, mapAccumR, mapAccumB,
 
 	-- comparisons
+#if defined(COMPILING_GHC)
 	Ord3(..), thenCmp, cmpList,
-	IF_NOT_GHC(cmpString COMMA)
-#ifdef USE_FAST_STRINGS
 	cmpPString,
 #else
-	substr,
+	cmpString,
 #endif
+
 	-- pairs
 	IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
 	IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
@@ -80,31 +84,22 @@ module Util (
 	-- error handling
 #if defined(COMPILING_GHC)
 	, panic, panic#, pprPanic, pprPanic#, pprError, pprTrace
-# ifdef DEBUG
 	, assertPanic
-# endif
 #endif {- COMPILING_GHC -}
 
-	-- and to make the interface self-sufficient...
-#if __HASKELL1__ < 3
-# if defined(COMPILING_GHC)
-	, Maybe(..){-.. for pragmas...-}, PrettyRep, Pretty(..)
-# else
-	, Maybe
-# endif
-#endif
-
     ) where
 
 #if defined(COMPILING_GHC)
 
 CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(List(zipWith4))
 
 import Pretty
+#else
+import List(zipWith4)
 #endif
-#if __HASKELL1__ < 3
-import Maybes		( Maybe(..) )
-#endif
+
+infixr 9 `thenCmp`
 \end{code}
 
 %************************************************************************
@@ -146,34 +141,34 @@ are of equal length.  Alastair Reid thinks this should only happen if
 DEBUGging on; hey, why not?
 
 \begin{code}
-zipEqual	:: [a] -> [b] -> [(a,b)]
-zipWithEqual	:: (a->b->c) -> [a]->[b]->[c]
-zipWith3Equal	:: (a->b->c->d) -> [a]->[b]->[c]->[d]
-zipWith4Equal	:: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+zipEqual	:: String -> [a] -> [b] -> [(a,b)]
+zipWithEqual	:: String -> (a->b->c) -> [a]->[b]->[c]
+zipWith3Equal	:: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith4Equal	:: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 
 #ifndef DEBUG
-zipEqual      = zip
-zipWithEqual  = zipWith
-zipWith3Equal = zipWith3
-zipWith4Equal = zipWith4
+zipEqual      _ = zip
+zipWithEqual  _ = zipWith
+zipWith3Equal _ = zipWith3
+zipWith4Equal _ = zipWith4
 #else
-zipEqual []     []     = []
-zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs
-zipEqual as     bs     = panic "zipEqual: unequal lists"
-
-zipWithEqual z (a:as) (b:bs)	=  z a b : zipWithEqual z as bs
-zipWithEqual _ [] []		=  []
-zipWithEqual _ _ _		=  panic "zipWithEqual: unequal lists"
-
-zipWith3Equal z (a:as) (b:bs) (c:cs)
-				=  z a b c : zipWith3Equal z as bs cs
-zipWith3Equal _ [] []  []	=  []
-zipWith3Equal _ _  _   _	=  panic "zipWith3Equal: unequal lists"
-
-zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds)
-				=  z a b c d : zipWith4Equal z as bs cs ds
-zipWith4Equal _ [] [] [] []	=  []
-zipWith4Equal _ _  _  _  _	=  panic "zipWith4Equal: unequal lists"
+zipEqual msg []     []     = []
+zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
+zipEqual msg as     bs     = panic ("zipEqual: unequal lists:"++msg)
+
+zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
+zipWithEqual msg _ [] []	=  []
+zipWithEqual msg _ _ _		=  panic ("zipWithEqual: unequal lists:"++msg)
+
+zipWith3Equal msg z (a:as) (b:bs) (c:cs)
+				=  z a b c : zipWith3Equal msg z as bs cs
+zipWith3Equal msg _ [] []  []	=  []
+zipWith3Equal msg _ _  _   _	=  panic ("zipWith3Equal: unequal lists:"++msg)
+
+zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
+				=  z a b c d : zipWith4Equal msg z as bs cs ds
+zipWith4Equal msg _ [] [] [] []	=  []
+zipWith4Equal msg _ _  _  _  _	=  panic ("zipWith4Equal: unequal lists:"++msg)
 #endif
 \end{code}
 
@@ -195,6 +190,16 @@ mapAndUnzip f (x:xs)
 	(rs1, rs2) = mapAndUnzip f xs
     in
     (r1:rs1, r2:rs2)
+
+mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
+
+mapAndUnzip3 f [] = ([],[],[])
+mapAndUnzip3 f (x:xs)
+  = let
+	(r1,  r2,  r3)  = f x
+	(rs1, rs2, rs3) = mapAndUnzip3 f xs
+    in
+    (r1:rs1, r2:rs2, r3:rs3)
 \end{code}
 
 \begin{code}
@@ -216,6 +221,7 @@ startsWith, endsWith :: String -> String -> Maybe String
 startsWith []     str = Just str
 startsWith (c:cs) (s:ss)
   = if c /= s then Nothing else startsWith cs ss
+startsWith  _	  []  = Nothing
 
 endsWith cs ss
   = case (startsWith (reverse cs) (reverse ss)) of
@@ -258,27 +264,6 @@ isn'tIn msg x ys
 
 # endif {- DEBUG -}
 
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isIn :: String -> Literal -> [Literal] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> MagicId -> [MagicId] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Name -> [Name] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyCon -> [TyCon] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyVar -> [TyVar] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Unique -> [Unique] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> _PackedString -> [_PackedString] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> (Id, Id) -> [(Id, Id)] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> Int -> [Int] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> Id -> [Id] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> MagicId -> [MagicId] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyCon -> [TyCon] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyVar -> [TyVar] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
-# endif
-
 #endif {- COMPILING_GHC -}
 \end{code}
 
@@ -298,21 +283,6 @@ assoc crash_msg lst key
     then panic ("Failed in assoc: " ++ crash_msg)
     else head res
   where res = [ val | (key', val) <- lst, key == key']
-
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE assoc :: String -> [(Id,            a)] -> Id		-> a #-}
-{-# SPECIALIZE assoc :: String -> [(Class,         a)] -> Class		-> a #-}
-{-# SPECIALIZE assoc :: String -> [(Name,          a)] -> Name		-> a #-}
-{-# SPECIALIZE assoc :: String -> [(PrimRep,      a)] -> PrimRep	-> a #-}
-{-# SPECIALIZE assoc :: String -> [(String,        a)] -> String        -> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyCon,         a)] -> TyCon		-> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyVar,         a)] -> TyVar		-> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-}
-{-# SPECIALIZE assoc :: String -> [(Type,          a)] -> Type		-> a #-}
-{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-}
-# endif
-#endif
 \end{code}
 
 %************************************************************************
@@ -337,11 +307,6 @@ hasNoDups xs = f [] xs
 #else
     is_elem = elem
 #endif
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-}
-# endif
-#endif
 \end{code}
 
 \begin{code}
@@ -628,11 +593,11 @@ transitiveClosure :: (a -> [a])		-- Successor function
 		  -> [a]		-- The transitive closure
 
 transitiveClosure succ eq xs
- = do [] xs
+ = go [] xs
  where
-   do done [] 			   = done
-   do done (x:xs) | x `is_in` done = do done xs
-   		  | otherwise      = do (x:done) (succ x ++ xs)
+   go done [] 			   = done
+   go done (x:xs) | x `is_in` done = go done xs
+   		  | otherwise      = go (x:done) (succ x ++ xs)
 
    x `is_in` []                 = False
    x `is_in` (y:ys) | eq x y    = True
@@ -759,26 +724,18 @@ cmpString (x:xs) (y:ys) = if	  x == y then cmpString xs ys
 cmpString []     ys	= LT_
 cmpString xs     []	= GT_
 
+#ifdef COMPILING_GHC
 cmpString _ _ = panic# "cmpString"
+#else
+cmpString _ _ = error "cmpString"
+#endif
 \end{code}
 
 \begin{code}
-#ifdef USE_FAST_STRINGS
 cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
 
 cmpPString x y
   = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
-#endif
-\end{code}
-
-\begin{code}
-#ifndef USE_FAST_STRINGS
-substr :: FAST_STRING -> Int -> Int -> FAST_STRING
-
-substr str beg end
-  = ASSERT (beg >= 0 && beg <= end)
-    take (end - beg + 1) (drop beg str)
-#endif
 \end{code}
 
 %************************************************************************
@@ -829,11 +786,15 @@ unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 panic x = error ("panic! (the `impossible' happened):\n\t"
 	      ++ x ++ "\n\n"
 	      ++ "Please report it as a compiler bug "
-	      ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" )
+	      ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
 
 pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
 pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg))
+#if __GLASGOW_HASKELL__ >= 200
+pprTrace heading pretty_msg = GHCbase.trace (heading++(ppShow 80 pretty_msg))
+#else
 pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
+#endif
 
 -- #-versions because panic can't return an unboxed int, and that's
 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
@@ -844,9 +805,8 @@ panic# s = case (panic s) of () -> EQ_
 
 pprPanic# heading pretty_msg = panic# (heading++(ppShow 80 pretty_msg))
 
-# ifdef DEBUG
 assertPanic :: String -> Int -> a
 assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
-# endif
+
 #endif {- COMPILING_GHC -}
 \end{code}