Permalink
Browse files

Basic hashtable: don't loop forever if the table contains no empty ma…

…rkers (fixes #1).
  • Loading branch information...
1 parent 8d899d3 commit 1fb7f4647ce0c2e0135ada0b1bb589ffee01d485 @gregorycollins committed Nov 23, 2011
Showing with 81 additions and 37 deletions.
  1. +28 −4 cbits/cfuncs.c
  2. +1 −1 hashtables.cabal
  3. +18 −10 src/Data/HashTable/Internal/CacheLine.hs
  4. +34 −22 src/Data/HashTable/ST/Basic.hs
View
@@ -44,8 +44,14 @@ int forwardSearch32_2(uint32_t* array, int start, int end,
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;
}
@@ -56,8 +62,14 @@ int forwardSearch32_3(uint32_t* array, int start, int end,
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;
}
@@ -68,8 +80,14 @@ int forwardSearch64_2(uint64_t* array, int start, int end,
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;
}
@@ -80,8 +98,14 @@ int forwardSearch64_3(uint64_t* array, int start, int end,
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;
}
View
@@ -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
@@ -234,30 +234,38 @@ prefetchWrite _ _ = return ()
{-# 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 0
@tmcdonell

tmcdonell Nov 24, 2011

warning: defaults zero to type Integer

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 > 0 then (-1,e,1) else (0,start,1))
+ 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 0
@tmcdonell

tmcdonell Nov 24, 2011

defaults to type Integer here as well

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 > 0 then (-1,e,1) else (0,start,1))
+ 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
@@ -1,5 +1,6 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
{-|
@@ -88,6 +89,7 @@ module Data.HashTable.ST.Basic
------------------------------------------------------------------------------
+import Control.Exception (assert)
import Control.Monad hiding (mapM_, foldM)
import Control.Monad.ST
import Data.Hashable (Hashable)
@@ -199,27 +201,32 @@ lookup htRef !k = 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 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 (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 if idx < b
+ then go (idx + 1) (idx + 1) b
+ else go (idx + 1) start end
{-# INLINE lookup #-}
@@ -337,9 +344,10 @@ insertRecord !sz !hashes !keys !values !h !key !value = do
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
------------------------------------------------------------------------------
@@ -408,6 +416,7 @@ delete' (HashTable sz loadRef hashes keys values) clearOut k h = do
debug $ "go: fp=" ++ show fp ++ " b=" ++ show b
!idx <- forwardSearch3 hashes b sz h emptyMarker deletedMarker
debug $ "forwardSearch3 returned " ++ show idx
+ assert (idx > 0) $ return ()
h0 <- U.readArray hashes idx
debug $ "h0 was " ++ show h0
@@ -502,5 +511,8 @@ readRef (HT ref) = readSTRef ref
------------------------------------------------------------------------------
{-# INLINE debug #-}
debug :: String -> ST s ()
---debug s = unsafeIOToST (putStrLn s)
+#ifdef DEBUG
+debug s = unsafeIOToST (putStrLn s)
+#else
debug _ = return ()
+#endif

0 comments on commit 1fb7f46

Please sign in to comment.