Use OPTIONS rather than OPTIONS_GHC for pragmas

[ghc-hetmet.git] / compiler / utils / FastString.lhs

diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs
index cdabd62..b744a37 100644 (file)
--- a/compiler/utils/FastString.lhs
+++ b/compiler/utils/FastString.lhs
@@ -2,6 +2,13 @@
 % (c) The University of Glasgow, 1997-2006
 %
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
 {-
 FastString:    A compact, hash-consed, representation of character strings.
                Comparison is O(1), and you can get a Unique from them.
@@ -78,11 +85,12 @@ import Data.IORef   ( IORef, newIORef, readIORef, writeIORef )
 import System.IO       ( hPutBuf )
 import Data.Maybe      ( isJust )
 
-import GHC.Arr         ( STArray(..), newSTArray )
+import GHC.ST
 import GHC.IOBase      ( IO(..) )
 import GHC.Ptr         ( Ptr(..) )
 
-#define hASH_TBL_SIZE  4091
+#define hASH_TBL_SIZE          4091
+#define hASH_TBL_SIZE_UNBOXED  4091#
 
 
 {-|
@@ -129,17 +137,17 @@ instance Show FastString where
 cmpFS :: FastString -> FastString -> Ordering
 cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) =
   if u1 == u2 then EQ else
-  let l = if l1 <= l2 then l1 else l2 in
-  inlinePerformIO $
-    withForeignPtr buf1 $ \p1 ->
-    withForeignPtr buf2 $ \p2 -> do
-      res <- memcmp p1 p2 l
-      case () of
-       _ | res <  0  -> return LT
-        | res == 0  -> if l1 == l2 then return EQ 
-                                   else if l1 < l2 then return LT
-                                                   else return GT
-        | otherwise -> return GT
+  case unsafeMemcmp buf1 buf2 (min l1 l2) `compare` 0 of
+     LT -> LT
+     EQ -> compare l1 l2
+     GT -> GT
+
+unsafeMemcmp :: ForeignPtr a -> ForeignPtr b -> Int -> Int
+unsafeMemcmp buf1 buf2 l =
+      inlinePerformIO $
+        withForeignPtr buf1 $ \p1 ->
+        withForeignPtr buf2 $ \p2 ->
+          memcmp p1 p2 l
 
 #ifndef __HADDOCK__
 foreign import ccall unsafe "ghc_memcmp" 
@@ -165,8 +173,10 @@ data FastStringTable =
 string_table :: IORef FastStringTable
 string_table = 
  unsafePerformIO $ do
-   (STArray _ _ arr#) <- stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
-   newIORef (FastStringTable 0 arr#)
+   tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of
+                           (# s2#, arr# #) ->
+                               (# s2#, FastStringTable 0 arr# #)
+   newIORef tab
 
 lookupTbl :: FastStringTable -> Int -> IO [FastString]
 lookupTbl (FastStringTable _ arr#) (I# i#) =