Add a copy of HashTable to keep hash GC benchmark working.
authorEdward Z. Yang <ezyang@mit.edu>
Wed, 2 Oct 2013 23:50:34 +0000 (16:50 -0700)
committerEdward Z. Yang <ezyang@mit.edu>
Wed, 2 Oct 2013 23:53:02 +0000 (16:53 -0700)
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
gc/hash/HashTable.hs [new file with mode: 0644]
gc/hash/hash.hs

diff --git a/gc/hash/HashTable.hs b/gc/hash/HashTable.hs
new file mode 100644 (file)
index 0000000..84fc85c
--- /dev/null
@@ -0,0 +1,529 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-name-shadowing #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HashTable
+-- Copyright   :  (c) The University of Glasgow 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- An implementation of extensible hash tables, as described in
+-- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,
+-- pp. 446--457.  The implementation is also derived from the one
+-- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).
+--
+-- This used to be Data.HashTable, but the module has been removed.
+-- It's been copied to nofib to let us still do GC benchmarking with it.
+--
+-----------------------------------------------------------------------------
+
+module HashTable
+      (
+        -- * Basic hash table operations
+        HashTable, new, newHint, insert, delete, lookup, update,
+        -- * Converting to and from lists
+        fromList, toList,
+        -- * Hash functions
+        -- $hash_functions
+        hashInt, hashString,
+        prime,
+        -- * Diagnostics
+        longestChain
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+#else
+import Prelude  hiding  ( lookup )
+#endif
+import Data.Tuple       ( fst )
+import Data.Bits
+import Data.Maybe
+import Data.List        ( maximumBy, length, concat, foldl', partition )
+import Data.Int         ( Int32 )
+
+#if defined(__GLASGOW_HASKELL__)
+import GHC.Num
+import GHC.Real         ( fromIntegral )
+import GHC.Show         ( Show(..) )
+import GHC.Int          ( Int64 )
+
+import GHC.IO
+import GHC.IOArray
+import GHC.IORef
+#else
+import Data.Char        ( ord )
+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
+import System.IO.Unsafe ( unsafePerformIO )
+import Data.Int         ( Int64 )
+#endif
+import Control.Monad    ( mapM, mapM_, sequence_ )
+
+
+-----------------------------------------------------------------------
+
+iNSTRUMENTED :: Bool
+iNSTRUMENTED = False
+
+-----------------------------------------------------------------------
+
+readHTArray  :: HTArray a -> Int32 -> IO a
+writeMutArray :: MutArray a -> Int32 -> a -> IO ()
+newMutArray   :: (Int32, Int32) -> a -> IO (MutArray a)
+newMutArray = newIOArray
+type MutArray a = IOArray Int32 a
+type HTArray a = MutArray a
+#if defined(DEBUG) || defined(__NHC__)
+readHTArray  = readIOArray
+writeMutArray = writeIOArray
+#else
+readHTArray arr i = unsafeReadIOArray arr (fromIntegral i)
+writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x
+#endif
+
+data HashTable key val = HashTable {
+                                     cmp     :: !(key -> key -> Bool),
+                                     hash_fn :: !(key -> Int32),
+                                     tab     :: !(IORef (HT key val))
+                                   }
+-- TODO: the IORef should really be an MVar.
+
+data HT key val
+  = HT {
+        kcount  :: !Int32,              -- Total number of keys.
+        bmask   :: !Int32,
+        buckets :: !(HTArray [(key,val)])
+       }
+
+-- ------------------------------------------------------------
+-- Instrumentation for performance tuning
+
+-- This ought to be roundly ignored after optimization when
+-- iNSTRUMENTED=False.
+
+-- STRICT version of modifyIORef!
+modifyIORef :: IORef a -> (a -> a) -> IO ()
+modifyIORef r f = do
+  v <- readIORef r
+  let z = f v in z `seq` writeIORef r z
+
+data HashData = HD {
+  tables :: !Integer,
+  insertions :: !Integer,
+  lookups :: !Integer,
+  totBuckets :: !Integer,
+  maxEntries :: !Int32,
+  maxChain :: !Int,
+  maxBuckets :: !Int32
+} deriving (Eq, Show)
+
+{-# NOINLINE hashData #-}
+hashData :: IORef HashData
+hashData =  unsafePerformIO (newIORef (HD { tables=0, insertions=0, lookups=0,
+                                            totBuckets=0, maxEntries=0,
+                                            maxChain=0, maxBuckets=tABLE_MIN } ))
+
+instrument :: (HashData -> HashData) -> IO ()
+instrument i | iNSTRUMENTED = modifyIORef hashData i
+             | otherwise    = return ()
+
+recordNew :: IO ()
+recordNew = instrument rec
+  where rec hd@HD{ tables=t, totBuckets=b } =
+               hd{ tables=t+1, totBuckets=b+fromIntegral tABLE_MIN }
+
+recordIns :: Int32 -> Int32 -> [a] -> IO ()
+recordIns i sz bkt = instrument rec
+  where rec hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } =
+               hd{ insertions=ins+fromIntegral i, maxEntries=mx `max` sz,
+                   maxChain=mc `max` length bkt }
+
+recordResize :: Int32 -> Int32 -> IO ()
+recordResize older newer = instrument rec
+  where rec hd@HD{ totBuckets=b, maxBuckets=mx } =
+               hd{ totBuckets=b+fromIntegral (newer-older),
+                   maxBuckets=mx `max` newer }
+
+recordLookup :: IO ()
+recordLookup = instrument lkup
+  where lkup hd@HD{ lookups=l } = hd{ lookups=l+1 }
+
+-- stats :: IO String
+-- stats =  fmap show $ readIORef hashData
+
+-- ----------------------------------------------------------------------------
+-- Sample hash functions
+
+-- $hash_functions
+--
+-- This implementation of hash tables uses the low-order /n/ bits of the hash
+-- value for a key, where /n/ varies as the hash table grows.  A good hash
+-- function therefore will give an even distribution regardless of /n/.
+--
+-- If your keyspace is integrals such that the low-order bits between
+-- keys are highly variable, then you could get away with using 'fromIntegral'
+-- as the hash function.
+--
+-- We provide some sample hash functions for 'Int' and 'String' below.
+
+golden :: Int32
+golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32
+-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32
+-- but that has bad mulHi properties (even adding 2^32 to get its inverse)
+-- Whereas the above works well and contains no hash duplications for
+-- [-32767..65536]
+
+hashInt32 :: Int32 -> Int32
+hashInt32 x = mulHi x golden + x
+
+-- | A sample (and useful) hash function for Int and Int32,
+-- implemented by extracting the uppermost 32 bits of the 64-bit
+-- result of multiplying by a 33-bit constant.  The constant is from
+-- Knuth, derived from the golden ratio:
+--
+-- > golden = round ((sqrt 5 - 1) * 2^32)
+--
+-- We get good key uniqueness on small inputs
+-- (a problem with previous versions):
+--  (length $ group $ sort $ map hashInt [-32767..65536]) == 65536 + 32768
+--
+hashInt :: Int -> Int32
+hashInt x = hashInt32 (fromIntegral x)
+
+-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply
+mulHi :: Int32 -> Int32 -> Int32
+mulHi a b = fromIntegral (r `shiftR` 32)
+   where r :: Int64
+         r = fromIntegral a * fromIntegral b
+
+-- | A sample hash function for Strings.  We keep multiplying by the
+-- golden ratio and adding.  The implementation is:
+--
+-- > hashString = foldl' f golden
+-- >   where f m c = fromIntegral (ord c) * magic + hashInt32 m
+-- >         magic = 0xdeadbeef
+--
+-- Where hashInt32 works just as hashInt shown above.
+--
+-- Knuth argues that repeated multiplication by the golden ratio
+-- will minimize gaps in the hash space, and thus it's a good choice
+-- for combining together multiple keys to form one.
+--
+-- Here we know that individual characters c are often small, and this
+-- produces frequent collisions if we use ord c alone.  A
+-- particular problem are the shorter low ASCII and ISO-8859-1
+-- character strings.  We pre-multiply by a magic twiddle factor to
+-- obtain a good distribution.  In fact, given the following test:
+--
+-- > testp :: Int32 -> Int
+-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls
+-- >   where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]
+-- >         hs = foldl' f golden
+-- >         f m c = fromIntegral (ord c) * k + hashInt32 m
+-- >         n = 100000
+--
+-- We discover that testp magic = 0.
+
+hashString :: String -> Int32
+hashString = foldl' f golden
+   where f m c = fromIntegral (ord c) * magic + hashInt32 m
+         magic = 0xdeadbeef
+
+-- | A prime larger than the maximum hash table size
+prime :: Int32
+prime = 33554467
+
+-- -----------------------------------------------------------------------------
+-- Parameters
+
+tABLE_MAX :: Int32
+tABLE_MAX  = 32 * 1024 * 1024   -- Maximum size of hash table
+tABLE_MIN :: Int32
+tABLE_MIN  = 8
+
+hLOAD :: Int32
+hLOAD = 7                       -- Maximum average load of a single hash bucket
+
+hYSTERESIS :: Int32
+hYSTERESIS = 64                 -- entries to ignore in load computation
+
+{- Hysteresis favors long association-list-like behavior for small tables. -}
+
+-- -----------------------------------------------------------------------------
+-- Creating a new hash table
+
+-- | Creates a new hash table.  The following property should hold for the @eq@
+-- and @hash@ functions passed to 'new':
+--
+-- >   eq A B  =>  hash A == hash B
+--
+new
+  :: (key -> key -> Bool)    -- ^ @eq@: An equality comparison on keys
+  -> (key -> Int32)          -- ^ @hash@: A hash function on keys
+  -> IO (HashTable key val)  -- ^ Returns: an empty hash table
+
+new cmpr hash = do
+  recordNew
+  -- make a new hash table with a single, empty, segment
+  let mask = tABLE_MIN-1
+  bkts <- newMutArray (0,mask) []
+
+  let
+    kcnt = 0
+    ht = HT {  buckets=bkts, kcount=kcnt, bmask=mask }
+
+  table <- newIORef ht
+  return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })
+
+{- 
+   bitTwiddleSameAs takes as arguments positive Int32s less than maxBound/2 and 
+   returns the smallest power of 2 that is greater than or equal to the 
+   argument.
+   http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2
+-}
+bitTwiddleSameAs :: Int32 -> Int32
+bitTwiddleSameAs v0 = 
+    let v1 = v0-1
+        v2 = v1 .|. (v1`shiftR`1)
+        v3 = v2 .|. (v2`shiftR`2)
+        v4 = v3 .|. (v3`shiftR`4)
+        v5 = v4 .|. (v4`shiftR`8)
+        v6 = v5 .|. (v5`shiftR`16)
+    in v6+1
+
+{-
+  powerOver takes as arguments Int32s and returns the smallest power of 2 
+  that is greater than or equal to the argument if that power of 2 is 
+  within [tABLE_MIN,tABLE_MAX]
+-}
+powerOver :: Int32 -> Int32
+powerOver n = 
+    if n <= tABLE_MIN
+    then tABLE_MIN
+    else if n >= tABLE_MAX
+         then tABLE_MAX
+         else bitTwiddleSameAs n 
+
+-- | Creates a new hash table with the given minimum size.
+newHint
+  :: (key -> key -> Bool)    -- ^ @eq@: An equality comparison on keys
+  -> (key -> Int32)          -- ^ @hash@: A hash function on keys
+  -> Int                     -- ^ @minSize@: initial table size
+  -> IO (HashTable key val)  -- ^ Returns: an empty hash table
+
+newHint cmpr hash minSize = do
+  recordNew
+  -- make a new hash table with a single, empty, segment
+  let mask = powerOver $ fromIntegral minSize
+  bkts <- newMutArray (0,mask) []
+
+  let
+    kcnt = 0
+    ht = HT {  buckets=bkts, kcount=kcnt, bmask=mask }
+
+  table <- newIORef ht
+  return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })
+
+-- -----------------------------------------------------------------------------
+-- Inserting a key\/value pair into the hash table
+
+-- | Inserts a key\/value mapping into the hash table.
+--
+-- Note that 'insert' doesn't remove the old entry from the table -
+-- the behaviour is like an association list, where 'lookup' returns
+-- the most-recently-inserted mapping for a key in the table.  The
+-- reason for this is to keep 'insert' as efficient as possible.  If
+-- you need to update a mapping, then we provide 'update'.
+--
+insert :: HashTable key val -> key -> val -> IO ()
+
+insert ht key val =
+  updatingBucket CanInsert (\bucket -> ((key,val):bucket, 1, ())) ht key
+
+
+-- ------------------------------------------------------------
+-- The core of the implementation is lurking down here, in findBucket,
+-- updatingBucket, and expandHashTable.
+
+tooBig :: Int32 -> Int32 -> Bool
+tooBig k b = k-hYSTERESIS > hLOAD * b
+
+-- index of bucket within table.
+bucketIndex :: Int32 -> Int32 -> Int32
+bucketIndex mask h = h .&. mask
+
+-- find the bucket in which the key belongs.
+-- returns (key equality, bucket index, bucket)
+--
+-- This rather grab-bag approach gives enough power to do pretty much
+-- any bucket-finding thing you might want to do.  We rely on inlining
+-- to throw away the stuff we don't want.  I'm proud to say that this
+-- plus updatingBucket below reduce most of the other definitions to a
+-- few lines of code, while actually speeding up the hashtable
+-- implementation when compared with a version which does everything
+-- from scratch.
+{-# INLINE findBucket #-}
+findBucket :: HashTable key val -> key -> IO (HT key val, Int32, [(key,val)])
+findBucket HashTable{ tab=ref, hash_fn=hash} key = do
+  table@HT{ buckets=bkts, bmask=b } <- readIORef ref
+  let indx = bucketIndex b (hash key)
+  bucket <- readHTArray bkts indx
+  return (table, indx, bucket)
+
+data Inserts = CanInsert
+             | Can'tInsert
+             deriving (Eq)
+
+-- updatingBucket is the real workhorse of all single-element table
+-- updates.  It takes a hashtable and a key, along with a function
+-- describing what to do with the bucket in which that key belongs.  A
+-- flag indicates whether this function may perform table insertions.
+-- The function returns the new contents of the bucket, the number of
+-- bucket entries inserted (negative if entries were deleted), and a
+-- value which becomes the return value for the function as a whole.
+-- The table sizing is enforced here, calling out to expandSubTable as
+-- necessary.
+
+-- This function is intended to be inlined and specialized for every
+-- calling context (eg every provided bucketFn).
+{-# INLINE updatingBucket #-}
+
+updatingBucket :: Inserts -> ([(key,val)] -> ([(key,val)], Int32, a)) ->
+                  HashTable key val -> key ->
+                  IO a
+updatingBucket canEnlarge bucketFn
+               ht@HashTable{ tab=ref, hash_fn=hash } key = do
+  (table@HT{ kcount=k, buckets=bkts, bmask=b },
+   indx, bckt) <- findBucket ht key
+  (bckt', inserts, result) <- return $ bucketFn bckt
+  let k' = k + inserts
+      table1 = table { kcount=k' }
+  writeMutArray bkts indx bckt'
+  table2 <- if canEnlarge == CanInsert && inserts > 0 then do
+               recordIns inserts k' bckt'
+               if tooBig k' b
+                  then expandHashTable hash table1
+                  else return table1
+            else return table1
+  writeIORef ref table2
+  return result
+
+expandHashTable :: (key -> Int32) -> HT key val -> IO (HT key val)
+expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do
+   let
+      oldsize = mask + 1
+      newmask = mask + mask + 1
+   recordResize oldsize (newmask+1)
+   --
+   if newmask > tABLE_MAX-1
+      then return table
+      else do
+   --
+    newbkts <- newMutArray (0,newmask) []
+
+    let
+     splitBucket oldindex = do
+       bucket <- readHTArray bkts oldindex
+       let (oldb,newb) =
+              partition ((oldindex==). bucketIndex newmask . hash . fst) bucket
+       writeMutArray newbkts oldindex oldb
+       writeMutArray newbkts (oldindex + oldsize) newb
+    mapM_ splitBucket [0..mask]
+
+    return ( table{ buckets=newbkts, bmask=newmask } )
+
+-- -----------------------------------------------------------------------------
+-- Deleting a mapping from the hash table
+
+-- Remove a key from a bucket
+deleteBucket :: (key -> Bool) -> [(key,val)] -> ([(key, val)], Int32, ())
+deleteBucket _   [] = ([],0,())
+deleteBucket del (pair@(k,_):bucket) =
+  case deleteBucket del bucket of
+    (bucket', dels, _) | del k     -> dels' `seq` (bucket', dels', ())
+                       | otherwise -> (pair:bucket', dels, ())
+      where dels' = dels - 1
+
+-- | Remove an entry from the hash table.
+delete :: HashTable key val -> key -> IO ()
+
+delete ht@HashTable{ cmp=eq } key =
+  updatingBucket Can'tInsert (deleteBucket (eq key)) ht key
+
+-- -----------------------------------------------------------------------------
+-- Updating a mapping in the hash table
+
+-- | Updates an entry in the hash table, returning 'True' if there was
+-- already an entry for this key, or 'False' otherwise.  After 'update'
+-- there will always be exactly one entry for the given key in the table.
+--
+-- 'insert' is more efficient than 'update' if you don't care about
+-- multiple entries, or you know for sure that multiple entries can't
+-- occur.  However, 'update' is more efficient than 'delete' followed
+-- by 'insert'.
+update :: HashTable key val -> key -> val -> IO Bool
+
+update ht@HashTable{ cmp=eq } key val =
+  updatingBucket CanInsert
+    (\bucket -> let (bucket', dels, _) = deleteBucket (eq key) bucket
+                in  ((key,val):bucket', 1+dels, dels/=0))
+    ht key
+
+-- -----------------------------------------------------------------------------
+-- Looking up an entry in the hash table
+
+-- | Looks up the value of a key in the hash table.
+lookup :: HashTable key val -> key -> IO (Maybe val)
+
+lookup ht@HashTable{ cmp=eq } key = do
+  recordLookup
+  (_, _, bucket) <- findBucket ht key
+  let firstHit (k,v) r | eq key k  = Just v
+                       | otherwise = r
+  return (foldr firstHit Nothing bucket)
+
+-- -----------------------------------------------------------------------------
+-- Converting to/from lists
+
+-- | Convert a list of key\/value pairs into a hash table.  Equality on keys
+-- is taken from the Eq instance for the key type.
+--
+fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)
+fromList hash list = do
+  table <- new (==) hash
+  sequence_ [ insert table k v | (k,v) <- list ]
+  return table
+
+-- | Converts a hash table to a list of key\/value pairs.
+--
+toList :: HashTable key val -> IO [(key,val)]
+toList = mapReduce id concat
+
+{-# INLINE mapReduce #-}
+mapReduce :: ([(key,val)] -> r) -> ([r] -> r) -> HashTable key val -> IO r
+mapReduce m r HashTable{ tab=ref } = do
+  HT{ buckets=bckts, bmask=b } <- readIORef ref
+  fmap r (mapM (fmap m . readHTArray bckts) [0..b])
+
+-- -----------------------------------------------------------------------------
+-- Diagnostics
+
+-- | This function is useful for determining whether your hash
+-- function is working well for your data set.  It returns the longest
+-- chain of key\/value pairs in the hash table for which all the keys
+-- hash to the same bucket.  If this chain is particularly long (say,
+-- longer than 14 elements or so), then it might be a good idea to try
+-- a different hash function.
+--
+longestChain :: HashTable key val -> IO [(key,val)]
+longestChain = mapReduce id (maximumBy lengthCmp)
+  where lengthCmp (_:x)(_:y) = lengthCmp x y
+        lengthCmp []   []    = EQ
+        lengthCmp []   _     = LT
+        lengthCmp _    []    = GT
+
index a15848d..88d8f02 100644 (file)
@@ -1,5 +1,5 @@
 import Control.Monad
-import qualified Data.HashTable as H
+import qualified HashTable as H
 import System.Environment
 
 main = do