X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FBitSet.lhs;h=a108136af3708c20a6e4e233010f5ef5a23cbcda;hb=6cfd14d1fca66eac8a1247f0a86aa11521650106;hp=eb6b52396f6894e5905168a42e40903d20304a6a;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/BitSet.lhs b/ghc/compiler/utils/BitSet.lhs
index eb6b523..a108136 100644
--- a/ghc/compiler/utils/BitSet.lhs
+++ b/ghc/compiler/utils/BitSet.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP Project, Glasgow University, 1994-1995
+% (c) The GRASP Project, Glasgow University, 1994-1998
 %
 \section[BitSet]{An implementation of very small sets}
 
@@ -18,19 +18,19 @@ Integer and get virtually unlimited sets.
 
 module BitSet (
 	BitSet,		-- abstract type
-	mkBS, listBS, emptyBS, singletonBS,
-	unionBS, minusBS
-#if ! defined(COMPILING_GHC)
-	, elementBS, intersectBS, isEmptyBS
-#endif
+	mkBS, listBS, emptyBS, unitBS,
+	unionBS, minusBS, intBS
     ) where
 
+#include "HsVersions.h"
+
 #ifdef __GLASGOW_HASKELL__
+import GLAEXTS
 -- nothing to import
 #elif defined(__YALE_HASKELL__)
 {-hide import from mkdependHS-}
 import
-        LogOpPrims
+	LogOpPrims
 #else
 {-hide import from mkdependHS-}
 import
@@ -41,15 +41,19 @@ import
 
 data BitSet = MkBS Word#
 
-emptyBS :: BitSet 
+emptyBS :: BitSet
 emptyBS = MkBS (int2Word# 0#)
 
 mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
+mkBS xs = foldr (unionBS . unitBS) emptyBS xs
 
-singletonBS :: Int -> BitSet
-singletonBS x = case x of
+unitBS :: Int -> BitSet
+unitBS x = case x of
+#if __GLASGOW_HASKELL__ >= 503
+    I# i# -> MkBS ((int2Word# 1#) `uncheckedShiftL#` i#)
+#else
     I# i# -> MkBS ((int2Word# 1#) `shiftL#` i#)
+#endif
 
 unionBS :: BitSet -> BitSet -> BitSet
 unionBS (MkBS x#) (MkBS y#) = MkBS (x# `or#` y#)
@@ -57,11 +61,11 @@ unionBS (MkBS x#) (MkBS y#) = MkBS (x# `or#` y#)
 minusBS :: BitSet -> BitSet -> BitSet
 minusBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` (not# y#))
 
-#if ! defined(COMPILING_GHC)
+#if 0
 -- not used in GHC
 isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s#) = 
-    case word2Int# s# of
+isEmptyBS (MkBS s#)
+  = case word2Int# s# of
     	0# -> True
     	_  -> False
 
@@ -77,7 +81,7 @@ elementBS x (MkBS s#) = case x of
 
 listBS :: BitSet -> [Int]
 listBS s = listify s 0
-    where listify (MkBS s#) n = 
+    where listify (MkBS s#) n =
     	    case word2Int# s# of
     	        0# -> []
     	        _  -> let s' = (MkBS (s# `shiftr` 1#))
@@ -85,33 +89,37 @@ listBS s = listify s 0
     	    	      in case word2Int# (s# `and#` (int2Word# 1#)) of
     	    	    	  0# -> more
     	    	    	  _  -> n : more
-# if __GLASGOW_HASKELL__ >= 23
+#if __GLASGOW_HASKELL__ >= 503
+	  shiftr x y = uncheckedShiftRL# x y
+#else
 	  shiftr x y = shiftRL# x y
-# else
-	  shiftr x y = shiftR#  x y
-# endif
+#endif
+
+-- intBS is a bit naughty.
+intBS :: BitSet -> Int
+intBS (MkBS w#) = I# (word2Int# w#)
 
 #elif defined(__YALE_HASKELL__)
 
 data BitSet = MkBS Int
 
-emptyBS :: BitSet 
+emptyBS :: BitSet
 emptyBS = MkBS 0
 
 mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
+mkBS xs = foldr (unionBS . unitBS) emptyBS xs
 
-singletonBS :: Int -> BitSet
-singletonBS x = MkBS (1 `ashInt` x)
+unitBS :: Int -> BitSet
+unitBS x = MkBS (1 `ashInt` x)
 
 unionBS :: BitSet -> BitSet -> BitSet
 unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y)
 
-#if ! defined(COMPILING_GHC)
+#if 0
 -- not used in GHC
 isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) = 
-    case s of
+isEmptyBS (MkBS s)
+  = case s of
     	0 -> True
     	_ -> False
 
@@ -119,8 +127,8 @@ intersectBS :: BitSet -> BitSet -> BitSet
 intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y)
 
 elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) = 
-    case logbitpInt x s of
+elementBS x (MkBS s)
+  = case logbitpInt x s of
     	0 -> False
     	_ -> True
 #endif
@@ -128,39 +136,39 @@ elementBS x (MkBS s) =
 minusBS :: BitSet -> BitSet -> BitSet
 minusBS (MkBS x) (MkBS y) = MkBS (x `logandc2Int` y)
 
--- rewritten to avoid right shifts (which would give nonsense on negative 
+-- rewritten to avoid right shifts (which would give nonsense on negative
 -- values.
 listBS :: BitSet -> [Int]
 listBS (MkBS s) = listify s 0 1
-    where listify s n m = 
+    where listify s n m =
     	    case s of
     	        0 -> []
     	        _ -> let n' = n+1; m' = m+m in
-                     case logbitpInt s m of
+		     case logbitpInt s m of
 		     0 -> listify s n' m'
 		     _ -> n : listify (s `logandc2Int` m) n' m'
 
-#else	/* HBC, perhaps? */    
+#else	/* HBC, perhaps? */
 
 data BitSet = MkBS Word
 
-emptyBS :: BitSet 
+emptyBS :: BitSet
 emptyBS = MkBS 0
 
 mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
+mkBS xs = foldr (unionBS . unitBS) emptyBS xs
 
-singletonBS :: Int -> BitSet
-singletonBS x = MkBS (1 `bitLsh` x)
+unitBS :: Int -> BitSet
+unitBS x = MkBS (1 `bitLsh` x)
 
 unionBS :: BitSet -> BitSet -> BitSet
 unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y)
 
-#if ! defined(COMPILING_GHC)
+#if 0
 -- not used in GHC
 isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) = 
-    case s of
+isEmptyBS (MkBS s)
+  = case s of
     	0 -> True
     	_ -> False
 
@@ -168,8 +176,8 @@ intersectBS :: BitSet -> BitSet -> BitSet
 intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y)
 
 elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) = 
-    case (1 `bitLsh` x) `bitAnd` s of
+elementBS x (MkBS s)
+  = case (1 `bitLsh` x) `bitAnd` s of
     	0 -> False
     	_ -> True
 #endif
@@ -179,7 +187,7 @@ minusBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` (bitCompl y))
 
 listBS :: BitSet -> [Int]
 listBS (MkBS s) = listify s 0
-    where listify s n = 
+    where listify s n =
     	    case s of
     	        0 -> []
     	        _ -> let s' = s `bitRsh` 1