From 76e3742711eb9eb2fed7654c56e602b54c517e87 Mon Sep 17 00:00:00 2001
From: Simon Marlow <simonmar@microsoft.com>
Date: Wed, 8 Feb 2006 13:10:18 +0000
Subject: [PATCH] add -dfaststring-stats to dump some stats about the
 FastString hash table

---
 ghc/compiler/main/DynFlags.hs     |    2 ++
 ghc/compiler/main/Main.hs         |   41 ++++++++++++++++++++++++++++++++++++-
 ghc/compiler/utils/FastString.lhs |   25 ++++++++++++++++++++++
 3 files changed, 67 insertions(+), 1 deletion(-)

diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs
index 9d279d6..82d3c37 100644
--- a/ghc/compiler/main/DynFlags.hs
+++ b/ghc/compiler/main/DynFlags.hs
@@ -115,6 +115,7 @@ data DynFlag
    | Opt_D_dump_hi
    | Opt_D_dump_hi_diffs
    | Opt_D_dump_minimal_imports
+   | Opt_D_faststring_stats
    | Opt_DoCoreLinting
    | Opt_DoStgLinting
    | Opt_DoCmmLinting
@@ -899,6 +900,7 @@ dynamic_flags = [
   ,  ( "dcmm-lint",		 NoArg (setDynFlag Opt_DoCmmLinting))
   ,  ( "dshow-passes",           NoArg (do unSetDynFlag Opt_RecompChecking
 				           setVerbosity "2") )
+  ,  ( "dfaststring-stats",	 NoArg (setDynFlag Opt_D_faststring_stats))
 
 	------ Machine dependant (-m<blah>) stuff ---------------------------
 
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 17eb526..8d6e30a 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -14,7 +14,7 @@ module Main (main) where
 -- The official GHC API
 import qualified GHC
 import GHC		( Session, DynFlags(..), GhcMode(..), HscTarget(..),
-			  LoadHowMuch(..) )
+			  LoadHowMuch(..), dopt, DynFlag(..) )
 import CmdLineParser
 
 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
@@ -34,6 +34,9 @@ import DriverPhases	( Phase(..), isSourceFilename, anyHsc,
 import StaticFlags	( staticFlags, v_Ld_inputs )
 import DynFlags         ( defaultDynFlags )
 import BasicTypes	( failed )
+import ErrUtils		( Message, debugTraceMsg, putMsg )
+import FastString	( getFastStringTable, isZEncoded, hasZEncoding )
+import Outputable
 import Util
 import Panic
 
@@ -148,6 +151,7 @@ main =
 	DoInteractive   -> interactiveUI session srcs Nothing
 	DoEval expr     -> interactiveUI session srcs (Just expr)
 
+  dumpFinalStats dflags
   exitWith ExitSuccess
 
 #ifndef GHCI
@@ -430,6 +434,41 @@ showGhcUsage cli_mode = do
      dump ('$':'$':s) = putStr progName >> dump s
      dump (c:s)	      = putChar c >> dump s
 
+dumpFinalStats :: DynFlags -> IO ()
+dumpFinalStats dflags = 
+  when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
+
+dumpFastStringStats :: DynFlags -> IO ()
+dumpFastStringStats dflags = do
+  buckets <- getFastStringTable
+  let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
+      msg = text "FastString stats:" $$
+	    nest 4 (vcat [text "size:           " <+> int (length buckets),
+			  text "entries:        " <+> int entries,
+			  text "longest chain:  " <+> int longest,
+			  text "z-encoded:      " <+> (is_z `pcntOf` entries),
+			  text "has z-encoding: " <+> (has_z `pcntOf` entries)
+			 ])
+	-- we usually get more "has z-encoding" than "z-encoded", because
+	-- when we z-encode a string it might hash to the exact same string,
+	-- which will is not counted as "z-encoded".  Only strings whose
+	-- Z-encoding is different from the original string are counted in
+	-- the "z-encoded" total.
+  putMsg dflags msg
+  where
+   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
+  
+countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
+countFS entries longest is_z has_z (b:bs) = 
+  let
+	len = length b
+	longest' = max len longest
+	entries' = entries + len
+	is_zs = length (filter isZEncoded b)
+	has_zs = length (filter hasZEncoding b)
+  in
+	countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs
+
 -- -----------------------------------------------------------------------------
 -- Util
 
diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 28aa6b0..4d432e6 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -51,6 +51,10 @@ module FastString
 	-- ** Outputing
         hPutFS,
 
+	-- ** Internal
+	getFastStringTable,
+	hasZEncoding,
+
 	-- * LitStrings
 	LitString, 
 	mkLitString#,
@@ -71,6 +75,7 @@ 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(..) )
@@ -343,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
@@ -415,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
-- 
1.7.10.4