X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Futils%2FFastString.lhs;h=b744a37fc37dc80ebff10ef9c70b56755d2e409b;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hp=26f687c40fa99b19a8b43b4baaf724242b84665d;hpb=9c54ee0c9e25617b2a9ad4cdd9d3a6354e2edc0f;p=ghc-hetmet.git

diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs
index 26f687c..b744a37 100644
--- 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" 
@@ -161,11 +169,14 @@ data FastStringTable =
     {-# UNPACK #-} !Int
     (MutableArray# RealWorld [FastString])
 
+{-# NOINLINE string_table #-}
 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#) =
@@ -489,21 +500,7 @@ pokeCAString ptr str =
   in
   go str 0
 
-#if __GLASGOW_HASKELL__ < 600
-
-mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
-mallocForeignPtrBytes n = do
-  r <- mallocBytes n
-  newForeignPtr r (finalizerFree r)
-
-foreign import ccall unsafe "stdlib.h free" 
-  finalizerFree :: Ptr a -> IO ()
-
+#if __GLASGOW_HASKELL__ <= 602
 peekCAStringLen = peekCStringLen
-
-#elif __GLASGOW_HASKELL__ <= 602
-
-peekCAStringLen = peekCStringLen
-
 #endif
 \end{code}