Remove some deprecated modules and functions
authorIan Lynagh <igloo@earth.li>
Fri, 20 Jul 2012 15:57:06 +0000 (16:57 +0100)
committerIan Lynagh <igloo@earth.li>
Fri, 20 Jul 2012 16:55:14 +0000 (17:55 +0100)
Control/Concurrent.hs
Control/Concurrent/QSem.hs [deleted file]
Control/Concurrent/QSemN.hs [deleted file]
Control/Concurrent/SampleVar.hs [deleted file]
Data/HashTable.hs [deleted file]
base.cabal

index 0f3bb5d..fa7fc4d 100644 (file)
@@ -72,16 +72,6 @@ module Control.Concurrent (
 
         module Control.Concurrent.MVar,
         module Control.Concurrent.Chan,
-        module Control.Concurrent.QSem,
-        module Control.Concurrent.QSemN,
-        module Control.Concurrent.SampleVar,
-
-        -- * Merging of streams
-#ifndef __HUGS__
-        mergeIO,                -- :: [a]   -> [a] -> IO [a]
-        nmergeIO,               -- :: [[a]] -> IO [a]
-#endif
-        -- $merge
 
 #ifdef __GLASGOW_HASKELL__
         -- * Bound Threads
@@ -147,9 +137,6 @@ import Hugs.ConcBase
 
 import Control.Concurrent.MVar
 import Control.Concurrent.Chan
-import Control.Concurrent.QSem
-import Control.Concurrent.QSemN
-import Control.Concurrent.SampleVar
 
 #ifdef __HUGS__
 type ThreadId = ()
@@ -225,85 +212,6 @@ forkFinally action and_then =
   mask $ \restore ->
     forkIO $ try (restore action) >>= and_then
 
--- -----------------------------------------------------------------------------
--- Merging streams
-
-#ifndef __HUGS__
-max_buff_size :: Int
-max_buff_size = 1
-
-{-# DEPRECATED mergeIO "Control.Concurrent.mergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}
-{-# DEPRECATED nmergeIO "Control.Concurrent.nmergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}
-mergeIO :: [a] -> [a] -> IO [a]
-nmergeIO :: [[a]] -> IO [a]
-
--- $merge
--- The 'mergeIO' and 'nmergeIO' functions fork one thread for each
--- input list that concurrently evaluates that list; the results are
--- merged into a single output list.  
---
--- Note: Hugs does not provide these functions, since they require
--- preemptive multitasking.
-
-mergeIO ls rs
- = newEmptyMVar                >>= \ tail_node ->
-   newMVar tail_node           >>= \ tail_list ->
-   newQSem max_buff_size       >>= \ e ->
-   newMVar 2                   >>= \ branches_running ->
-   let
-    buff = (tail_list,e)
-   in
-    forkIO (suckIO branches_running buff ls) >>
-    forkIO (suckIO branches_running buff rs) >>
-    takeMVar tail_node  >>= \ val ->
-    signalQSem e        >>
-    return val
-
-type Buffer a
- = (MVar (MVar [a]), QSem)
-
-suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
-
-suckIO branches_running buff@(tail_list,e) vs
- = case vs of
-        [] -> takeMVar branches_running >>= \ val ->
-              if val == 1 then
-                 takeMVar tail_list     >>= \ node ->
-                 putMVar node []        >>
-                 putMVar tail_list node
-              else
-                 putMVar branches_running (val-1)
-        (x:xs) ->
-                waitQSem e                       >>
-                takeMVar tail_list               >>= \ node ->
-                newEmptyMVar                     >>= \ next_node ->
-                unsafeInterleaveIO (
-                        takeMVar next_node  >>= \ y ->
-                        signalQSem e        >>
-                        return y)                >>= \ next_node_val ->
-                putMVar node (x:next_node_val)   >>
-                putMVar tail_list next_node      >>
-                suckIO branches_running buff xs
-
-nmergeIO lss
- = let
-    len = length lss
-   in
-    newEmptyMVar          >>= \ tail_node ->
-    newMVar tail_node     >>= \ tail_list ->
-    newQSem max_buff_size >>= \ e ->
-    newMVar len           >>= \ branches_running ->
-    let
-     buff = (tail_list,e)
-    in
-    mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
-    takeMVar tail_node  >>= \ val ->
-    signalQSem e        >>
-    return val
-  where
-    mapIO f xs = sequence (map f xs)
-#endif /* __HUGS__ */
-
 #ifdef __GLASGOW_HASKELL__
 -- ---------------------------------------------------------------------------
 -- Bound Threads
diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs
deleted file mode 100644 (file)
index 2fd2ad6..0000000
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP #-}
-#ifdef __GLASGOW_HASKELL__
-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-#endif
-
------------------------------------------------------------------------------
--- |
--- Module      :  Control.Concurrent.QSem
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file libraries/base/LICENSE)
--- 
--- Maintainer  :  libraries@haskell.org
--- Stability   :  experimental
--- Portability :  non-portable (concurrency)
---
--- Simple quantity semaphores.
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.QSem
-        {-# DEPRECATED "Control.Concurrent.QSem will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}
-        ( -- * Simple Quantity Semaphores
-          QSem,         -- abstract
-          newQSem,      -- :: Int  -> IO QSem
-          waitQSem,     -- :: QSem -> IO ()
-          signalQSem    -- :: QSem -> IO ()
-        ) where
-
-import Prelude
-import Control.Concurrent.MVar
-import Control.Exception ( mask_ )
-import Data.Typeable
-
-#include "Typeable.h"
-
--- General semaphores are also implemented readily in terms of shared
--- @MVar@s, only have to catch the case when the semaphore is tried
--- waited on when it is empty (==0). Implement this in the same way as
--- shared variables are implemented - maintaining a list of @MVar@s
--- representing threads currently waiting. The counter is a shared
--- variable, ensuring the mutual exclusion on its access.
-
--- |A 'QSem' is a simple quantity semaphore, in which the available
--- \"quantity\" is always dealt with in units of one.
-newtype QSem = QSem (MVar (Int, [MVar ()])) deriving Eq
-
-INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
-
--- |Build a new 'QSem' with a supplied initial quantity.
---  The initial quantity must be at least 0.
-newQSem :: Int -> IO QSem
-newQSem initial =
-    if initial < 0
-    then fail "newQSem: Initial quantity must be non-negative"
-    else do sem <- newMVar (initial, [])
-            return (QSem sem)
-
--- |Wait for a unit to become available
-waitQSem :: QSem -> IO ()
-waitQSem (QSem sem) = mask_ $ do
-   (avail,blocked) <- takeMVar sem  -- gain ex. access
-   if avail > 0 then
-     let avail' = avail-1
-     in avail' `seq` putMVar sem (avail',[])
-    else do
-     b <- newEmptyMVar
-      {-
-        Stuff the reader at the back of the queue,
-        so as to preserve waiting order. A signalling
-        process then only have to pick the MVar at the
-        front of the blocked list.
-
-        The version of waitQSem given in the paper could
-        lead to starvation.
-      -}
-     putMVar sem (0, blocked++[b])
-     takeMVar b
-
--- |Signal that a unit of the 'QSem' is available
-signalQSem :: QSem -> IO ()
-signalQSem (QSem sem) = mask_ $ do
-   (avail,blocked) <- takeMVar sem
-   case blocked of
-     [] -> let avail' = avail+1
-           in avail' `seq` putMVar sem (avail',blocked)
-
-     (b:blocked') -> do
-           putMVar sem (0,blocked')
-           putMVar b ()
diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs
deleted file mode 100644 (file)
index 9126365..0000000
+++ /dev/null
@@ -1,82 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP #-}
-#ifdef __GLASGOW_HASKELL__
-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-#endif
-
------------------------------------------------------------------------------
--- |
--- Module      :  Control.Concurrent.QSemN
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file libraries/base/LICENSE)
--- 
--- Maintainer  :  libraries@haskell.org
--- Stability   :  experimental
--- Portability :  non-portable (concurrency)
---
--- Quantity semaphores in which each thread may wait for an arbitrary
--- \"amount\".
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.QSemN
-        {-# DEPRECATED "Control.Concurrent.QSemN will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}
-        (  -- * General Quantity Semaphores
-          QSemN,        -- abstract
-          newQSemN,     -- :: Int   -> IO QSemN
-          waitQSemN,    -- :: QSemN -> Int -> IO ()
-          signalQSemN   -- :: QSemN -> Int -> IO ()
-      ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-import Control.Exception ( mask_ )
-import Data.Typeable
-
-#include "Typeable.h"
-
--- |A 'QSemN' is a quantity semaphore, in which the available
--- \"quantity\" may be signalled or waited for in arbitrary amounts.
-newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())])) deriving Eq
-
-INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")
-
--- |Build a new 'QSemN' with a supplied initial quantity.
---  The initial quantity must be at least 0.
-newQSemN :: Int -> IO QSemN
-newQSemN initial =
-    if initial < 0
-    then fail "newQSemN: Initial quantity must be non-negative"
-    else do sem <- newMVar (initial, [])
-            return (QSemN sem)
-
--- |Wait for the specified quantity to become available
-waitQSemN :: QSemN -> Int -> IO ()
-waitQSemN (QSemN sem) sz = mask_ $ do
-  (avail,blocked) <- takeMVar sem   -- gain ex. access
-  let remaining = avail - sz
-  if remaining >= 0 then
-       -- discharging 'sz' still leaves the semaphore
-       -- in an 'unblocked' state.
-     putMVar sem (remaining,blocked)
-   else do
-     b <- newEmptyMVar
-     putMVar sem (avail, blocked++[(sz,b)])
-     takeMVar b
-
--- |Signal that a given quantity is now available from the 'QSemN'.
-signalQSemN :: QSemN -> Int  -> IO ()
-signalQSemN (QSemN sem) n = mask_ $ do
-   (avail,blocked)   <- takeMVar sem
-   (avail',blocked') <- free (avail+n) blocked
-   avail' `seq` putMVar sem (avail',blocked')
- where
-   free avail []    = return (avail,[])
-   free avail ((req,b):blocked)
-     | avail >= req = do
-        putMVar b ()
-        free (avail-req) blocked
-     | otherwise    = do
-        (avail',blocked') <- free avail blocked
-        return (avail',(req,b):blocked')
diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs
deleted file mode 100644 (file)
index e3852fa..0000000
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP #-}
-#ifdef __GLASGOW_HASKELL__
-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-#endif
-
------------------------------------------------------------------------------
--- |
--- Module      :  Control.Concurrent.SampleVar
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file libraries/base/LICENSE)
--- 
--- Maintainer  :  libraries@haskell.org
--- Stability   :  experimental
--- Portability :  non-portable (concurrency)
---
--- Sample variables
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.SampleVar
-        {-# DEPRECATED "Control.Concurrent.SampleVar will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}
-       (
-         -- * Sample Variables
-         SampleVar,         -- :: type _ =
-         newEmptySampleVar, -- :: IO (SampleVar a)
-         newSampleVar,      -- :: a -> IO (SampleVar a)
-         emptySampleVar,    -- :: SampleVar a -> IO ()
-         readSampleVar,     -- :: SampleVar a -> IO a
-         writeSampleVar,    -- :: SampleVar a -> a -> IO ()
-         isEmptySampleVar,  -- :: SampleVar a -> IO Bool
-
-       ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-
-import Control.Exception ( mask_ )
-
-import Data.Functor ( (<$>) )
-
-import Data.Typeable
-
-#include "Typeable.h"
-
--- |
--- Sample variables are slightly different from a normal 'MVar':
--- 
---  * Reading an empty 'SampleVar' causes the reader to block.
---    (same as 'takeMVar' on empty 'MVar')
--- 
---  * Reading a filled 'SampleVar' empties it and returns value.
---    (same as 'takeMVar')
--- 
---  * Writing to an empty 'SampleVar' fills it with a value, and
---    potentially, wakes up a blocked reader (same as for 'putMVar' on
---    empty 'MVar').
---
---  * Writing to a filled 'SampleVar' overwrites the current value.
---    (different from 'putMVar' on full 'MVar'.)
-
-newtype SampleVar a = SampleVar ( MVar ( Int    -- 1  == full
-                                                -- 0  == empty
-                                                -- <0 no of readers blocked
-                                       , MVar a
-                                       )
-                                )
-    deriving (Eq)
-
-INSTANCE_TYPEABLE1(SampleVar,sampleVarTc,"SampleVar")
-
--- |Build a new, empty, 'SampleVar'
-newEmptySampleVar :: IO (SampleVar a)
-newEmptySampleVar = do
-   v <- newEmptyMVar
-   SampleVar <$> newMVar (0,v)
-
--- |Build a 'SampleVar' with an initial value.
-newSampleVar :: a -> IO (SampleVar a)
-newSampleVar a = do
-   v <- newMVar a
-   SampleVar <$> newMVar (1,v)
-
--- |If the SampleVar is full, leave it empty.  Otherwise, do nothing.
-emptySampleVar :: SampleVar a -> IO ()
-emptySampleVar (SampleVar v) = mask_ $ do
-   s@(readers, var) <- takeMVar v
-   if readers > 0 then do
-     _ <- takeMVar var
-     putMVar v (0,var)
-    else
-     putMVar v s
-
--- |Wait for a value to become available, then take it and return.
-readSampleVar :: SampleVar a -> IO a
-readSampleVar (SampleVar svar) = mask_ $ do
---
--- filled => make empty and grab sample
--- not filled => try to grab value, empty when read val.
---
-   (readers,val) <- takeMVar svar
-   let readers' = readers-1
-   readers' `seq` putMVar svar (readers',val)
-   takeMVar val
-
--- |Write a value into the 'SampleVar', overwriting any previous value that
--- was there.
-writeSampleVar :: SampleVar a -> a -> IO ()
-writeSampleVar (SampleVar svar) v = mask_ $ do
---
--- filled => overwrite
--- not filled => fill, write val
---
-   s@(readers,val) <- takeMVar svar
-   case readers of
-     1 ->
-       swapMVar val v >>
-       putMVar svar s
-     _ ->
-       putMVar val v >>
-       let readers' = min 1 (readers+1)
-       in readers' `seq` putMVar svar (readers', val)
-
--- | Returns 'True' if the 'SampleVar' is currently empty.
---
--- Note that this function is only useful if you know that no other
--- threads can be modifying the state of the 'SampleVar', because
--- otherwise the state of the 'SampleVar' may have changed by the time
--- you see the result of 'isEmptySampleVar'.
---
-isEmptySampleVar :: SampleVar a -> IO Bool
-isEmptySampleVar (SampleVar svar) = do
-   (readers, _) <- readMVar svar
-   return (readers <= 0)
-
diff --git a/Data/HashTable.hs b/Data/HashTable.hs
deleted file mode 100644 (file)
index 9ce023c..0000000
+++ /dev/null
@@ -1,536 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP, NoImplicitPrelude #-}
-{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-name-shadowing #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  Data.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}@).
---
------------------------------------------------------------------------------
-
-module Data.HashTable
-      {-# DEPRECATED "Data.HashTable will be removed in GHC 7.8. Please use an alternative, e.g. the hashtables package, instead." #-}
-      (
-        -- * 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
-
--- This module is imported by Data.Dynamic, which is pretty low down in the
--- module hierarchy, so don't import "high-level" modules
-
-#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 )
-#  if defined(__HUGS__)
-import Hugs.IOArray     ( IOArray, newIOArray,
-                          unsafeReadIOArray, unsafeWriteIOArray )
-#  elif defined(__NHC__)
-import NHC.IOExtras     ( IOArray, newIOArray, readIOArray, writeIOArray )
-#  endif
-#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 213dd4e..b564de4 100644 (file)
@@ -120,9 +120,6 @@ Library {
         Control.Concurrent,
         Control.Concurrent.Chan,
         Control.Concurrent.MVar,
-        Control.Concurrent.QSem,
-        Control.Concurrent.QSemN,
-        Control.Concurrent.SampleVar,
         Control.Exception,
         Control.Exception.Base
         Control.Monad,
@@ -148,7 +145,6 @@ Library {
         Data.Foldable
         Data.Function,
         Data.Functor,
-        Data.HashTable,
         Data.IORef,
         Data.Int,
         Data.Ix,