This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via 388e074c53f6c97e7aec21617e00f5909c4f2210 (commit)
from d0783a072d3730e5ca19aab7858dbf91f3d838ff (commit)
Summary of changes:
snap-server.cabal | 2 +
src/Data/Concurrent/HashMap.hs | 237 +++++++++++++++++++++++++++
src/Data/Concurrent/HashMap/Internal.hs | 16 ++
test/suite/Data/Concurrent/HashMap/Tests.hs | 121 ++++++++++++++
test/suite/TestSuite.hs | 6 +-
5 files changed, 380 insertions(+), 2 deletions(-)
create mode 100644 src/Data/Concurrent/HashMap.hs
create mode 100644 src/Data/Concurrent/HashMap/Internal.hs
create mode 100644 test/suite/Data/Concurrent/HashMap/Tests.hs
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 388e074c53f6c97e7aec21617e00f5909c4f2210
Author: Gregory Collins <[email protected]>
Date: Sun Mar 20 19:21:48 2011 +0100
Oops, some code was still using Data.Concurrent.HashMap
diff --git a/snap-server.cabal b/snap-server.cabal
index a175ccd..7f5bbc6 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -86,6 +86,8 @@ Library
other-modules:
Paths_snap_server,
+ Data.Concurrent.HashMap,
+ Data.Concurrent.HashMap.Internal,
Snap.Internal.Http.Parser,
Snap.Internal.Http.Server,
Snap.Internal.Http.Server.Date,
diff --git a/src/Data/Concurrent/HashMap.hs b/src/Data/Concurrent/HashMap.hs
new file mode 100644
index 0000000..1c649cc
--- /dev/null
+++ b/src/Data/Concurrent/HashMap.hs
@@ -0,0 +1,237 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Concurrent.HashMap
+ ( HashMap
+ , new
+ , new'
+ , null
+ , insert
+ , delete
+ , lookup
+ , update
+ , fromList
+ , toList
+ , hashString
+ , hashBS
+ , hashInt
+ , nextHighestPowerOf2 ) where
+
+------------------------------------------------------------------------------
+
+import Control.Concurrent.MVar
+import Control.Monad
+import Data.Bits
+import qualified Data.ByteString as B
+import qualified Data.Digest.Murmur32 as Murmur
+import qualified Data.Digest.Murmur64 as Murmur
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IM
+import Data.Maybe
+import qualified Data.Vector as V
+import Data.Vector (Vector)
+import GHC.Conc (numCapabilities)
+import Prelude hiding (lookup, null)
+import qualified Prelude
+
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts ( Word(..), Int(..), shiftRL# )
+#else
+import Data.Word
+#endif
+
+import Data.Concurrent.HashMap.Internal
+
+
+hashString :: String -> Word
+hashString = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]
+ [| Murmur.asWord64 . Murmur.hash64 |])
+{-# INLINE hashString #-}
+
+
+hashInt :: Int -> Word
+hashInt = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]
+ [| Murmur.asWord64 . Murmur.hash64 |])
+{-# INLINE hashInt #-}
+
+
+hashBS :: B.ByteString -> Word
+hashBS =
+ $(let h32 = [| \s -> s `seq`
+ Murmur.asWord32 $
+ B.foldl' (\h c -> h `seq` c `seq`
+ Murmur.hash32AddInt (fromEnum c) h)
+ (Murmur.hash32 ([] :: [Int]))
+ s
+ |]
+ h64 = [| \s -> s `seq`
+ Murmur.asWord64 $
+ B.foldl' (\h c -> h `seq` c `seq`
+ Murmur.hash64AddInt (fromEnum c) h)
+ (Murmur.hash64 ([] :: [Int]))
+ s
+ |]
+ in whichHash h32 h64)
+{-# INLINE hashBS #-}
+
+
+data HashMap k v = HM {
+ _hash :: !(k -> Word)
+ , _hashToBucket :: !(Word -> Word)
+ , _maps :: !(Vector (MVar (Submap k v)))
+}
+
+
+
+null :: HashMap k v -> IO Bool
+null ht = liftM V.and $ V.mapM f $ _maps ht
+
+ where
+ f mv = withMVar mv (return . IM.null)
+
+
+new' :: Eq k =>
+ Int -- ^ number of locks to use
+ -> (k -> Word) -- ^ hash function
+ -> IO (HashMap k v)
+new' numLocks hashFunc = do
+ vector <- V.replicateM (fromEnum n) (newMVar IM.empty)
+ return $! HM hf bh vector
+
+ where
+ hf !x = hashFunc x
+ bh !x = x .&. (n-1)
+ !n = nextHighestPowerOf2 $ toEnum numLocks
+
+
+new :: Eq k =>
+ (k -> Word) -- ^ hash function
+ -> IO (HashMap k v)
+new = new' defaultNumberOfLocks
+
+
+insert :: k -> v -> HashMap k v -> IO ()
+insert key value ht =
+ modifyMVar_ submap $ \m ->
+ return $! insSubmap hashcode key value m
+
+ where
+ hashcode = _hash ht key
+ bucket = _hashToBucket ht hashcode
+ submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
+
+
+delete :: (Eq k) => k -> HashMap k v -> IO ()
+delete key ht =
+ modifyMVar_ submap $ \m ->
+ return $! delSubmap hashcode key m
+ where
+ hashcode = _hash ht key
+ bucket = _hashToBucket ht hashcode
+ submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
+
+
+lookup :: (Eq k) => k -> HashMap k v -> IO (Maybe v)
+lookup key ht =
+ withMVar submap $ \m ->
+ return $! lookupSubmap hashcode key m
+ where
+ hashcode = _hash ht key
+ bucket = _hashToBucket ht hashcode
+ submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
+
+
+update :: (Eq k) => k -> v -> HashMap k v -> IO Bool
+update key value ht =
+ modifyMVar submap $ \m ->
+ return $! updateSubmap hashcode key value m
+ where
+ hashcode = _hash ht key
+ bucket = _hashToBucket ht hashcode
+ submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
+
+
+toList :: HashMap k v -> IO [(k,v)]
+toList ht = liftM (concat . V.toList) $ V.mapM f $ _maps ht
+ where
+ f m = withMVar m $ \sm -> return $ concat $ IM.elems sm
+
+
+fromList :: (Eq k) => (k -> Word) -> [(k,v)] -> IO (HashMap k v)
+fromList hf xs = do
+ ht <- new hf
+ mapM_ (\(k,v) -> insert k v ht) xs
+ return $! ht
+
+
+------------------------------------------------------------------------------
+-- helper functions
+------------------------------------------------------------------------------
+
+-- nicked this technique from Data.IntMap
+
+shiftRL :: Word -> Int -> Word
+#if __GLASGOW_HASKELL__
+{--------------------------------------------------------------------
+ GHC: use unboxing to get @shiftRL@ inlined.
+--------------------------------------------------------------------}
+shiftRL (W# x) (I# i)
+ = W# (shiftRL# x i)
+#else
+shiftRL x i = shiftR x i
+#endif
+
+
+type Submap k v = IntMap [(k,v)]
+
+
+nextHighestPowerOf2 :: Word -> Word
+nextHighestPowerOf2 w = highestBitMask (w-1) + 1
+
+
+highestBitMask :: Word -> Word
+highestBitMask !x0 = case (x0 .|. shiftRL x0 1) of
+ x1 -> case (x1 .|. shiftRL x1 2) of
+ x2 -> case (x2 .|. shiftRL x2 4) of
+ x3 -> case (x3 .|. shiftRL x3 8) of
+ x4 -> case (x4 .|. shiftRL x4 16) of
+ x5 -> x5 .|. shiftRL x5 32
+
+
+
+insSubmap :: Word -> k -> v -> Submap k v -> Submap k v
+insSubmap hashcode key value m = let !x = f m in x
+ where
+ f = IM.insertWith (++) (fromIntegral hashcode) [(key,value)]
+
+
+delSubmap :: (Eq k) => Word -> k -> Submap k v -> Submap k v
+delSubmap hashcode key m =
+ let !z = IM.update f (fromIntegral hashcode) m in z
+
+ where
+ f l = let l' = del l in if Prelude.null l' then Nothing else Just l'
+
+ del = filter ((/= key) . fst)
+
+
+lookupSubmap :: (Eq k) => Word -> k -> Submap k v -> Maybe v
+lookupSubmap hashcode key m = maybe Nothing (Prelude.lookup key) mbBucket
+ where
+ mbBucket = IM.lookup (fromIntegral hashcode) m
+
+
+updateSubmap :: (Eq k) => Word -> k -> v -> Submap k v -> (Submap k v, Bool)
+updateSubmap hashcode key value m = (m'', b)
+ where
+ oldV = lookupSubmap hashcode key m
+ m' = maybe m (const $ delSubmap hashcode key m) oldV
+ m'' = insSubmap hashcode key value m'
+ b = isJust oldV
+
+
+defaultNumberOfLocks :: Int
+defaultNumberOfLocks = 8 * numCapabilities
diff --git a/src/Data/Concurrent/HashMap/Internal.hs
b/src/Data/Concurrent/HashMap/Internal.hs
new file mode 100644
index 0000000..3ff3f6b
--- /dev/null
+++ b/src/Data/Concurrent/HashMap/Internal.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Concurrent.HashMap.Internal where
+
+import Data.Bits
+import Data.Word
+import Language.Haskell.TH
+
+
+whichHash :: ExpQ -> ExpQ -> Q Exp
+whichHash as32 as64 = if bitSize (undefined :: Word) == 32
+ then [| \x -> fromIntegral $ $as32 x |]
+ else [| \x -> fromIntegral $ $as64 x |]
diff --git a/test/suite/Data/Concurrent/HashMap/Tests.hs
b/test/suite/Data/Concurrent/HashMap/Tests.hs
new file mode 100644
index 0000000..a0fefaf
--- /dev/null
+++ b/test/suite/Data/Concurrent/HashMap/Tests.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PackageImports #-}
+
+module Data.Concurrent.HashMap.Tests
+ ( tests ) where
+
+import Data.ByteString.Char8 (ByteString)
+import Data.List
+import Data.Word
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+
+import qualified Data.Concurrent.HashMap as H
+import Snap.Test.Common ()
+
+tests :: [Test]
+tests = [ testFromTo
+ , testLookup
+ , testDeletes
+ , testUpdate
+ ]
+
+
+-- make sure we generate two strings which hash to the same bucket.
+bogoHash :: ByteString -> Word
+bogoHash "qqq" = 12345
+bogoHash "zzz" = 12345
+bogoHash x = H.hashBS x
+
+
+testFromTo :: Test
+testFromTo = testProperty "HashMap/fromList/toList" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: [(Int,Int)] -> PropertyM IO ()
+ prop l = do
+ ht <- run $ H.fromList H.hashInt l
+ l' <- run $ H.toList ht
+
+ let s1 = sort l
+ let s2 = sort l'
+
+ assert $ s1 == s2
+
+
+testDeletes :: Test
+testDeletes = testProperty "HashMap/deletes" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: [(ByteString,ByteString)] -> PropertyM IO ()
+ prop l' = do
+ pre (not $ null l')
+ let l = [("qqq","QQQ"),("zzz","ZZZ")] ++ l'
+ let h = head l'
+
+ ht <- run $ H.fromList bogoHash l
+ v1 <- run $ H.lookup "qqq" ht
+ v2 <- run $ H.lookup "zzz" ht
+
+ run $ H.delete "qqq" ht
+ v3 <- run $ H.lookup "qqq" ht
+ v4 <- run $ H.lookup "zzz" ht
+
+ run $ H.delete (fst h) ht
+ run $ H.delete (fst h) ht
+
+ v5 <- run $ H.lookup (fst h) ht
+
+ assert $ v1 == Just "QQQ"
+ assert $ v2 == Just "ZZZ"
+ assert $ v3 == Nothing
+ assert $ v4 == Just "ZZZ"
+ assert $ v5 == Nothing
+
+
+testLookup :: Test
+testLookup = testProperty "HashMap/lookup" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: [(ByteString,ByteString)] -> PropertyM IO ()
+ prop l' = do
+ pre (not $ null l')
+ let h = head l'
+ let l = filter ((/= (fst h)) . fst) $ tail l'
+
+ ht <- run $ H.fromList H.hashBS (h:l)
+
+ v1 <- run $ H.lookup (fst h) ht
+ run $ H.delete (fst h) ht
+ v2 <- run $ H.lookup (fst h) ht
+
+ assert $ v1 == (Just $ snd h)
+ assert $ v2 == Nothing
+
+
+testUpdate :: Test
+testUpdate = testProperty "HashMap/update" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop :: [(ByteString,ByteString)] -> PropertyM IO ()
+ prop l' = do
+ pre (not $ null l')
+ let h = head l'
+ let l = filter ((/= (fst h)) . fst) $ tail l'
+
+ ht <- run $ H.fromList H.hashBS (h:l)
+ e1 <- run $ H.update (fst h) "qqq" ht
+ v1 <- run $ H.lookup (fst h) ht
+ run $ H.delete (fst h) ht
+ v2 <- run $ H.lookup (fst h) ht
+ e2 <- run $ H.update (fst h) "zzz" ht
+ v3 <- run $ H.lookup (fst h) ht
+
+ assert e1
+ assert $ v1 == Just "qqq"
+ assert $ v2 == Nothing
+ assert $ not e2
+ assert $ v3 == Just "zzz"
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
index c2a4a08..ede0839 100644
--- a/test/suite/TestSuite.hs
+++ b/test/suite/TestSuite.hs
@@ -10,7 +10,7 @@ import qualified Network.HTTP.Enumerator as HTTP
import Test.Framework (defaultMain, testGroup)
import Snap.Http.Server.Config
-
+import qualified Data.Concurrent.HashMap.Tests
import qualified Snap.Internal.Http.Parser.Tests
import qualified Snap.Internal.Http.Server.Tests
import qualified Snap.Internal.Http.Server.TimeoutManager.Tests
@@ -45,7 +45,9 @@ main = HTTP.withHttpEnumerator $ do
mapM_ takeMVar $ map snd tinfos
where tests =
- [ testGroup "Snap.Internal.Http.Parser.Tests"
+ [ testGroup "Data.Concurrent.HashMap.Tests"
+ Data.Concurrent.HashMap.Tests.tests
+ , testGroup "Snap.Internal.Http.Parser.Tests"
Snap.Internal.Http.Parser.Tests.tests
, testGroup "Snap.Internal.Http.Server.Tests"
Snap.Internal.Http.Server.Tests.tests
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
