1 {-# OPTIONS_GHC -fno-implicit-prelude #-}
3 -----------------------------------------------------------------------------
5 -- Module : Data.HashTable
6 -- Copyright : (c) The University of Glasgow 2003
7 -- License : BSD-style (see the file libraries/base/LICENSE)
9 -- Maintainer : libraries@haskell.org
10 -- Stability : provisional
11 -- Portability : portable
13 -- An implementation of extensible hash tables, as described in
14 -- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,
15 -- pp. 446--457. The implementation is also derived from the one
16 -- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).
18 -----------------------------------------------------------------------------
20 module Data.HashTable (
21 -- * Basic hash table operations
22 HashTable, new, insert, delete, lookup, update,
23 -- * Converting to and from lists
33 -- This module is imported by Data.Dynamic, which is pretty low down in the
34 -- module hierarchy, so don't import "high-level" modules
36 #ifdef __GLASGOW_HASKELL__
39 import Prelude hiding ( lookup )
41 import Data.Tuple ( fst )
44 import Data.List ( maximumBy, length, concat, foldl', partition )
45 import Data.Int ( Int32 )
47 #if defined(__GLASGOW_HASKELL__)
49 import GHC.Real ( fromIntegral )
50 import GHC.Show ( Show(..) )
51 import GHC.Int ( Int64 )
53 import GHC.IOBase ( IO, IOArray, newIOArray,
54 unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO,
55 IORef, newIORef, readIORef, writeIORef )
57 import Data.Char ( ord )
58 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
59 # if defined(__HUGS__)
60 import Hugs.IOArray ( IOArray, newIOArray,
61 unsafeReadIOArray, unsafeWriteIOArray )
62 # elif defined(__NHC__)
63 import NHC.IOExtras ( IOArray, newIOArray )
66 import Control.Monad ( mapM, mapM_, sequence_ )
69 -----------------------------------------------------------------------
74 -----------------------------------------------------------------------
76 readHTArray :: HTArray a -> Int32 -> IO a
77 writeMutArray :: MutArray a -> Int32 -> a -> IO ()
78 freezeArray :: MutArray a -> IO (HTArray a)
79 thawArray :: HTArray a -> IO (MutArray a)
80 newMutArray :: (Int32, Int32) -> a -> IO (MutArray a)
81 #if defined(DEBUG) || defined(__NHC__)
82 type MutArray a = IOArray Int32 a
83 type HTArray a = MutArray a
84 newMutArray = newArray
85 readHTArray = readArray
86 writeMutArray = writeArray
90 type MutArray a = IOArray Int32 a
91 type HTArray a = MutArray a -- Array Int32 a
92 newMutArray = newIOArray
93 readHTArray arr i = readMutArray arr i -- return $! (unsafeAt arr (fromIntegral i))
94 readMutArray :: MutArray a -> Int32 -> IO a
95 readMutArray arr i = unsafeReadIOArray arr (fromIntegral i)
96 writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x
97 freezeArray = return -- unsafeFreeze
98 thawArray = return -- unsafeThaw
101 data HashTable key val = HashTable {
102 cmp :: !(key -> key -> Bool),
103 hash_fn :: !(key -> Int32),
104 tab :: !(IORef (HT key val))
106 -- TODO: the IORef should really be an MVar.
110 kcount :: !Int32, -- Total number of keys.
112 buckets :: !(HTArray [(key,val)])
115 -- ------------------------------------------------------------
116 -- Instrumentation for performance tuning
118 -- This ought to be roundly ignored after optimization when
119 -- iNSTRUMENTED=False.
121 -- STRICT version of modifyIORef!
122 modifyIORef :: IORef a -> (a -> a) -> IO ()
125 let z = f v in z `seq` writeIORef r z
129 insertions :: !Integer,
131 totBuckets :: !Integer,
132 maxEntries :: !Int32,
135 } deriving (Eq, Show)
137 {-# NOINLINE hashData #-}
138 hashData :: IORef HashData
139 hashData = unsafePerformIO (newIORef (HD { tables=0, insertions=0, lookups=0,
140 totBuckets=0, maxEntries=0,
141 maxChain=0, maxBuckets=tABLE_MIN } ))
143 instrument :: (HashData -> HashData) -> IO ()
144 instrument i | iNSTRUMENTED = modifyIORef hashData i
145 | otherwise = return ()
148 recordNew = instrument rec
149 where rec hd@HD{ tables=t, totBuckets=b } =
150 hd{ tables=t+1, totBuckets=b+fromIntegral tABLE_MIN }
152 recordIns :: Int32 -> Int32 -> [a] -> IO ()
153 recordIns i sz bkt = instrument rec
154 where rec hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } =
155 hd{ insertions=ins+fromIntegral i, maxEntries=mx `max` sz,
156 maxChain=mc `max` length bkt }
158 recordResize :: Int32 -> Int32 -> IO ()
159 recordResize older newer = instrument rec
160 where rec hd@HD{ totBuckets=b, maxBuckets=mx } =
161 hd{ totBuckets=b+fromIntegral (newer-older),
162 maxBuckets=mx `max` newer }
164 recordLookup :: IO ()
165 recordLookup = instrument lkup
166 where lkup hd@HD{ lookups=l } = hd{ lookups=l+1 }
168 -- stats :: IO String
169 -- stats = fmap show $ readIORef hashData
171 -- -----------------------------------------------------------------------------
172 -- Sample hash functions
176 -- This implementation of hash tables uses the low-order /n/ bits of the hash
177 -- value for a key, where /n/ varies as the hash table grows. A good hash
178 -- function therefore will give an even distribution regardless of /n/.
180 -- If your keyspace is integrals such that the low-order bits between
181 -- keys are highly variable, then you could get away with using 'id'
182 -- as the hash function.
184 -- We provide some sample hash functions for 'Int' and 'String' below.
189 -- | A sample (and useful) hash function for Int and Int32,
190 -- implemented by extracting the uppermost 32 bits of the 64-bit
191 -- result of multiplying by a 32-bit constant. The constant is from
192 -- Knuth, derived from the golden ratio:
193 -- > golden = round ((sqrt 5 - 1) * 2^31) :: Int
194 hashInt :: Int -> Int32
195 hashInt x = mulHi (fromIntegral x) golden
197 -- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply
198 mulHi :: Int32 -> Int32 -> Int32
199 mulHi a b = fromIntegral (r `shiftR` 32)
201 r = fromIntegral a * fromIntegral b :: Int64
203 -- | A sample hash function for Strings. We keep multiplying by the
204 -- golden ratio and adding. The implementation is:
206 -- > hashString = foldl' f 0
207 -- > where f m c = fromIntegral (ord c) + mulHi m golden
209 -- Note that this has not been extensively tested for reasonability,
210 -- but Knuth argues that repeated multiplication by the golden ratio
211 -- will minimize gaps in the hash space.
212 hashString :: String -> Int32
213 hashString = foldl' f 0
214 where f m c = fromIntegral (ord c) + mulHi m golden
216 -- | A prime larger than the maximum hash table size
220 -- -----------------------------------------------------------------------------
224 tABLE_MAX = 32 * 1024 * 1024 -- Maximum size of hash table
229 hLOAD = 7 -- Maximum average load of a single hash bucket
232 hYSTERESIS = 64 -- entries to ignore in load computation
234 {- Hysteresis favors long association-list-like behavior for small tables. -}
236 -- -----------------------------------------------------------------------------
237 -- Creating a new hash table
239 -- | Creates a new hash table. The following property should hold for the @eq@
240 -- and @hash@ functions passed to 'new':
242 -- > eq A B => hash A == hash B
245 :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys
246 -> (key -> Int32) -- ^ @hash@: A hash function on keys
247 -> IO (HashTable key val) -- ^ Returns: an empty hash table
251 -- make a new hash table with a single, empty, segment
252 let mask = tABLE_MIN-1
253 bkts' <- newMutArray (0,mask) []
254 bkts <- freezeArray bkts'
258 ht = HT { buckets=bkts, kcount=kcnt, bmask=mask }
261 return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })
263 -- -----------------------------------------------------------------------------
264 -- Inserting a key\/value pair into the hash table
266 -- | Inserts a key\/value mapping into the hash table.
268 -- Note that 'insert' doesn't remove the old entry from the table -
269 -- the behaviour is like an association list, where 'lookup' returns
270 -- the most-recently-inserted mapping for a key in the table. The
271 -- reason for this is to keep 'insert' as efficient as possible. If
272 -- you need to update a mapping, then we provide 'update'.
274 insert :: HashTable key val -> key -> val -> IO ()
277 updatingBucket CanInsert (\bucket -> ((key,val):bucket, 1, ())) ht key
280 -- ------------------------------------------------------------
281 -- The core of the implementation is lurking down here, in findBucket,
282 -- updatingBucket, and expandHashTable.
284 tooBig :: Int32 -> Int32 -> Bool
285 tooBig k b = k-hYSTERESIS > hLOAD * b
287 -- index of bucket within table.
288 bucketIndex :: Int32 -> Int32 -> Int32
289 bucketIndex mask h = h .&. mask
291 -- find the bucket in which the key belongs.
292 -- returns (key equality, bucket index, bucket)
294 -- This rather grab-bag approach gives enough power to do pretty much
295 -- any bucket-finding thing you might want to do. We rely on inlining
296 -- to throw away the stuff we don't want. I'm proud to say that this
297 -- plus updatingBucket below reduce most of the other definitions to a
298 -- few lines of code, while actually speeding up the hashtable
299 -- implementation when compared with a version which does everything
301 {-# INLINE findBucket #-}
302 findBucket :: HashTable key val -> key -> IO (HT key val, Int32, [(key,val)])
303 findBucket HashTable{ tab=ref, hash_fn=hash} key = do
304 table@HT{ buckets=bkts, bmask=b } <- readIORef ref
305 let indx = bucketIndex b (hash key)
306 bucket <- readHTArray bkts indx
307 return (table, indx, bucket)
309 data Inserts = CanInsert
313 -- updatingBucket is the real workhorse of all single-element table
314 -- updates. It takes a hashtable and a key, along with a function
315 -- describing what to do with the bucket in which that key belongs. A
316 -- flag indicates whether this function may perform table insertions.
317 -- The function returns the new contents of the bucket, the number of
318 -- bucket entries inserted (negative if entries were deleted), and a
319 -- value which becomes the return value for the function as a whole.
320 -- The table sizing is enforced here, calling out to expandSubTable as
323 -- This function is intended to be inlined and specialized for every
324 -- calling context (eg every provided bucketFn).
325 {-# INLINE updatingBucket #-}
327 updatingBucket :: Inserts -> ([(key,val)] -> ([(key,val)], Int32, a)) ->
328 HashTable key val -> key ->
330 updatingBucket canEnlarge bucketFn
331 ht@HashTable{ tab=ref, hash_fn=hash } key = do
332 (table@HT{ kcount=k, buckets=bkts, bmask=b },
333 indx, bckt) <- findBucket ht key
334 (bckt', inserts, result) <- return $ bucketFn bckt
336 table1 = table { kcount=k' }
337 bkts' <- thawArray bkts
338 writeMutArray bkts' indx bckt'
340 table2 <- if canEnlarge == CanInsert && inserts > 0 then do
341 recordIns inserts k' bckt'
343 then expandHashTable hash table1
346 writeIORef ref table2
349 expandHashTable :: (key -> Int32) -> HT key val -> IO (HT key val)
350 expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do
353 newmask = mask + mask + 1
354 recordResize oldsize (newmask+1)
356 if newmask > tABLE_MAX-1
360 newbkts' <- newMutArray (0,newmask) []
363 splitBucket oldindex = do
364 bucket <- readHTArray bkts oldindex
366 partition ((oldindex==). bucketIndex newmask . hash . fst) bucket
367 writeMutArray newbkts' oldindex oldb
368 writeMutArray newbkts' (oldindex + oldsize) newb
369 mapM_ splitBucket [0..mask]
371 newbkts <- freezeArray newbkts'
373 return ( table{ buckets=newbkts, bmask=newmask } )
375 -- -----------------------------------------------------------------------------
376 -- Deleting a mapping from the hash table
378 -- Remove a key from a bucket
379 deleteBucket :: (key -> Bool) -> [(key,val)] -> ([(key, val)], Int32, ())
380 deleteBucket _ [] = ([],0,())
381 deleteBucket del (pair@(k,_):bucket) =
382 case deleteBucket del bucket of
383 (bucket', dels, _) | del k -> dels' `seq` (bucket', dels', ())
384 | otherwise -> (pair:bucket', dels, ())
385 where dels' = dels - 1
387 -- | Remove an entry from the hash table.
388 delete :: HashTable key val -> key -> IO ()
390 delete ht@HashTable{ cmp=eq } key =
391 updatingBucket Can'tInsert (deleteBucket (eq key)) ht key
393 -- -----------------------------------------------------------------------------
394 -- Updating a mapping in the hash table
396 -- | Updates an entry in the hash table, returning 'True' if there was
397 -- already an entry for this key, or 'False' otherwise. After 'update'
398 -- there will always be exactly one entry for the given key in the table.
400 -- 'insert' is more efficient than 'update' if you don't care about
401 -- multiple entries, or you know for sure that multiple entries can't
402 -- occur. However, 'update' is more efficient than 'delete' followed
404 update :: HashTable key val -> key -> val -> IO Bool
406 update ht@HashTable{ cmp=eq } key val =
407 updatingBucket CanInsert
408 (\bucket -> let (bucket', dels, _) = deleteBucket (eq key) bucket
409 in ((key,val):bucket', 1+dels, dels/=0))
412 -- -----------------------------------------------------------------------------
413 -- Looking up an entry in the hash table
415 -- | Looks up the value of a key in the hash table.
416 lookup :: HashTable key val -> key -> IO (Maybe val)
418 lookup ht@HashTable{ cmp=eq } key = do
420 (_, _, bucket) <- findBucket ht key
421 let firstHit (k,v) r | eq key k = Just v
423 return (foldr firstHit Nothing bucket)
425 -- -----------------------------------------------------------------------------
426 -- Converting to/from lists
428 -- | Convert a list of key\/value pairs into a hash table. Equality on keys
429 -- is taken from the Eq instance for the key type.
431 fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)
432 fromList hash list = do
433 table <- new (==) hash
434 sequence_ [ insert table k v | (k,v) <- list ]
437 -- | Converts a hash table to a list of key\/value pairs.
439 toList :: HashTable key val -> IO [(key,val)]
440 toList = mapReduce id concat
442 {-# INLINE mapReduce #-}
443 mapReduce :: ([(key,val)] -> r) -> ([r] -> r) -> HashTable key val -> IO r
444 mapReduce m r HashTable{ tab=ref } = do
445 HT{ buckets=bckts, bmask=b } <- readIORef ref
446 fmap r (mapM (fmap m . readHTArray bckts) [0..b])
448 -- -----------------------------------------------------------------------------
451 -- | This function is useful for determining whether your hash
452 -- function is working well for your data set. It returns the longest
453 -- chain of key\/value pairs in the hash table for which all the keys
454 -- hash to the same bucket. If this chain is particularly long (say,
455 -- longer than 14 elements or so), then it might be a good idea to try
456 -- a different hash function.
458 longestChain :: HashTable key val -> IO [(key,val)]
459 longestChain = mapReduce id (maximumBy lengthCmp)
460 where lengthCmp (_:x)(_:y) = lengthCmp x y