diff --git a/cbits/cfuncs.c b/cbits/cfuncs.c --- a/cbits/cfuncs.c +++ b/cbits/cfuncs.c @@ -1,5 +1,7 @@ +#include #include - +#include +#include #if defined(USE_SSE_4_1) #include @@ -42,8 +44,14 @@ uint32_t x1, uint32_t x2) { uint32_t* ep = array + end; uint32_t* p = array + start; + int wrapped = 0; while (1) { - if (p == ep) p = array; + if (p == ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + } if (*p == x1 || *p == x2) return p - array; ++p; } @@ -54,8 +62,14 @@ uint32_t x1, uint32_t x2, uint32_t x3) { uint32_t* ep = array + end; uint32_t* p = array + start; + int wrapped = 0; while (1) { - if (p == ep) p = array; + if (p == ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + } if (*p == x1 || *p == x2 || *p == x3) return p - array; ++p; } @@ -66,8 +80,14 @@ uint64_t x1, uint64_t x2) { uint64_t* ep = array + end; uint64_t* p = array + start; + int wrapped = 0; while (1) { - if (p == ep) p = array; + if (p == ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + } if (*p == x1 || *p == x2) return p - array; ++p; } @@ -78,8 +98,14 @@ uint64_t x1, uint64_t x2, uint64_t x3) { uint64_t* ep = array + end; uint64_t* p = array + start; + int wrapped = 0; while (1) { - if (p == ep) p = array; + if (p == ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + } if (*p == x1 || *p == x2 || *p == x3) return p - array; ++p; } @@ -469,3 +495,13 @@ return lineResult64((int)m, start); } +void suicide(volatile int* check, int t) { + int secs = (3*t + 999999) / 1000000; + if (secs < 1) secs = 1; + + sleep(secs); + if (*check) { + printf("timeout expired, dying!!\n"); + raise(SIGKILL); + } +} diff --git a/hashtables.cabal b/hashtables.cabal --- a/hashtables.cabal +++ b/hashtables.cabal @@ -1,5 +1,5 @@ Name: hashtables -Version: 1.0.0.0 +Version: 1.0.1.0 Synopsis: Mutable hash tables in the ST monad Homepage: http://github.com/gregorycollins/hashtables License: BSD3 @@ -165,7 +165,7 @@ if flag(portable) - cpp-options: -DNO_C_SEARCH + cpp-options: -DNO_C_SEARCH -DPORTABLE if !flag(portable) && flag(unsafe-tricks) && impl(ghc) build-depends: ghc-prim diff --git a/src/Data/HashTable/Internal/CacheLine.hs b/src/Data/HashTable/Internal/CacheLine.hs --- a/src/Data/HashTable/Internal/CacheLine.hs +++ b/src/Data/HashTable/Internal/CacheLine.hs @@ -234,30 +234,38 @@ {-# INLINE forwardSearch2 #-} forwardSearch2 :: IntArray s -> Int -> Int -> Int -> Int -> ST s Int -forwardSearch2 !vec !start !end !x1 !x2 = go start +forwardSearch2 !vec !start !end !x1 !x2 = go start end False where - next !i = let !j = i+1 - in if j == end then 0 else j + next !i !e !b = let !j = i+1 + in if j == e + then (if b then (-1,e,True) else (0,start,True)) + else (j,e,b) - go !i = do + go !i !e !b = do h <- M.readArray vec i if h == x1 || h == x2 then return i - else go $ next i + else do + let (!i',!e',!b') = next i e b + if (i' < 0) then return (-1) else go i' e' b' {-# INLINE forwardSearch3 #-} forwardSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int -forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start +forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start end False where - next !i = let !j = i+1 - in if j == end then 0 else j + next !i !e !b = let !j = i+1 + in if j == e + then (if b then (-1,e,True) else (0,start,True)) + else (j,e,b) - go !i = do + go !i !e !b = do h <- M.readArray vec i if h == x1 || h == x2 || h == x3 then return i - else go $ next i + else do + let (!i',!e',!b') = next i e b + if (i' < 0) then return (-1) else go i' e' b' deBruijnBitPositions :: U.Vector Int8 diff --git a/src/Data/HashTable/ST/Basic.hs b/src/Data/HashTable/ST/Basic.hs --- a/src/Data/HashTable/ST/Basic.hs +++ b/src/Data/HashTable/ST/Basic.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} {-| @@ -13,6 +14,10 @@ * don't care that a table resize might pause for a long time to rehash all of the key-value mappings. + * have a workload which is not heavy with deletes; deletes clutter the table + with deleted markers and force the table to be completely rehashed fairly + often. + /Details:/ Of the hash tables in this collection, this hash table has the best insert and @@ -88,11 +93,13 @@ ------------------------------------------------------------------------------ +import Control.Exception (assert) import Control.Monad hiding (mapM_, foldM) import Control.Monad.ST import Data.Hashable (Hashable) import qualified Data.Hashable as H import Data.Maybe +import Data.Monoid import Data.STRef import GHC.Exts import Prelude hiding (lookup, read, mapM_) @@ -109,13 +116,14 @@ newtype HashTable s k v = HT (STRef s (HashTable_ s k v)) data HashTable_ s k v = HashTable - { _size :: {-# UNPACK #-} !Int - , _load :: !(U.IntArray s) -- ^ prefer unboxed vector here to STRef - -- because I know it will be appropriately - -- strict - , _hashes :: !(U.IntArray s) - , _keys :: {-# UNPACK #-} !(MutableArray s k) - , _values :: {-# UNPACK #-} !(MutableArray s v) + { _size :: {-# UNPACK #-} !Int + , _load :: !(U.IntArray s) -- ^ How many entries in the table? Prefer + -- unboxed vector here to STRef because I + -- know it will be appropriately strict + , _delLoad :: !(U.IntArray s) -- ^ How many deleted entries in the table? + , _hashes :: !(U.IntArray s) + , _keys :: {-# UNPACK #-} !(MutableArray s k) + , _values :: {-# UNPACK #-} !(MutableArray s v) } @@ -166,8 +174,8 @@ k <- newArray m undefined v <- newArray m undefined ld <- U.newArray 1 - return $! HashTable m ld h k v - + dl <- U.newArray 1 + return $! HashTable m ld dl h k v ------------------------------------------------------------------------------ @@ -186,8 +194,6 @@ {-# INLINE delete #-} - - ------------------------------------------------------------------------------ -- | See the documentation for this function in -- "Data.HashTable.Class#v:lookup". @@ -196,30 +202,35 @@ ht <- readRef htRef lookup' ht where - lookup' (HashTable sz _ hashes keys values) = do + lookup' (HashTable sz _ _ hashes keys values) = do let !b = whichBucket h sz debug $ "lookup sz=" ++ show sz ++ " h=" ++ show h ++ " b=" ++ show b - go b + go b 0 sz where !h = hash k - go !b = {-# SCC "lookup/go" #-} do - idx <- forwardSearch2 hashes b sz h emptyMarker + go !b !start !end = {-# SCC "lookup/go" #-} do + idx <- forwardSearch2 hashes b end h emptyMarker debug $ "forwardSearch2 returned " ++ show idx - h0 <- U.readArray hashes idx - debug $ "h0 was " ++ show h0 + if (idx < 0 || idx < start || idx >= end) + then return Nothing + else do + h0 <- U.readArray hashes idx + debug $ "h0 was " ++ show h0 - if recordIsEmpty h0 - then return Nothing - else do - k' <- readArray keys idx - if k == k' - then do - debug $ "value found at " ++ show idx - v <- readArray values idx - return $! Just v - else go $! idx + 1 + if recordIsEmpty h0 + then return Nothing + else do + k' <- readArray keys idx + if k == k' + then do + debug $ "value found at " ++ show idx + v <- readArray values idx + return $! Just v + else if idx < b + then go (idx + 1) (idx + 1) b + else go (idx + 1) start end {-# INLINE lookup #-} @@ -262,7 +273,7 @@ foldM :: (a -> (k,v) -> ST s a) -> a -> HashTable s k v -> ST s a foldM f seed0 htRef = readRef htRef >>= work where - work (HashTable sz _ hashes keys values) = go 0 seed0 + work (HashTable sz _ _ hashes keys values) = go 0 seed0 where go !i !seed | i >= sz = return seed | otherwise = do @@ -282,7 +293,7 @@ mapM_ :: ((k,v) -> ST s b) -> HashTable s k v -> ST s () mapM_ f htRef = readRef htRef >>= work where - work (HashTable sz _ hashes keys values) = go 0 + work (HashTable sz _ _ hashes keys values) = go 0 where go !i | i >= sz = return () | otherwise = do @@ -302,14 +313,14 @@ computeOverhead :: HashTable s k v -> ST s Double computeOverhead htRef = readRef htRef >>= work where - work (HashTable sz' loadRef _ _ _) = do + work (HashTable sz' loadRef _ _ _ _) = do !ld <- U.readArray loadRef 0 let k = fromIntegral ld / sz return $ constOverhead / sz + overhead k where sz = fromIntegral sz' -- Change these if you change the representation - constOverhead = 10 + constOverhead = 14 overhead k = 3 / k - 2 @@ -330,44 +341,55 @@ -> ST s () insertRecord !sz !hashes !keys !values !h !key !value = do let !b = whichBucket h sz - debug $ "insertRecord sz=" ++ show sz ++ "h=" ++ show h ++ " b=" ++ show b + debug $ "insertRecord sz=" ++ show sz ++ " h=" ++ show h ++ " b=" ++ show b probe b where probe !i = {-# SCC "insertRecord/probe" #-} do !idx <- forwardSearch2 hashes i sz emptyMarker deletedMarker debug $ "forwardSearch2 returned " ++ show idx - U.writeArray hashes idx h - writeArray keys idx key - writeArray values idx value + assert (idx >= 0) $ do + U.writeArray hashes idx h + writeArray keys idx key + writeArray values idx value ------------------------------------------------------------------------------ checkOverflow :: (Eq k, Hashable k) => (HashTable_ s k v) -> ST s (HashTable_ s k v) -checkOverflow ht@(HashTable sz ldRef _ _ _) = do +checkOverflow ht@(HashTable sz ldRef delRef _ _ _) = do !ld <- U.readArray ldRef 0 let !ld' = ld + 1 U.writeArray ldRef 0 ld' + !dl <- U.readArray delRef 0 - if fromIntegral ld / fromIntegral sz > maxLoad - then growTable ht + debug $ concat [ "checkOverflow: sz=" + , show sz + , " entries=" + , show ld + , " deleted=" + , show dl ] + + if fromIntegral (ld + dl) / fromIntegral sz > maxLoad + then if dl > ld `div` 2 + then rehashAll ht sz + else growTable ht else return ht ------------------------------------------------------------------------------ -growTable :: Hashable k => HashTable_ s k v -> ST s (HashTable_ s k v) -growTable (HashTable sz loadRef hashes keys values) = do - let !sz' = bumpSize sz +rehashAll :: Hashable k => HashTable_ s k v -> Int -> ST s (HashTable_ s k v) +rehashAll (HashTable sz loadRef _ hashes keys values) sz' = do + debug $ "rehashing: old size " ++ show sz ++ ", new size " ++ show sz' ht' <- newSizedReal sz' - let (HashTable _ loadRef' newHashes newKeys newValues) = ht' + let (HashTable _ loadRef' _ newHashes newKeys newValues) = ht' U.readArray loadRef 0 >>= U.writeArray loadRef' 0 - rehash sz' newHashes newKeys newValues + rehash newHashes newKeys newValues return ht' where - rehash sz' newHashes newKeys newValues = go 0 + rehash newHashes newKeys newValues = go 0 where go !i | i >= sz = return () | otherwise = {-# SCC "growTable/rehash" #-} do @@ -381,6 +403,30 @@ ------------------------------------------------------------------------------ +growTable :: Hashable k => HashTable_ s k v -> ST s (HashTable_ s k v) +growTable ht@(HashTable sz _ _ _ _ _) = do + let !sz' = bumpSize sz + rehashAll ht sz' + + +------------------------------------------------------------------------------ +-- Helper data structure for delete' +data Slot = Slot { + _slot :: {-# UNPACK #-} !Int + , _wasDeleted :: {-# UNPACK #-} !Int -- we use Int because Bool won't + -- unpack + } + deriving (Show) + + +------------------------------------------------------------------------------ +instance Monoid Slot where + mempty = Slot maxBound 0 + (Slot x1 b1) `mappend` (Slot x2 b2) = + if x1 == maxBound then Slot x2 b2 else Slot x1 b1 + + +------------------------------------------------------------------------------ -- Returns the slot in the array where it would be safe to write the given key. delete' :: (Hashable k, Eq k) => (HashTable_ s k v) @@ -388,62 +434,97 @@ -> k -> Int -> ST s Int -delete' (HashTable sz loadRef hashes keys values) clearOut k h = do - let !b = whichBucket h sz +delete' (HashTable sz loadRef delRef hashes keys values) clearOut k h = do debug $ "delete': sz=" ++ show sz ++ " h=" ++ show h - ++ " b=" ++ show b - (found,b') <- go Nothing b - when found $ do - !ld <- U.readArray loadRef 0 - let !ld' = ld - 1 - U.writeArray loadRef 0 ld' + ++ " b0=" ++ show b0 + (found, slot) <- go mempty b0 False + + let !b' = _slot slot + + when found $ bump loadRef (-1) + + -- bump the delRef lower if we're writing over a deleted marker + when (not clearOut && _wasDeleted slot == 1) $ bump delRef (-1) return b' where - delPlace !fp !b = maybe (Just b) (const fp) fp - choosePlace !fp !b = fromMaybe b fp - samePlace !fp !b = maybe (True) (== b) fp + bump ref i = do + !ld <- U.readArray ref 0 + U.writeArray ref 0 $! ld + i - go !fp !b = do + !b0 = whichBucket h sz + + haveWrapped !(Slot fp _) !b = if fp == maxBound + then False + else b <= fp + + -- arguments: + + -- * fp maintains the slot in the array where it would be safe to + -- write the given key + -- * b search the buckets array starting at this index. + -- * wrap True if we've wrapped around, False otherwise + + go !fp !b !wrap = do debug $ "go: fp=" ++ show fp ++ " b=" ++ show b + ++ ", wrap=" ++ show wrap !idx <- forwardSearch3 hashes b sz h emptyMarker deletedMarker debug $ "forwardSearch3 returned " ++ show idx - h0 <- U.readArray hashes idx - debug $ "h0 was " ++ show h0 - if recordIsEmpty h0 - then do - let pl = choosePlace fp idx - debug $ "empty, returning " ++ show pl - return (False, pl) - else - if recordIsDeleted h0 + if wrap && idx >= b0 + -- we wrapped around in the search and didn't find our hash code; + -- this means that the table is full of deleted elements. Just return + -- the first place we'd be allowed to insert. + -- + -- TODO: if we get in this situation we should probably just rehash + -- the table, because every insert is going to be O(n). + then return $! + (False, fp `mappend` (Slot (error "impossible") 0)) + else do + -- because the table isn't full, we know that there must be either + -- an empty or a deleted marker somewhere in the table. Assert this + -- here. + assert (idx > 0) $ return () + h0 <- U.readArray hashes idx + debug $ "h0 was " ++ show h0 + + if recordIsEmpty h0 then do - let pl = delPlace fp idx - debug $ "deleted, cont with pl=" ++ show pl - go pl $ idx + 1 - else - if h == h0 + let pl = fp `mappend` (Slot idx 0) + debug $ "empty, returning " ++ show pl + return (False, pl) + else do + let !wrap' = haveWrapped fp idx + if recordIsDeleted h0 then do - k' <- readArray keys idx - if k == k' + let pl = fp `mappend` (Slot idx 1) + debug $ "deleted, cont with pl=" ++ show pl + go pl (idx + 1) wrap' + else + if h == h0 then do - debug $ "found at " ++ show idx - debug $ "clearout=" ++ show clearOut - debug $ "sp? " ++ show (samePlace fp idx) - -- "clearOut" is set if we intend to write a new - -- element into the slot. If we're doing an update and - -- we found the old key, instead of writing "deleted" - -- and then re-writing the new element there, we can - -- just write the new element. This only works if we - -- were planning on writing the new element here. - when (clearOut || not (samePlace fp idx)) $ do - U.writeArray hashes idx 1 - writeArray keys idx undefined - writeArray values idx undefined - return (True, choosePlace fp idx) - else go fp $ idx + 1 - else go fp $ idx + 1 + k' <- readArray keys idx + if k == k' + then do + let samePlace = _slot fp == idx + debug $ "found at " ++ show idx + debug $ "clearout=" ++ show clearOut + debug $ "sp? " ++ show samePlace + -- "clearOut" is set if we intend to write a new + -- element into the slot. If we're doing an update + -- and we found the old key, instead of writing + -- "deleted" and then re-writing the new element + -- there, we can just write the new element. This + -- only works if we were planning on writing the + -- new element here. + when (clearOut || not samePlace) $ do + bump delRef 1 + U.writeArray hashes idx 1 + writeArray keys idx undefined + writeArray values idx undefined + return (True, fp `mappend` (Slot idx 0)) + else go fp (idx + 1) wrap' + else go fp (idx + 1) wrap' ------------------------------------------------------------------------------ maxLoad :: Double @@ -502,5 +583,8 @@ ------------------------------------------------------------------------------ {-# INLINE debug #-} debug :: String -> ST s () ---debug s = unsafeIOToST (putStrLn s) +#ifdef DEBUG +debug s = unsafeIOToST (putStrLn s) +#else debug _ = return () +#endif diff --git a/src/Data/HashTable/ST/Cuckoo.hs b/src/Data/HashTable/ST/Cuckoo.hs --- a/src/Data/HashTable/ST/Cuckoo.hs +++ b/src/Data/HashTable/ST/Cuckoo.hs @@ -253,7 +253,9 @@ searchOne !keys !hashes !k = go where go !b !h = do + debug $ "searchOne: go " ++ show b ++ " " ++ show h idx <- cacheLineSearch hashes b h + debug $ "searchOne: cacheLineSearch returned " ++ show idx case idx of -1 -> return (-1) diff --git a/test/hashtables-test.cabal b/test/hashtables-test.cabal --- a/test/hashtables-test.cabal +++ b/test/hashtables-test.cabal @@ -47,8 +47,10 @@ ghc-options: -fhpc if flag(portable) - cpp-options: -DNO_C_SEARCH - + cpp-options: -DNO_C_SEARCH -DPORTABLE + else + build-depends: unix >= 2.3 && <3 + if !flag(portable) && flag(unsafe-tricks) && impl(ghc) cpp-options: -DUNSAFETRICKS build-depends: ghc-prim @@ -68,8 +70,10 @@ mwc-random == 0.8.*, primitive, QuickCheck >= 2.3.0.2, + HUnit >= 1.2 && <2, test-framework >= 0.3.1 && <0.4, test-framework-quickcheck2 >= 0.2.6 && < 0.3, + test-framework-hunit >= 0.2.6 && <3, vector >= 0.7 cpp-options: -DTESTSUITE @@ -92,7 +96,9 @@ ghc-prof-options: -prof -auto-all if flag(portable) - cpp-options: -DNO_C_SEARCH + cpp-options: -DNO_C_SEARCH -DPORTABLE + else + build-depends: unix >= 2.3 && <3 if !flag(portable) && flag(unsafe-tricks) && impl(ghc) cpp-options: -DUNSAFETRICKS @@ -112,8 +118,10 @@ hashable >= 1.1 && <2, mwc-random == 0.8.*, QuickCheck >= 2.3.0.2, + HUnit >= 1.2 && <2, test-framework >= 0.3.1 && <0.4, test-framework-quickcheck2 >= 0.2.6 && < 0.3, + test-framework-hunit >= 0.2.6 && <3, statistics == 0.8.*, primitive, vector >= 0.7 diff --git a/test/suite/Data/HashTable/Test/Common.hs b/test/suite/Data/HashTable/Test/Common.hs --- a/test/suite/Data/HashTable/Test/Common.hs +++ b/test/suite/Data/HashTable/Test/Common.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RankNTypes #-} module Data.HashTable.Test.Common ( FixedTableType @@ -9,7 +11,7 @@ ) where ------------------------------------------------------------------------------ -import Control.Monad (liftM, when) +import Control.Monad (foldM_, liftM, when) import Control.Monad.ST (unsafeIOToST) import Data.IORef import Data.List hiding ( insert @@ -20,14 +22,22 @@ import qualified Data.Vector.Mutable as MV import Prelude hiding (lookup, mapM_) import System.Random.MWC +import System.Timeout import Test.Framework +import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 +import Test.HUnit (assertFailure) import Test.QuickCheck import Test.QuickCheck.Monadic ------------------------------------------------------------------------------ import qualified Data.HashTable.Class as C import Data.HashTable.IO +#ifndef PORTABLE +import Control.Concurrent +import Foreign (malloc, free, poke, Ptr) +import Foreign.C.Types (CInt) +#endif ------------------------------------------------------------------------------ type FixedTableType h = forall k v . IOHashTable h k v @@ -67,6 +77,8 @@ , SomeTest testNewAndInsert , SomeTest testGrowTable , SomeTest testDelete + , SomeTest testNastyFullLookup + , SomeTest testForwardSearch3 ] @@ -250,6 +262,162 @@ ct <- run $ foldM f (0::Int, 0::Int) ht assertEq "max + count" (n-1,n-1) ct forceType dummyArg ht + + +------------------------------------------------------------------------------ +data Action = Lookup Int + | Insert Int + | Delete Int + deriving Show + + +timeout_ :: Int -> IO a -> IO () +#ifdef PORTABLE +timeout_ t m = timeout t m >>= maybe (assertFailure "timeout") + (const $ return ()) +#else + +foreign import ccall safe "suicide" + c_suicide :: Ptr CInt -> CInt -> IO () + + +-- Foreign thread can get blocked here, stalling progress. We'll make damned +-- sure we bomb out. +timeout_ t m = do + ptr <- malloc + poke ptr 1 + forkOS $ suicide ptr + threadDelay 1000 + r <- timeout t m + poke ptr 0 + maybe (assertFailure "timeout") + (const $ return ()) + r + where + suicide ptr = do + c_suicide ptr $ toEnum t + free ptr +#endif + +applyAction :: forall h . C.HashTable h => + IOHashTable h Int () -> Action -> IO () +applyAction tbl (Lookup key) = lookup tbl key >> return () +applyAction tbl (Insert key) = insert tbl key () +applyAction tbl (Delete key) = delete tbl key + + +testForwardSearch3 :: HashTest +testForwardSearch3 prefix dummyArg = testCase (prefix ++ "/forwardSearch3") go + where + go = do + tbl <- new + forceType tbl dummyArg + timeout_ 3000000 $ + foldM_ (\t k -> applyAction t k >> return t) tbl testData + + testData = + [ Insert 65 + , Insert 66 + , Insert 67 + , Insert 74 + , Insert 75 + , Insert 76 + , Insert 77 + , Insert 79 + , Insert 80 + , Insert 81 + , Insert 82 + , Insert 83 + , Insert 84 + , Delete 81 + , Delete 82 + , Insert 85 + , Insert 86 + , Insert 87 + , Insert 88 + , Insert 89 + , Insert 90 + , Insert 78 + , Insert 93 + , Insert 94 + , Insert 95 + , Insert 96 + , Insert 97 + , Insert 92 + , Delete 93 + , Delete 94 + , Delete 95 + , Delete 96 + , Insert 99 + , Insert 100 + , Insert 101 + , Insert 102 + , Insert 103 + , Insert 104 + , Insert 98 + , Insert 91 + , Insert 108 + , Insert 109 + , Insert 110 + , Insert 111 + ] + + +testNastyFullLookup :: HashTest +testNastyFullLookup prefix dummyArg = testCase (prefix ++ "/nastyFullLookup") go + where + go = do + tbl <- new + forceType tbl dummyArg + timeout_ 3000000 $ + foldM_ (\t k -> applyAction t k >> return t) tbl testData + + testData = + [ Insert 28 + , Insert 27 + , Insert 30 + , Insert 31 + , Insert 32 + , Insert 33 + , Insert 34 + , Insert 29 + , Insert 36 + , Insert 37 + , Delete 34 + , Delete 29 + , Insert 38 + , Insert 39 + , Insert 40 + , Insert 35 + , Delete 39 + , Insert 42 + , Insert 43 + , Delete 40 + , Delete 35 + , Insert 44 + , Insert 45 + , Insert 41 + , Insert 48 + , Insert 47 + , Insert 50 + , Insert 51 + , Insert 52 + , Insert 49 + , Insert 54 + , Insert 53 + , Insert 56 + , Insert 55 + , Insert 58 + , Insert 57 + , Insert 60 + , Insert 59 + , Delete 60 + , Insert 62 + , Insert 61 + , Insert 63 + , Insert 46 + , Lookup 66 + ] ------------------------------------------------------------------------------