Commit 9557f5f1 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Remove some deprecated modules and functions

parent 3bf08162
......@@ -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
......
{-# 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 ()
{-# 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')
{-# 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)
{-# 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]