add -dfaststring-stats to dump some stats about the FastString hash table

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

diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 2558c56..4d432e6 100644 (file)
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -2,8 +2,6 @@
 % (c) The University of Glasgow, 1997-2006
 %
 \begin{code}
-{-# OPTIONS -fglasgow-exts -O #-}
-
 {-
 FastString:    A compact, hash-consed, representation of character strings.
                Comparison is O(1), and you can get a Unique from them.
@@ -53,6 +51,10 @@ module FastString
        -- ** Outputing
         hPutFS,
 
+       -- ** Internal
+       getFastStringTable,
+       hasZEncoding,
+
        -- * LitStrings
        LitString, 
        mkLitString#,
@@ -68,16 +70,16 @@ import Encoding
 
 import Foreign
 import Foreign.C
-import GLAEXTS
-import UNSAFE_IO       ( unsafePerformIO )
-import MONAD_ST                ( stToIO )
-import DATA_IOREF      ( IORef, newIORef, readIORef, writeIORef )
+import GHC.Exts
+import System.IO.Unsafe ( unsafePerformIO )
+import Control.Monad.ST        ( stToIO )
+import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
 import System.IO       ( hPutBuf )
+import Data.Maybe      ( isJust )
 
 import GHC.Arr         ( STArray(..), newSTArray )
 import GHC.IOBase      ( IO(..) )
-
-import IO
+import GHC.Ptr         ( Ptr(..) )
 
 #define hASH_TBL_SIZE  4091
 
@@ -346,6 +348,17 @@ isZEncoded :: FastString -> Bool
 isZEncoded fs | ZEncoded <- enc fs = True
                | otherwise          = False
 
+-- | Returns 'True' if this 'FastString' is not Z-encoded but already has
+-- a Z-encoding cached (used in producing stats).
+hasZEncoding :: FastString -> Bool
+hasZEncoding fs@(FastString uid n_bytes _ fp enc) =
+  case enc of
+    ZEncoded -> False
+    UTF8Encoded ref ->
+      inlinePerformIO $ do
+        m <- readIORef ref
+       return (isJust m)
+
 -- | Returns 'True' if the 'FastString' is empty
 nullFS :: FastString -> Bool
 nullFS f  =  n_bytes f == 0
@@ -418,6 +431,15 @@ uniqueOfFS (FastString (I# u#) _ _ _ _) = u#
 nilFS = mkFastString ""
 
 -- -----------------------------------------------------------------------------
+-- Stats
+
+getFastStringTable :: IO [[FastString]]
+getFastStringTable = do
+  tbl <- readIORef string_table
+  buckets <- mapM (lookupTbl tbl) [0..hASH_TBL_SIZE]
+  return buckets
+
+-- -----------------------------------------------------------------------------
 -- Outputting 'FastString's
 
 -- |Outputs a 'FastString' with /no decoding at all/, that is, you
@@ -448,12 +470,30 @@ foreign import ccall unsafe "ghc_strlen"
 inlinePerformIO :: IO a -> a
 inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 
+-- NB. does *not* add a '\0'-terminator.
 pokeCAString :: Ptr CChar -> String -> IO ()
 pokeCAString ptr str =
   let
-       go [] n     = pokeElemOff ptr n 0
+       go [] n     = return ()
        go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
   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 ()
+
+peekCAStringLen = peekCStringLen
+
+#elif __GLASGOW_HASKELL__ <= 602
+
+peekCAStringLen = peekCStringLen
+
+#endif
 \end{code}