add GHC.HetMet.{hetmet_kappa,hetmet_kappa_app}

[ghc-base.git] / Data / HashTable.hs

diff --git a/Data/HashTable.hs b/Data/HashTable.hs
index ed0fb8f..e96160a 100644 (file)
--- a/Data/HashTable.hs
+++ b/Data/HashTable.hs
@@ -1,4 +1,5 @@
-{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-name-shadowing #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -19,7 +20,7 @@
 
 module Data.HashTable (
         -- * Basic hash table operations
-        HashTable, new, insert, delete, lookup, update,
+        HashTable, new, newHint, insert, delete, lookup, update,
         -- * Converting to and from lists
         fromList, toList,
         -- * Hash functions
@@ -50,9 +51,9 @@ import GHC.Real         ( fromIntegral )
 import GHC.Show         ( Show(..) )
 import GHC.Int          ( Int64 )
 
-import GHC.IOBase       ( IO, IOArray, newIOArray,
-                          unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO,
-                          IORef, newIORef, readIORef, writeIORef )
+import GHC.IO
+import GHC.IOArray
+import GHC.IORef
 #else
 import Data.Char        ( ord )
 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
@@ -77,27 +78,16 @@ iNSTRUMENTED = False
 
 readHTArray  :: HTArray a -> Int32 -> IO a
 writeMutArray :: MutArray a -> Int32 -> a -> IO ()
-freezeArray  :: MutArray a -> IO (HTArray a)
-thawArray    :: HTArray a -> IO (MutArray a)
 newMutArray   :: (Int32, Int32) -> a -> IO (MutArray a)
-#if defined(DEBUG) || defined(__NHC__)
+newMutArray = newIOArray
 type MutArray a = IOArray Int32 a
 type HTArray a = MutArray a
-newMutArray = newIOArray
+#if defined(DEBUG) || defined(__NHC__)
 readHTArray  = readIOArray
 writeMutArray = writeIOArray
-freezeArray = return
-thawArray = return
 #else
-type MutArray a = IOArray Int32 a
-type HTArray a = MutArray a -- Array Int32 a
-newMutArray = newIOArray
-readHTArray arr i = readMutArray arr i -- return $! (unsafeAt arr (fromIntegral i))
-readMutArray  :: MutArray a -> Int32 -> IO a
-readMutArray arr i = unsafeReadIOArray arr (fromIntegral i)
+readHTArray arr i = unsafeReadIOArray arr (fromIntegral i)
 writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x
-freezeArray = return -- unsafeFreeze
-thawArray = return -- unsafeThaw
 #endif
 
 data HashTable key val = HashTable {
@@ -285,8 +275,56 @@ new cmpr hash = do
   recordNew
   -- make a new hash table with a single, empty, segment
   let mask = tABLE_MIN-1
-  bkts'  <- newMutArray (0,mask) []
-  bkts   <- freezeArray bkts'
+  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
@@ -369,9 +407,7 @@ updatingBucket canEnlarge bucketFn
   (bckt', inserts, result) <- return $ bucketFn bckt
   let k' = k + inserts
       table1 = table { kcount=k' }
-  bkts' <- thawArray bkts
-  writeMutArray bkts' indx bckt'
-  freezeArray bkts'
+  writeMutArray bkts indx bckt'
   table2 <- if canEnlarge == CanInsert && inserts > 0 then do
                recordIns inserts k' bckt'
                if tooBig k' b
@@ -392,19 +428,17 @@ expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do
       then return table
       else do
    --
-    newbkts' <- newMutArray (0,newmask) []
+    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
+       writeMutArray newbkts oldindex oldb
+       writeMutArray newbkts (oldindex + oldsize) newb
     mapM_ splitBucket [0..mask]
 
-    newbkts <- freezeArray newbkts'
-
     return ( table{ buckets=newbkts, bmask=newmask } )
 
 -- -----------------------------------------------------------------------------