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 ff9db5e3e33ca74661b22edab5be5e3b265f5144 (commit)
from 5514e026237f8b121e9a88b178a32e1b165e1cb4 (commit)
Summary of changes:
snap-server.cabal | 4 +
src/Data/HashMap/Concurrent.hs | 238 +++++++++++++++++++++++++
src/Snap/Internal/Http/Server/LibevBackend.hs | 85 ++--------
test/snap-server-testsuite.cabal | 2 +
test/suite/Data/HashMap/Concurrent/Tests.hs | 31 ++++
test/suite/Snap/Test/Common.hs | 1 -
test/suite/TestSuite.hs | 7 +-
7 files changed, 294 insertions(+), 74 deletions(-)
create mode 100644 src/Data/HashMap/Concurrent.hs
create mode 100644 test/suite/Data/HashMap/Concurrent/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 ff9db5e3e33ca74661b22edab5be5e3b265f5144
Author: Gregory Collins <[email protected]>
Date: Tue Jul 6 23:34:19 2010 -0400
Commit an experimental concurrent HashMap routine
diff --git a/snap-server.cabal b/snap-server.cabal
index a5a3303..36e14d6 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -66,6 +66,8 @@ extra-source-files:
test/runTestsAndCoverage.sh,
test/snap-server-testsuite.cabal,
test/suite/Paths_snap_server.hs,
+ test/suite/Data/HashMap/Concurrent/Tests.hs,
+ test/suite/Snap/Internal/Http/Parser/Tests.hs,
test/suite/Snap/Internal/Http/Parser/Tests.hs,
test/suite/Snap/Internal/Http/Server/Tests.hs,
test/suite/Snap/Test/Common.hs,
@@ -91,6 +93,7 @@ Library
System.FastLogger
other-modules:
+ Data.HashMap.Concurrent,
Paths_snap_server,
Snap.Internal.Http.Parser,
Snap.Internal.Http.Server,
@@ -111,6 +114,7 @@ Library
filepath,
iteratee >= 0.3.1 && <0.4,
monads-fd,
+ murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.*,
old-locale,
snap-core >= 0.2.7 && <0.3,
diff --git a/src/Data/HashMap/Concurrent.hs b/src/Data/HashMap/Concurrent.hs
new file mode 100644
index 0000000..0f82317
--- /dev/null
+++ b/src/Data/HashMap/Concurrent.hs
@@ -0,0 +1,238 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Data.HashMap.Concurrent
+ ( HashMap
+ , new
+ , new'
+ , null
+ , insert
+ , delete
+ , lookup
+ , update
+ , fromList
+ , toList
+ , hashString
+ , hashBS
+ , hashInt ) 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# )
+import Data.Word (Word32, Word64)
+#else
+import Data.Word
+#endif
+
+whichHash :: (a -> Word32) -> (a -> Word64) -> a -> Word
+whichHash as32 as64 x = if bitSize (undefined :: Word) == 32
+ then fromIntegral $ as32 x
+ else fromIntegral $ as64 x
+
+
+hashString :: String -> Word
+hashString = whichHash hashString32 hashString64
+ where
+ hashString32 s = Murmur.asWord32 $ Murmur.hash32 s
+ hashString64 s = Murmur.asWord64 $ Murmur.hash64 s
+{-# INLINE hashString #-}
+
+
+hashInt :: Int -> Word
+hashInt = whichHash h32 h64
+ where
+ h32 x = Murmur.asWord32 $ Murmur.hash32 x
+ h64 x = Murmur.asWord64 $ Murmur.hash64 x
+{-# INLINE hashInt #-}
+
+
+hashBS :: B.ByteString -> Word
+hashBS = whichHash h32 h64
+ where
+ h32 !s = Murmur.asWord32 $ B.foldl' f32 (Murmur.hash32 ([] :: [Int])) s
+ h64 !s = Murmur.asWord64 $ B.foldl' f64 (Murmur.hash64 ([] :: [Int])) s
+
+ f32 !h !c = Murmur.hash32AddInt (fromEnum c) h
+ f64 !h !c = Murmur.hash64AddInt (fromEnum c) h
+{-# 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 [] = []
+ del (x:xs) = if fst x == key then xs else x:(del xs)
+
+
+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/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 9bd3b0d..a1c1c10 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -41,13 +41,8 @@ import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString as B
-import Data.DList (DList)
-import qualified Data.DList as D
import Data.IORef
import Data.Iteratee.WrappedByteString
-import qualified Data.List as List
-import Data.Set (Set)
-import qualified Data.Set as Set
import Data.Typeable
import Foreign hiding (new)
import Foreign.C.Error
@@ -58,6 +53,10 @@ import Network.Socket
import Prelude hiding (catch)
import System.Timeout
------------------------------------------------------------------------------
+
+-- FIXME: should be HashSet, make that later.
+import qualified Data.HashMap.Concurrent as H
+import Data.HashMap.Concurrent (HashMap)
import Snap.Iteratee
import Snap.Internal.Debug
import Snap.Internal.Http.Server.Date
@@ -81,11 +80,7 @@ data Backend = Backend
, _asyncObj :: !EvAsyncPtr
, _killCb :: !(FunPtr AsyncCallback)
, _killObj :: !EvAsyncPtr
- , _connectionThreads :: !(MVar (Set ThreadId))
- , _connThreadEdits :: !(IORef (DList (Set ThreadId -> Set ThreadId)))
- , _connThreadId :: !(MVar ThreadId)
- , _connThreadIsDone :: !(MVar ())
- , _threadActivity :: !(MVar ())
+ , _connectionThreads :: !(HashMap ThreadId ())
, _backendCPU :: !Int
}
@@ -219,11 +214,7 @@ new (sock,sockFd) cpu = do
evIoStart lp accIO
-- thread set stuff
- connThreadMVar <- newEmptyMVar
- connSet <- newMVar Set.empty
- editsRef <- newIORef D.empty
- connThreadDone <- newEmptyMVar
- threadActivity <- newMVar ()
+ connSet <- H.new (H.hashString . show)
let b = Backend sock
sockFd
@@ -238,17 +229,10 @@ new (sock,sockFd) cpu = do
killCB
killObj
connSet
- editsRef
- connThreadMVar
- connThreadDone
- threadActivity
cpu
forkOnIO cpu $ loopThread b
- conntid <- forkOnIO cpu $ connTableSeqThread b
- putMVar connThreadMVar conntid
-
debug $ "Backend.new: loop spawned"
return b
@@ -357,8 +341,8 @@ waitForThreads backend t = timeout t wait >> return ()
where
threadSet = _connectionThreads backend
wait = do
- threads <- readMVar threadSet
- if (Set.null threads)
+ b <- H.null threadSet
+ if b
then return ()
else threadDelay (seconds 1) >> wait
@@ -399,15 +383,6 @@ timerCallback loop tmr ioref tmv _ _ _ = do
evTimerAgain loop tmr
-addThreadSetEdit :: Backend -> (Set ThreadId -> Set ThreadId) -> IO ()
-addThreadSetEdit backend edit = do
- atomicModifyIORef (_connThreadEdits backend) $ \els ->
- (D.snoc els edit, ())
-
- tryPutMVar (_threadActivity backend) ()
- return ()
-
-
freeConnection :: Connection -> IO ()
freeConnection conn = ignoreException $ do
withMVar loopLock $ \_ -> block $ do
@@ -431,8 +406,8 @@ freeConnection conn = ignoreException $ do
tid <- readMVar $ _connThread conn
- -- schedule the removal of the thread id from the backend set
- addThreadSetEdit backend (Set.delete tid)
+ -- removal the thread id from the backend set
+ H.delete tid $ _connectionThreads backend
-- wake up the event loop so it can be apprised of the changes
evAsyncSend loop asyncObj
@@ -456,46 +431,14 @@ ignoreException :: IO () -> IO ()
ignoreException = handle (\(_::SomeException) -> return ())
-connTableSeqThread :: Backend -> IO ()
-connTableSeqThread backend = loop `finally` putMVar threadDone ()
- where
- threadDone = _connThreadIsDone backend
- editsRef = _connThreadEdits backend
- table = _connectionThreads backend
- activity = _threadActivity backend
-
- loop = do
- takeMVar activity
-
- -- grab the edits
- edits <- atomicModifyIORef editsRef $ \t -> (D.empty, D.toList t)
-
- -- apply the edits
- modifyMVar_ table $ \t -> block $ do
- let !t' = List.foldl' (flip ($)) t edits
- return t'
-
- -- zzz
- threadDelay 1000000
- loop
-
-
freeBackend :: Backend -> IO ()
freeBackend backend = ignoreException $ block $ do
-- note: we only get here after an unloop
- readMVar (_connThreadId backend) >>= killThread
- takeMVar $ _connThreadIsDone backend
-
- -- read edits and obtain final thread table
- threads <- withMVar (_connectionThreads backend) $ \table -> do
- edits <- liftM D.toList $
- readIORef (_connThreadEdits backend)
-
- let !t = List.foldl' (flip ($)) table edits
- return $ Set.toList t
- mapM_ killThread threads
+ -- kill everything in thread table
+ tset <- H.toList $ _connectionThreads backend
+ mapM_ (killThread . fst) tset
debug $ "Backend.freeBackend: all threads killed"
debug $ "Backend.freeBackend: destroying resources"
@@ -622,7 +565,7 @@ withConnection backend cpu proc = go
tid <- forkOnIO cpu $ threadProc conn
- addThreadSetEdit backend (Set.insert tid)
+ H.update tid () (_connectionThreads backend)
putMVar thrmv tid
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 0393d9e..97400a9 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -34,6 +34,7 @@ Executable testsuite
HTTP >= 4000.0.9 && < 4001,
HUnit >= 1.2 && < 2,
monads-fd,
+ murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.7,
network-bytestring >= 0.1.2 && < 0.2,
old-locale,
@@ -91,6 +92,7 @@ Executable pongserver
old-locale,
parallel > 2,
iteratee >= 0.3.1 && < 0.4,
+ murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.7,
network-bytestring >= 0.1.2 && < 0.2,
snap-core >= 0.2.7 && <0.3,
diff --git a/test/suite/Data/HashMap/Concurrent/Tests.hs
b/test/suite/Data/HashMap/Concurrent/Tests.hs
new file mode 100644
index 0000000..025b5a8
--- /dev/null
+++ b/test/suite/Data/HashMap/Concurrent/Tests.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PackageImports #-}
+
+module Data.HashMap.Concurrent.Tests
+ ( tests ) where
+
+import Data.List
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+
+import qualified Data.HashMap.Concurrent as H
+
+tests :: [Test]
+tests = [ testFromTo ]
+
+
+testFromTo :: Test
+testFromTo = testProperty "HashMap/fromList/toList" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop l = do
+ ht <- run $ H.fromList H.hashInt (l :: [(Int,Int)])
+ l' <- run $ H.toList ht
+
+ let s1 = sort l
+ let s2 = sort l'
+
+ assert $ s1 == s2
diff --git a/test/suite/Snap/Test/Common.hs b/test/suite/Snap/Test/Common.hs
index 5c6a19e..65f3124 100644
--- a/test/suite/Snap/Test/Common.hs
+++ b/test/suite/Snap/Test/Common.hs
@@ -7,7 +7,6 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w)
import Test.QuickCheck
-import Test.QuickCheck.Gen
instance Arbitrary S.ByteString where
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
index 4df07fb..226dd43 100644
--- a/test/suite/TestSuite.hs
+++ b/test/suite/TestSuite.hs
@@ -2,12 +2,15 @@ module Main where
import Test.Framework (defaultMain, testGroup)
+import qualified Data.HashMap.Concurrent.Tests
import qualified Snap.Internal.Http.Parser.Tests
import qualified Snap.Internal.Http.Server.Tests
+
main :: IO ()
main = defaultMain tests
- where tests = [
- testGroup "Snap.Internal.Http.Parser.Tests"
+ where tests = [ testGroup "Data.HashMap.Concurrent.Tests"
+ Data.HashMap.Concurrent.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
