http2 1.4.2 → 1.4.3
raw patch · 13 files changed
+1242/−232 lines, 13 files
Files
- ChangeLog.md +9/−0
- Network/HTTP2/Priority/PSQ.hs +8/−5
- bench-priority/BinaryHeap.hs +173/−0
- bench-priority/BinaryHeapSTM.hs +170/−0
- bench-priority/DoublyLinkedQueueIO.hs +85/−0
- bench-priority/Heap.hs +118/−0
- bench-priority/Main.hs +233/−0
- bench-priority/RandomSkewHeap.hs +107/−0
- bench-priority/RingOfQueues.hs +156/−0
- bench-priority/RingOfQueuesSTM.hs +149/−0
- bench/Main.hs +0/−225
- http2.cabal +10/−2
- test/HTTP2/PrioritySpec.hs +24/−0
ChangeLog.md view
@@ -1,3 +1,12 @@+## 1.4.3++* Priority benchmark is now external information versions.+* Using proper baseDeficit for deletion.++## 1.4.2++* Test files are now self-contained.+ ## 1.4.1 * The reverse indices for static and dynamic are combined for performance.
Network/HTTP2/Priority/PSQ.hs view
@@ -6,7 +6,7 @@ Key , Precedence(..) , newPrecedence- , PriorityQueue+ , PriorityQueue(..) , empty , isEmpty , enqueue@@ -118,10 +118,13 @@ in Just (k, p, v, PriorityQueue base queue') delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)-delete k PriorityQueue{..} = case P.findMin queue' of- Nothing -> (mv, empty)- Just (_,p,_) -> (mv, PriorityQueue (deficit p) queue')+delete k q@PriorityQueue{..} = case P.alter f k queue of+ (mv@(Just _), queue') -> case P.minView queue of+ Nothing -> error "delete"+ Just (k',p',_,_)+ | k' == k -> (mv, PriorityQueue (deficit p') queue')+ | otherwise -> (mv, PriorityQueue baseDeficit queue')+ (Nothing, _) -> (Nothing, q) where- (!mv,!queue') = P.alter f k queue f Nothing = (Nothing, Nothing) f (Just (_,v)) = (Just v, Nothing)
+ bench-priority/BinaryHeap.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++module BinaryHeap (+ Entry+ , newEntry+ , renewEntry+ , item+ , PriorityQueue(..)+ , new+ , enqueue+ , dequeue+ , delete+ ) where++import Control.Monad (when, void)+import Data.Array (Array, listArray, (!))+import Data.Array.IO (IOArray)+import Data.Array.MArray (newArray_, readArray, writeArray)+import Data.IORef+import Data.Word (Word64)++----------------------------------------------------------------++type Weight = Int+type Deficit = Word64++-- | Abstract data type of entries for priority queues.+-- This does not contain Key because Entry is assumed to be stored+-- in HTTP/2 stream information, too.+data Entry a = Entry {+ weight :: {-# UNPACK #-} !Weight+ , item :: {-# UNPACK #-} !(IORef a) -- ^ Extracting an item from an entry.+ , deficit :: {-# UNPACK #-} !(IORef Deficit)+ , index :: {-# UNPACK #-} !(IORef Index)+ }++newEntry :: a -> Weight -> IO (Entry a)+newEntry x w = Entry w <$> newIORef x <*> newIORef magicDeficit <*> newIORef (-1)++-- | Changing the item of an entry.+renewEntry :: Entry a -> a -> IO ()+renewEntry Entry{..} x = writeIORef item x++----------------------------------------------------------------++type Index = Int+type MA a = IOArray Index (Entry a)++-- FIXME: The base (Word64) would be overflowed.+-- In that case, the heap must be re-constructed.+data PriorityQueue a = PriorityQueue (IORef Deficit)+ (IORef Index)+ (MA a)++----------------------------------------------------------------++magicDeficit :: Deficit+magicDeficit = 0++deficitSteps :: Int+deficitSteps = 65536++deficitList :: [Deficit]+deficitList = map calc idxs+ where+ idxs = [1..256] :: [Double]+ calc w = round (fromIntegral deficitSteps / w)++deficitTable :: Array Index Deficit+deficitTable = listArray (1,256) deficitList++weightToDeficit :: Weight -> Deficit+weightToDeficit w = deficitTable ! w++----------------------------------------------------------------++new :: Int -> IO (PriorityQueue a)+new n = PriorityQueue <$> newIORef 0+ <*> newIORef 1+ <*> newArray_ (1,n)++-- | Enqueuing an entry. PriorityQueue is updated.+enqueue :: Entry a -> PriorityQueue a -> IO ()+enqueue ent@Entry{..} (PriorityQueue bref idx arr) = do+ i <- readIORef idx+ base <- readIORef bref+ d <- readIORef deficit+ let !b = if d == magicDeficit then base else d+ !d' = b + weightToDeficit weight+ writeIORef deficit d'+ write arr i ent+ shiftUp arr i+ let !i' = i + 1+ writeIORef idx i'+ return ()++-- | Dequeuing an entry. PriorityQueue is updated.+dequeue :: PriorityQueue a -> IO (Entry a)+dequeue (PriorityQueue bref idx arr) = do+ ent <- shrink arr 1 idx+ i <- readIORef idx+ shiftDown arr 1 i+ d <- readIORef $ deficit ent+ writeIORef bref $ if i == 1 then 0 else d+ return ent++shrink :: MA a -> Index -> IORef Index -> IO (Entry a)+shrink arr r idx = do+ entr <- readArray arr r+ -- fixme: checking if i == 0+ i <- subtract 1 <$> readIORef idx+ xi <- readArray arr i+ write arr r xi+ writeIORef idx i+ return entr++shiftUp :: MA a -> Int -> IO ()+shiftUp _ 1 = return ()+shiftUp arr c = do+ swapped <- swap arr p c+ when swapped $ shiftUp arr p+ where+ p = c `div` 2++shiftDown :: MA a -> Int -> Int -> IO ()+shiftDown arr p n+ | c1 > n = return ()+ | c1 == n = void $ swap arr p c1+ | otherwise = do+ let !c2 = c1 + 1+ xc1 <- readArray arr c1+ xc2 <- readArray arr c2+ d1 <- readIORef $ deficit xc1+ d2 <- readIORef $ deficit xc2+ let !c = if d1 < d2 then c1 else c2+ swapped <- swap arr p c+ when swapped $ shiftDown arr c n+ where+ c1 = 2 * p++{-# INLINE swap #-}+swap :: MA a -> Index -> Index -> IO Bool+swap arr p c = do+ xp <- readArray arr p+ xc <- readArray arr c+ dp <- readIORef $ deficit xp+ dc <- readIORef $ deficit xc+ if dc < dp then do+ write arr c xp+ write arr p xc+ return True+ else+ return False++{-# INLINE write #-}+write :: MA a -> Index -> Entry a -> IO ()+write arr i ent = do+ writeArray arr i ent+ writeIORef (index ent) i++delete :: Entry a -> PriorityQueue a -> IO ()+delete ent pq@(PriorityQueue _ idx arr) = do+ i <- readIORef $ index ent+ if i == 1 then+ void $ dequeue pq+ else do+ entr <- shrink arr i idx+ r <- readIORef $ index entr+ shiftDown arr r (i - 1)+ shiftUp arr r
+ bench-priority/BinaryHeapSTM.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++module BinaryHeapSTM (+ Entry+ , newEntry+ , renewEntry+ , item+ , PriorityQueue(..)+ , new+ , enqueue+ , dequeue+ , delete+ ) where++import Control.Concurrent.STM+import Control.Monad (when, void)+import Data.Array (Array, listArray, (!))+import Data.Array.MArray (newArray_, readArray, writeArray)+import Data.Word (Word64)++----------------------------------------------------------------++type Weight = Int+type Deficit = Word64++-- | Abstract data type of entries for priority queues.+data Entry a = Entry {+ weight :: {-# UNPACK #-} !Weight+ , item :: {-# UNPACK #-} !(TVar a) -- ^ Extracting an item from an entry.+ , deficit :: {-# UNPACK #-} !(TVar Deficit)+ , index :: {-# UNPACK #-} !(TVar Index)+ }++newEntry :: a -> Weight -> STM (Entry a)+newEntry x w = Entry w <$> newTVar x <*> newTVar magicDeficit <*> newTVar (-1)++-- | Changing the item of an entry.+renewEntry :: Entry a -> a -> STM ()+renewEntry Entry{..} x = writeTVar item x++----------------------------------------------------------------++type Index = Int+type MA a = TArray Index (Entry a)++-- FIXME: The base (Word64) would be overflowed.+-- In that case, the heap must be re-constructed.+data PriorityQueue a = PriorityQueue (TVar Deficit)+ (TVar Index)+ (MA a)++----------------------------------------------------------------++magicDeficit :: Deficit+magicDeficit = 0++deficitSteps :: Int+deficitSteps = 65536++deficitList :: [Deficit]+deficitList = map calc idxs+ where+ idxs = [1..256] :: [Double]+ calc w = round (fromIntegral deficitSteps / w)++deficitTable :: Array Index Deficit+deficitTable = listArray (1,256) deficitList++weightToDeficit :: Weight -> Deficit+weightToDeficit w = deficitTable ! w++----------------------------------------------------------------++new :: Int -> STM (PriorityQueue a)+new n = PriorityQueue <$> newTVar 0+ <*> newTVar 1+ <*> newArray_ (1,n)++-- | Enqueuing an entry. PriorityQueue is updated.+enqueue :: Entry a -> PriorityQueue a -> STM ()+enqueue ent@Entry{..} (PriorityQueue bref idx arr) = do+ i <- readTVar idx+ base <- readTVar bref+ d <- readTVar deficit+ let !b = if d == magicDeficit then base else d+ !d' = b + weightToDeficit weight+ writeTVar deficit d'+ write arr i ent+ shiftUp arr i+ let !i' = i + 1+ writeTVar idx i'+ return ()++-- | Dequeuing an entry. PriorityQueue is updated.+dequeue :: PriorityQueue a -> STM (Entry a)+dequeue (PriorityQueue bref idx arr) = do+ ent <- shrink arr 1 idx+ i <- readTVar idx+ shiftDown arr 1 i+ d <- readTVar $ deficit ent+ writeTVar bref $ if i == 1 then 0 else d+ return ent++shrink :: MA a -> Index -> TVar Index -> STM (Entry a)+shrink arr r idx = do+ entr <- readArray arr r+ -- fixme: checking if i == 0+ i <- subtract 1 <$> readTVar idx+ xi <- readArray arr i+ write arr r xi+ writeTVar idx i+ return entr++shiftUp :: MA a -> Int -> STM ()+shiftUp _ 1 = return ()+shiftUp arr c = do+ swapped <- swap arr p c+ when swapped $ shiftUp arr p+ where+ p = c `div` 2++shiftDown :: MA a -> Int -> Int -> STM ()+shiftDown arr p n+ | c1 > n = return ()+ | c1 == n = void $ swap arr p c1+ | otherwise = do+ let !c2 = c1 + 1+ xc1 <- readArray arr c1+ xc2 <- readArray arr c2+ d1 <- readTVar $ deficit xc1+ d2 <- readTVar $ deficit xc2+ let !c = if d1 < d2 then c1 else c2+ swapped <- swap arr p c+ when swapped $ shiftDown arr c n+ where+ c1 = 2 * p++{-# INLINE swap #-}+swap :: MA a -> Index -> Index -> STM Bool+swap arr p c = do+ xp <- readArray arr p+ xc <- readArray arr c+ dp <- readTVar $ deficit xp+ dc <- readTVar $ deficit xc+ if dc < dp then do+ write arr c xp+ write arr p xc+ return True+ else+ return False++{-# INLINE write #-}+write :: MA a -> Index -> Entry a -> STM ()+write arr i ent = do+ writeArray arr i ent+ writeTVar (index ent) i++delete :: Entry a -> PriorityQueue a -> STM ()+delete ent pq@(PriorityQueue _ idx arr) = do+ i <- readTVar $ index ent+ if i == 1 then+ void $ dequeue pq+ else do+ entr <- shrink arr i idx+ r <- readTVar $ index entr+ shiftDown arr r (i - 1)+ shiftUp arr r
+ bench-priority/DoublyLinkedQueueIO.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RecordWildCards #-}++module DoublyLinkedQueueIO (+ Queue+ , Node+ , item+ , new+ , isEmpty+ , enqueue+ , dequeue+ , delete+ ) where++import Data.IORef++data Queue a = Queue {+ entr :: Node a+ , exit :: Node a+ }++data Node a = Node {+ item :: a+ , prev :: {-# UNPACK #-} !(IORef (Node a))+ , next :: {-# UNPACK #-} !(IORef (Node a))+ } deriving Eq++newNode :: a -> IO (Node a)+newNode x = Node x <$> newIORef undefined <*> newIORef undefined++{-# INLINE getNext #-}+getNext :: Node a -> IO (Node a)+getNext Node{..} = readIORef next++{-# INLINE setNext #-}+setNext :: Node a -> Node a -> IO ()+setNext Node{..} x = writeIORef next x++{-# INLINE getPrev #-}+getPrev :: Node a -> IO (Node a)+getPrev Node{..} = readIORef prev++{-# INLINE setPrev #-}+setPrev :: Node a -> Node a -> IO ()+setPrev Node{..} x = writeIORef prev x++new :: IO (Queue a)+new = do+ a1 <- newNode undefined+ a2 <- newNode undefined+ setPrev a1 a2+ setNext a1 a2+ setPrev a2 a1+ setNext a2 a1+ return $! Queue a1 a2++isEmpty :: Queue a -> IO Bool+isEmpty Queue{..} = do+ n <- getNext entr+ nn <- getNext n+ return $! next entr == next nn++enqueue :: a -> Queue a -> IO (Node a)+enqueue a Queue{..} = do+ x <- newNode a+ n <- getNext entr+ setPrev x entr+ setNext x n+ setPrev n x+ setNext entr x+ return x++dequeue :: Queue a -> IO a+dequeue Queue{..} = do+ p <- getPrev exit+ pp <- getPrev p+ setPrev exit pp+ setNext pp exit+ return $! item p++delete :: Node a -> IO ()+delete x = do+ p <- getPrev x+ n <- getNext x+ setNext p n+ setPrev n p
+ bench-priority/Heap.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module Heap (+ PriorityQueue(..)+ , Precedence(..)+ , newPrecedence+ , empty+ , isEmpty+ , enqueue+ , dequeue+ , delete+ ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative ((<$>))+#endif+import Data.Array (Array, listArray, (!))+import Data.Heap (Heap)+import qualified Data.Heap as H+import Data.Word (Word64)++----------------------------------------------------------------++type Key = Int+type Weight = Int+type Deficit = Word64++data Precedence = Precedence {+ deficit :: {-# UNPACK #-} !Deficit+ , weight :: {-# UNPACK #-} !Weight+ -- stream dependency, used by the upper layer+ , dependency :: {-# UNPACK #-} !Key+ } deriving Show++-- | For test only+newPrecedence :: Weight -> Precedence+newPrecedence w = Precedence 0 w 0++instance Eq Precedence where+ Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2++instance Ord Precedence where+ Precedence d1 _ _ < Precedence d2 _ _ = d1 < d2+ Precedence d1 _ _ <= Precedence d2 _ _ = d1 <= d2++data Entry a = Entry Key Precedence a++instance Eq (Entry a) where+ Entry _ p1 _ == Entry _ p2 _ = p1 == p2++instance Ord (Entry a) where+ Entry _ p1 _ < Entry _ p2 _ = p1 < p2+ Entry _ p1 _ <= Entry _ p2 _ = p1 <= p2++-- FIXME: The base (Word64) would be overflowed.+-- In that case, the heap must be re-constructed.+data PriorityQueue a = PriorityQueue {+ baseDeficit :: {-# UNPACK #-} !Deficit+ , queue :: Heap (Entry a)+ }++----------------------------------------------------------------++magicDeficit :: Deficit+magicDeficit = 0++deficitSteps :: Int+deficitSteps = 65536++deficitList :: [Deficit]+deficitList = map calc idxs+ where+ idxs = [1..256] :: [Double]+ calc w = round (fromIntegral deficitSteps / w)++deficitTable :: Array Int Deficit+deficitTable = listArray (1,256) deficitList++weightToDeficit :: Weight -> Deficit+weightToDeficit w = deficitTable ! w++----------------------------------------------------------------++empty :: PriorityQueue a+empty = PriorityQueue 0 H.empty++isEmpty :: PriorityQueue a -> Bool+isEmpty (PriorityQueue _ h) = H.null h++enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a+enqueue k p v PriorityQueue{..} = PriorityQueue b queue'+ where+ !b = if deficit p == magicDeficit then baseDeficit else deficit p+ !deficit' = b + weightToDeficit (weight p)+ !p' = p { deficit = deficit' }+ !queue' = H.insert (Entry k p' v) queue++dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a)+dequeue (PriorityQueue _ heap) = case H.uncons heap of+ Nothing -> Nothing+ Just (Entry k p v, heap')+ | H.null heap' -> Just (k, p, v, empty) -- reset the deficit base+ | otherwise -> Just (k, p, v, PriorityQueue (deficit p) heap')++delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)+delete k (PriorityQueue base heap) = (mv, PriorityQueue base' heap')+ where+ !(h,heap') = H.partition (\(Entry k' _ _) -> k' == k) heap+ mv = case H.viewMin h of+ Nothing -> Nothing+ Just (Entry _ _ v, _) -> Just v+ base' = case H.viewMin heap of+ Nothing -> base+ Just (Entry k' p _, _)+ | k == k' -> deficit p+ | otherwise -> base
+ bench-priority/Main.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE BangPatterns #-}++module Main where++import Control.Concurrent.STM+import Criterion.Main+import Data.List (foldl')+import System.Random++import qualified RingOfQueuesSTM as A+import qualified RingOfQueues as AIO+import qualified BinaryHeapSTM as B+import qualified BinaryHeap as BIO+import qualified Heap as O+import qualified Network.HTTP2.Priority.PSQ as P+import qualified RandomSkewHeap as R++type Key = Int+type Weight = Int++numOfStreams :: Int+numOfStreams = 100++numOfTrials :: Int+numOfTrials = 10000++main :: IO ()+main = do+ gen <- getStdGen+ let ks = [1,3..]+ ws = take numOfStreams $ randomRs (1,256) gen+ xs = zip ks ws+ defaultMain [+ bgroup "enqueue & dequeue" [+ bench "Random Skew Heap" $ whnf enqdeqR xs+ , bench "Skew Binomial Heap" $ whnf enqdeqO xs+ , bench "Priority Search Queue" $ whnf enqdeqP xs+ , bench "Binary Heap" $ nfIO (enqdeqBIO xs)+ , bench "Binary Heap STM" $ nfIO (enqdeqB xs)+ , bench "Ring of Queues" $ nfIO (enqdeqAIO xs)+ , bench "Ring of Queues STM" $ nfIO (enqdeqA xs)+ ]+ , bgroup "delete" [+ bench "Random Skew Heap" $ whnf deleteR xs+ , bench "Skew Binomial Heap" $ whnf deleteO xs+ , bench "Priority Search Queue" $ whnf deleteP xs+ , bench "Binary Heap" $ nfIO (deleteBIO xs)+ , bench "Binary Heap STM" $ nfIO (deleteB xs)+ , bench "Ring of Queues IO" $ nfIO (deleteAIO xs)+ ]+ ]++----------------------------------------------------------------++enqdeqR :: [(Key,Weight)] -> ()+enqdeqR xs = loop pq numOfTrials+ where+ !pq = createR xs R.empty+ loop _ 0 = ()+ loop q !n = case R.dequeue q of+ Nothing -> error "enqdeqR"+ Just (k,w,v,q') -> let !q'' = R.enqueue k w v q'+ in loop q'' (n - 1)++deleteR :: [(Key,Weight)] -> R.PriorityQueue Int+deleteR xs = foldl' (\q k -> let (_,!q') = R.delete k q in q') pq ks+ where+ !pq = createR xs R.empty+ (ks,_) = unzip xs++createR :: [(Key,Weight)] -> R.PriorityQueue Int -> R.PriorityQueue Int+createR [] !q = q+createR ((k,w):xs) !q = createR xs q'+ where+ !v = k+ !q' = R.enqueue k w v q++----------------------------------------------------------------++enqdeqO :: [(Key,Weight)] -> O.PriorityQueue Int+enqdeqO xs = loop pq numOfTrials+ where+ !pq = createO xs O.empty+ loop !q 0 = q+ loop !q !n = case O.dequeue q of+ Nothing -> error "enqdeqO"+ Just (k,p,v,q') -> loop (O.enqueue k p v q') (n - 1)++deleteO :: [(Key,Weight)] -> O.PriorityQueue Int+deleteO xs = foldl' (\q k -> let (_,!q') = O.delete k q in q') pq ks+ where+ !pq = createO xs O.empty+ (ks,_) = unzip xs++createO :: [(Key,Weight)] -> O.PriorityQueue Int -> O.PriorityQueue Int+createO [] !q = q+createO ((k,w):xs) !q = createO xs q'+ where+ !pre = O.newPrecedence w+ !v = k+ !q' = O.enqueue k pre v q++----------------------------------------------------------------++enqdeqP :: [(Key,Weight)] -> P.PriorityQueue Int+enqdeqP xs = loop pq numOfTrials+ where+ !pq = createP xs P.empty+ loop !q 0 = q+ loop !q !n = case P.dequeue q of+ Nothing -> error "enqdeqP"+ Just (k,pre,x,q') -> loop (P.enqueue k pre x q') (n - 1)++deleteP :: [(Key,Weight)] -> P.PriorityQueue Int+deleteP xs = foldl' (\q k -> let (_,!q') = P.delete k q in q') pq ks+ where+ !pq = createP xs P.empty+ (ks,_) = unzip xs++createP :: [(Key,Weight)] -> P.PriorityQueue Int -> P.PriorityQueue Int+createP [] !q = q+createP ((k,w):xs) !q = createP xs q'+ where+ !pre = P.newPrecedence w+ !v = k+ !q' = P.enqueue k pre v q++----------------------------------------------------------------++enqdeqB :: [(Key,Weight)] -> IO ()+enqdeqB xs = do+ q <- atomically (B.new numOfStreams)+ _ <- createB xs q+ loop q numOfTrials+ where+ loop _ 0 = return ()+ loop q !n = do+ ent <- atomically $ B.dequeue q+ atomically $ B.enqueue ent q+ loop q (n - 1)++deleteB :: [(Key,Weight)] -> IO ()+deleteB xs = do+ q <- atomically $ B.new numOfStreams+ ents <- createB xs q+ mapM_ (\ent -> atomically $ B.delete ent q) ents++createB :: [(Key,Weight)] -> B.PriorityQueue Int -> IO ([B.Entry Key])+createB [] _ = return []+createB ((k,w):xs) !q = do+ ent <- atomically $ B.newEntry k w+ atomically $ B.enqueue ent q+ ents <- createB xs q+ return $ ent:ents++----------------------------------------------------------------++enqdeqBIO :: [(Key,Weight)] -> IO ()+enqdeqBIO xs = do+ q <- BIO.new numOfStreams+ _ <- createBIO xs q+ loop q numOfTrials+ where+ loop _ 0 = return ()+ loop q !n = do+ ent <- BIO.dequeue q+ BIO.enqueue ent q+ loop q (n - 1)++deleteBIO :: [(Key,Weight)] -> IO ()+deleteBIO xs = do+ q <- BIO.new numOfStreams+ ents <- createBIO xs q+ mapM_ (\ent -> BIO.delete ent q) ents++createBIO :: [(Key,Weight)] -> BIO.PriorityQueue Int -> IO ([BIO.Entry Key])+createBIO [] _ = return []+createBIO ((k,w):xs) !q = do+ ent <- BIO.newEntry k w+ BIO.enqueue ent q+ ents <- createBIO xs q+ return $ ent:ents++----------------------------------------------------------------++enqdeqA :: [(Key,Weight)] -> IO ()+enqdeqA ws = do+ q <- atomically A.new+ createA ws q+ loop q numOfTrials+ where+ loop _ 0 = return ()+ loop q !n = do+ ent <- atomically $ A.dequeue q+ atomically $ A.enqueue ent q+ loop q (n - 1)++createA :: [(Key,Weight)] -> A.PriorityQueue Int -> IO ()+createA [] _ = return ()+createA ((k,w):xs) !q = do+ let !ent = A.newEntry k w+ atomically $ A.enqueue ent q+ createA xs q++----------------------------------------------------------------++enqdeqAIO :: [(Key,Weight)] -> IO ()+enqdeqAIO xs = do+ q <- AIO.new+ _ <- createAIO xs q+ loop q numOfTrials+ where+ loop _ 0 = return ()+ loop q !n = do+ Just ent <- AIO.dequeue q+ _ <- AIO.enqueue ent q+ loop q (n - 1)++deleteAIO :: [(Key,Weight)] -> IO ()+deleteAIO xs = do+ q <- AIO.new+ ns <- createAIO xs q+ mapM_ AIO.delete ns++createAIO :: [(Key,Weight)] -> AIO.PriorityQueue Int -> IO [AIO.Node (AIO.Entry Weight)]+createAIO [] _ = return []+createAIO ((k,w):xs) !q = do+ let !ent = AIO.newEntry k w+ n <- AIO.enqueue ent q+ ns <- createAIO xs q+ return $ n : ns++----------------------------------------------------------------
+ bench-priority/RandomSkewHeap.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE BangPatterns #-}++-- This data structure is based on skew heap.+--+-- If we take weight as priority, a typical heap (priority queue)+-- is not fair enough. Consider two weight 201 for A and 101 for B.+-- A typical heap would generate A(201), A(200), A(199), A(198), ....,+-- and finaly A(101), B(101), A(100), B(100).+-- What we want is A, A, B, A, A, B...+--+-- So, we introduce randomness to Skew Heap.+--+-- In the random binary tree,+-- an element is selected as the root with probability of+-- 1 / (n + 1) where n is the size of the original tree.+-- In the random skew heap, an element is selected as the root+-- with the probability of weight / total_weight.+--+-- Since this data structure uses random numbers, APIs should be+-- essentially impure. But since this is used with STM,+-- APIs are made to be pure with unsafePerformIO.++module RandomSkewHeap (+ PriorityQueue+ , empty+ , isEmpty+ , enqueue+ , dequeue+ , delete+ ) where++import Data.List (partition)+import System.IO.Unsafe (unsafePerformIO)+import System.Random.MWC (createSystemRandom, uniformR, GenIO)++----------------------------------------------------------------++type Key = Int+type Weight = Int++----------------------------------------------------------------++data PriorityQueue a = Leaf | Node {-# UNPACK #-} !Weight -- total+ {-# UNPACK #-} !Key+ {-# UNPACK #-} !Weight+ !a+ !(PriorityQueue a)+ !(PriorityQueue a) deriving Show++----------------------------------------------------------------++empty :: PriorityQueue a+empty = Leaf++isEmpty :: PriorityQueue a -> Bool+isEmpty Leaf = True+isEmpty _ = False++singleton :: Key -> Weight -> a -> PriorityQueue a+singleton k w v = Node w k w v Leaf Leaf++----------------------------------------------------------------++enqueue :: Key -> Weight -> a -> PriorityQueue a -> PriorityQueue a+enqueue k w v q = merge (singleton k w v) q++-- if l is a singleton, w1 == tw1.+merge :: PriorityQueue t -> PriorityQueue t -> PriorityQueue t+merge t Leaf = t+merge Leaf t = t+merge l@(Node tw1 k1 w1 v1 ll lr) r@(Node tw2 k2 w2 v2 rl rr)+ | g <= w1 = Node tw k1 w1 v1 lr $ merge ll r+ | otherwise = Node tw k2 w2 v2 rr $ merge rl l+ where+ tw = tw1 + tw2+ g = unsafePerformIO $ uniformR (1,tw) gen+{-# NOINLINE merge #-}++dequeue :: PriorityQueue a -> Maybe (Key, Weight, a, PriorityQueue a)+dequeue Leaf = Nothing+dequeue (Node _ k w v l r) = Just (k, w, v, t)+ where+ !t = merge l r++delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)+delete k q = (mv, fromList xs')+ where+ !xs = toList q+ (!ds,!xs') = partition (\(k',_,_) -> k' == k) xs+ mv = case ds of+ [] -> Nothing+ ((_,_,v):_) -> Just v++toList :: PriorityQueue a -> [(Key, Weight, a)]+toList q = go q id []+ where+ go Leaf b = b+ go (Node _ k w v l r) b = go r (go l (((k,w,v) :) . b))++fromList :: [(Key, Weight, a)] -> PriorityQueue a+fromList xs = go empty xs+ where+ go !q [] = q+ go !q ((k,w,v):xks) = go (enqueue k w v q) xks++gen :: GenIO+gen = unsafePerformIO createSystemRandom
+ bench-priority/RingOfQueues.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++-- Haskell implementation of H2O's priority queue.+-- https://github.com/h2o/h2o/blob/master/lib/http2/scheduler.c++module RingOfQueues (+ Entry+ , newEntry+ , renewEntry+ , item+ , Node+ , PriorityQueue(..)+ , new+ , enqueue+ , dequeue+ , delete+ ) where++import Control.Monad (replicateM)+import Data.Array (Array, listArray, (!))+import Data.Bits (setBit, clearBit, shiftR)+import Data.IORef+import Data.Word (Word64)+import Foreign.C.Types (CLLong(..))++import DoublyLinkedQueueIO (Queue, Node)+import qualified DoublyLinkedQueueIO as Q++----------------------------------------------------------------++type Weight = Int++-- | Abstract data type of entries for priority queues.+data Entry a = Entry {+ item :: a -- ^ Extracting an item from an entry.+ , weight :: {-# UNPACK #-} !Weight+ , deficit :: {-# UNPACK #-} !Int+ } deriving Show++newEntry :: a -> Weight -> Entry a+newEntry x w = Entry x w 0++-- | Changing the item of an entry.+renewEntry :: Entry a -> b -> Entry b+renewEntry ent x = ent { item = x }++----------------------------------------------------------------++data PriorityQueue a = PriorityQueue {+ bitsRef :: IORef Word64+ , offsetRef :: IORef Int+ , queues :: Array Int (Queue (Entry a))+ }++----------------------------------------------------------------++bitWidth :: Int+bitWidth = 64++relativeIndex :: Int -> Int -> Int+relativeIndex idx offset = (offset + idx) `mod` bitWidth++----------------------------------------------------------------++deficitSteps :: Int+deficitSteps = 65536++deficitList :: [Int]+deficitList = map calc idxs+ where+ idxs :: [Double]+ idxs = [1..256]+ calc w = round (65536 * 63 / w)++deficitTable :: Array Int Int+deficitTable = listArray (1,256) deficitList++----------------------------------------------------------------++-- https://en.wikipedia.org/wiki/Find_first_set+foreign import ccall unsafe "strings.h ffsll"+ c_ffs :: CLLong -> CLLong++-- | Finding first bit set. O(1)+--+-- >>> firstBitSet $ setBit 0 63+-- 63+-- >>> firstBitSet $ setBit 0 62+-- 62+-- >>> firstBitSet $ setBit 0 1+-- 1+-- >>> firstBitSet $ setBit 0 0+-- 0+-- >>> firstBitSet 0+-- -1+firstBitSet :: Word64 -> Int+firstBitSet x = ffs x - 1+ where+ ffs = fromIntegral . c_ffs . fromIntegral++----------------------------------------------------------------++new :: IO (PriorityQueue a)+new = PriorityQueue <$> newIORef 0 <*> newIORef 0 <*> newQueues+ where+ newQueues = listArray (0, bitWidth - 1) <$> replicateM bitWidth Q.new++-- | Enqueuing an entry. PriorityQueue is updated.+enqueue :: Entry a -> PriorityQueue a -> IO (Node (Entry a))+enqueue ent PriorityQueue{..} = do+ let (!idx,!deficit') = calcIdxAndDeficit+ !offidx <- getOffIdx idx+ node <- push offidx ent { deficit = deficit' }+ updateBits idx+ return node+ where+ calcIdxAndDeficit = total `divMod` deficitSteps+ where+ total = deficitTable ! weight ent + deficit ent+ getOffIdx idx = relativeIndex idx <$> readIORef offsetRef+ push offidx ent' = Q.enqueue ent' (queues ! offidx)+ updateBits idx = modifyIORef' bitsRef $ flip setBit idx++-- | Dequeuing an entry. PriorityQueue is updated.+dequeue :: PriorityQueue a -> IO (Maybe (Entry a))+dequeue pq@PriorityQueue{..} = do+ !idx <- getIdx+ if idx == -1 then+ return Nothing+ else do+ !offidx <- getOffIdx idx+ updateOffset offidx+ queueIsEmpty <- checkEmpty offidx+ updateBits idx queueIsEmpty+ if queueIsEmpty then+ dequeue pq+ else+ Just <$> pop offidx+ where+ getIdx = firstBitSet <$> readIORef bitsRef+ getOffIdx idx = relativeIndex idx <$> readIORef offsetRef+ pop offidx = Q.dequeue (queues ! offidx)+ checkEmpty offidx = Q.isEmpty (queues ! offidx)+ updateOffset offset' = writeIORef offsetRef offset'+ updateBits idx isEmpty = modifyIORef' bitsRef shiftClear+ where+ shiftClear bits+ | isEmpty = clearBit (shiftR bits idx) 0+ | otherwise = shiftR bits idx++-- bits is not updated because it's difficult.+delete :: Node (Entry a) -> IO ()+delete node = Q.delete node
+ bench-priority/RingOfQueuesSTM.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++-- Haskell implementation of H2O's priority queue.+-- https://github.com/h2o/h2o/blob/master/lib/http2/scheduler.c++-- delete is not supported because TQueue does not support deletion.+-- So, key is not passed to enqueue.++module RingOfQueuesSTM (+ Entry+ , newEntry+ , renewEntry+ , item+ , PriorityQueue(..)+ , new+ , enqueue+ , dequeue+ ) where++import Control.Concurrent.STM+import Control.Monad (replicateM)+import Data.Array (Array, listArray, (!))+import Data.Bits (setBit, clearBit, shiftR)+import Data.Word (Word64)+import Foreign.C.Types (CLLong(..))++----------------------------------------------------------------++type Weight = Int++-- | Abstract data type of entries for priority queues.+data Entry a = Entry {+ item :: a -- ^ Extracting an item from an entry.+ , weight :: {-# UNPACK #-} !Weight+ , deficit :: {-# UNPACK #-} !Int+ } deriving Show++newEntry :: a -> Weight -> Entry a+newEntry x w = Entry x w 0++-- | Changing the item of an entry.+renewEntry :: Entry a -> b -> Entry b+renewEntry ent x = ent { item = x }++----------------------------------------------------------------++data PriorityQueue a = PriorityQueue {+ bitsRef :: TVar Word64+ , offsetRef :: TVar Int+ , queues :: Array Int (TQueue (Entry a))+ }++----------------------------------------------------------------++bitWidth :: Int+bitWidth = 64++relativeIndex :: Int -> Int -> Int+relativeIndex idx offset = (offset + idx) `mod` bitWidth++----------------------------------------------------------------++deficitSteps :: Int+deficitSteps = 65536++deficitList :: [Int]+deficitList = map calc idxs+ where+ idxs :: [Double]+ idxs = [1..256]+ calc w = round (65536 * 63 / w)++deficitTable :: Array Int Int+deficitTable = listArray (1,256) deficitList++----------------------------------------------------------------++-- https://en.wikipedia.org/wiki/Find_first_set+foreign import ccall unsafe "strings.h ffsll"+ c_ffs :: CLLong -> CLLong++-- | Finding first bit set. O(1)+--+-- >>> firstBitSet $ setBit 0 63+-- 63+-- >>> firstBitSet $ setBit 0 62+-- 62+-- >>> firstBitSet $ setBit 0 1+-- 1+-- >>> firstBitSet $ setBit 0 0+-- 0+-- >>> firstBitSet 0+-- -1+firstBitSet :: Word64 -> Int+firstBitSet x = ffs x - 1+ where+ ffs = fromIntegral . c_ffs . fromIntegral++----------------------------------------------------------------++new :: STM (PriorityQueue a)+new = PriorityQueue <$> newTVar 0 <*> newTVar 0 <*> newQueues+ where+ newQueues = listArray (0, bitWidth - 1) <$> replicateM bitWidth newTQueue++-- | Enqueuing an entry. PriorityQueue is updated.+enqueue :: Entry a -> PriorityQueue a -> STM ()+enqueue ent PriorityQueue{..} = do+ let (!idx,!deficit') = calcIdxAndDeficit+ !offidx <- getOffIdx idx+ push offidx ent { deficit = deficit' }+ updateBits idx+ where+ calcIdxAndDeficit = total `divMod` deficitSteps+ where+ total = deficitTable ! weight ent + deficit ent+ getOffIdx idx = relativeIndex idx <$> readTVar offsetRef+ push offidx ent' = writeTQueue (queues ! offidx) ent'+ updateBits idx = modifyTVar' bitsRef $ flip setBit idx++-- | Dequeuing an entry. PriorityQueue is updated.+dequeue :: PriorityQueue a -> STM (Entry a)+dequeue pq@PriorityQueue{..} = do+ !idx <- getIdx+ if idx == -1 then+ retry+ else do+ !offidx <- getOffIdx idx+ updateOffset offidx+ queueIsEmpty <- checkEmpty offidx+ updateBits idx queueIsEmpty+ if queueIsEmpty then+ dequeue pq+ else+ pop offidx+ where+ getIdx = firstBitSet <$> readTVar bitsRef+ getOffIdx idx = relativeIndex idx <$> readTVar offsetRef+ pop offidx = readTQueue (queues ! offidx)+ checkEmpty offidx = isEmptyTQueue (queues ! offidx)+ updateOffset offset' = writeTVar offsetRef offset'+ updateBits idx isEmpty = modifyTVar' bitsRef shiftClear+ where+ shiftClear bits+ | isEmpty = clearBit (shiftR bits idx) 0+ | otherwise = shiftR bits idx
− bench/Main.hs
@@ -1,225 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Main where--import Control.Concurrent.STM-import Criterion.Main-import Data.List (foldl')-import System.Random--import qualified ArrayOfQueue as A-import qualified ArrayOfQueueIO as AIO-import qualified BinaryHeap as B-import qualified BinaryHeapIO as BIO-import qualified Heap as O-import qualified Network.HTTP2.Priority.PSQ as P-import qualified RandomSkewHeap as R--type Key = Int-type Weight = Int--numOfStreams :: Int-numOfStreams = 100--numOfTrials :: Int-numOfTrials = 10000--main :: IO ()-main = do- gen <- getStdGen- let ks = [1,3..]- ws = take numOfStreams $ randomRs (1,256) gen- xs = zip ks ws- defaultMain [- bgroup "enqueue & dequeue" [- bench "Random Skew Heap" $ whnf enqdeqR xs- , bench "Okasaki Heap" $ whnf enqdeqO xs- , bench "Priority Search Queue" $ whnf enqdeqP xs- , bench "Binary Heap STM" $ nfIO (enqdeqB xs)- , bench "Binary Heap IO" $ nfIO (enqdeqBIO xs)- , bench "Array of Queue STM" $ nfIO (enqdeqA xs)- , bench "Array of Queue IO" $ nfIO (enqdeqAIO xs)- ]- , bgroup "delete" [- bench "Random Skew Heap" $ whnf deleteR xs- , bench "Okasaki Heap" $ whnf deleteO xs- , bench "Priority Search Queue" $ whnf deleteP xs- , bench "Binary Heap STM" $ nfIO (deleteB xs)- , bench "Binary Heap IO" $ nfIO (deleteBIO xs)- , bench "Array of Queue IO" $ nfIO (deleteAIO xs)- ]- ]--------------------------------------------------------------------enqdeqR :: [(Key,Weight)] -> ()-enqdeqR xs = loop pq numOfTrials- where- !pq = createR xs R.empty- loop _ 0 = ()- loop q !n = case R.dequeue q of- Nothing -> error "enqdeqR"- Just (k,w,x,q') -> let !q'' = R.enqueue k w x q'- in loop q'' (n - 1)--deleteR :: [(Key,Weight)] -> R.PriorityQueue Int-deleteR xs = foldl' (\p k -> snd (R.delete k p)) pq ks- where- !pq = createR xs R.empty- (ks,_) = unzip xs--createR :: [(Key,Weight)] -> R.PriorityQueue Int -> R.PriorityQueue Int-createR [] !q = q-createR ((k,w):xs) !q = createR xs q'- where- !q' = R.enqueue k w k q--------------------------------------------------------------------enqdeqO :: [(Key,Weight)] -> O.PriorityQueue Int-enqdeqO xs = loop pq numOfTrials- where- !pq = createO xs O.empty- loop !q 0 = q- loop !q !n = case O.dequeue q of- Nothing -> error "enqdeqO"- Just (k,w,x,q') -> loop (O.enqueue k w x q') (n - 1)--deleteO :: [(Key,Weight)] -> O.PriorityQueue Int-deleteO xs = foldl' (\p k -> snd (O.delete k p)) pq ks- where- !pq = createO xs O.empty- (ks,_) = unzip xs--createO :: [(Key,Weight)] -> O.PriorityQueue Int -> O.PriorityQueue Int-createO [] !q = q-createO ((k,w):xs) !q = createO xs q'- where- !q' = O.enqueue k w k q--------------------------------------------------------------------enqdeqP :: [(Key,Weight)] -> P.PriorityQueue Int-enqdeqP xs = loop pq numOfTrials- where- !pq = createP xs P.empty- loop !q 0 = q- loop !q !n = case P.dequeue q of- Nothing -> error "enqdeqP"- Just (k,w,x,q') -> loop (P.enqueue k w x q') (n - 1)--deleteP :: [(Key,Weight)] -> P.PriorityQueue Int-deleteP xs = foldl' (\p k -> snd (P.delete k p)) pq ks- where- !pq = createP xs P.empty- (ks,_) = unzip xs--createP :: [(Key,Weight)] -> P.PriorityQueue Int -> P.PriorityQueue Int-createP [] !q = q-createP ((k,w):xs) !q = createP xs (P.enqueue k w k q)--------------------------------------------------------------------enqdeqB :: [(Key,Weight)] -> IO ()-enqdeqB xs = do- q <- atomically (B.new numOfStreams)- createB xs q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- Just (k,w,x) <- atomically $ B.dequeue q- atomically $ B.enqueue k w x q- loop q (n - 1)--deleteB :: [(Key,Weight)] -> IO ()-deleteB xs = do- q <- atomically $ B.new numOfStreams- createB xs q- mapM_ (\k -> atomically $ B.delete k q) keys- where- (keys,_) = unzip xs--createB :: [(Key,Weight)] -> B.PriorityQueue Int -> IO ()-createB [] _ = return ()-createB ((k,w):xs) !q = do- atomically $ B.enqueue k w k q- createB xs q--------------------------------------------------------------------enqdeqBIO :: [(Key,Weight)] -> IO ()-enqdeqBIO xs = do- q <- BIO.new numOfStreams- createBIO xs q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- Just (k,w,x) <- BIO.dequeue q- BIO.enqueue k w x q- loop q (n - 1)--deleteBIO :: [(Key,Weight)] -> IO ()-deleteBIO xs = do- q <- BIO.new numOfStreams- createBIO xs q- mapM_ (\k -> BIO.delete k q) keys- where- (keys,_) = unzip xs--createBIO :: [(Key,Weight)] -> BIO.PriorityQueue Int -> IO ()-createBIO [] _ = return ()-createBIO ((k,w):xs) !q = do- BIO.enqueue k w k q- createBIO xs q--------------------------------------------------------------------enqdeqA :: [(Key,Weight)] -> IO ()-enqdeqA xs = do- q <- atomically A.new- createA xs q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- Just (k,w,x) <- atomically $ A.dequeue q- atomically $ A.enqueue k w x q- loop q (n - 1)--createA :: [(Key,Weight)] -> A.PriorityQueue Int -> IO ()-createA [] _ = return ()-createA ((k,w):xs) !q = do- atomically $ A.enqueue k w k q- createA xs q--------------------------------------------------------------------enqdeqAIO :: [(Key,Weight)] -> IO ()-enqdeqAIO xs = do- q <- AIO.new- createAIO xs q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- Just (k,w,x) <- AIO.dequeue q- AIO.enqueue k w x q- loop q (n - 1)--deleteAIO :: [(Key,Weight)] -> IO ()-deleteAIO xs = do- q <- AIO.new- createAIO xs q- mapM_ (\k -> AIO.delete k q) keys- where- (keys,_) = unzip xs--createAIO :: [(Key,Weight)] -> AIO.PriorityQueue Int -> IO ()-createAIO [] _ = return ()-createAIO ((k,w):xs) !q = do- AIO.enqueue k w k q- createAIO xs q------------------------------------------------------------------
http2.cabal view
@@ -1,5 +1,5 @@ Name: http2-Version: 1.4.2+Version: 1.4.3 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -264,9 +264,17 @@ Benchmark criterion Type: exitcode-stdio-1.0 Default-Language: Haskell2010- Hs-Source-Dirs: bench, .+ Hs-Source-Dirs: bench-priority, . Ghc-Options: -Wall Main-Is: Main.hs+ Other-Modules: BinaryHeap+ BinaryHeapSTM+ DoublyLinkedQueueIO+ Heap+ RandomSkewHeap+ RingOfQueues+ RingOfQueuesSTM+ Build-Depends: base , array , containers
test/HTTP2/PrioritySpec.hs view
@@ -23,6 +23,30 @@ P.enqueue 1 (P.newPrecedence 201) 1 P.empty xs = enqdeq q 1000 map length (group (sort xs)) `shouldBe` [664,333,3]+ it "deletes properly" $ do+ let q = P.enqueue 7 (P.newPrecedence 1) 7 $+ P.enqueue 5 (P.newPrecedence 5) 5 $+ P.enqueue 3 (P.newPrecedence 50) 3 $+ P.enqueue 1 (P.newPrecedence 201) (1 :: Int) P.empty+ let Just (k1,_,_,q1) = P.dequeue q+ k1 `shouldBe` 1+ let (mk, q2) = P.delete 5 q1+ mk `shouldBe` Just 5+ let Just (k3,_,_,q3) = P.dequeue q2+ k3 `shouldBe` 3+ let Just (k4,_,_,_) = P.dequeue q3+ k4 `shouldBe` 7+ it "deletes entries properly" $ do+ let q = P.enqueue 5 (P.newPrecedence 1) 5 $+ P.enqueue 3 (P.newPrecedence 101) 3 $+ P.enqueue 1 (P.newPrecedence 201) 1 P.empty+ (mv1,q1) = P.delete 1 q+ (mv2,q2) = P.delete 3 q+ P.baseDeficit q `shouldBe` 0+ mv1 `shouldBe` Just (1 :: Int)+ P.baseDeficit q1 `shouldBe` 326+ mv2 `shouldBe` Just 3+ P.baseDeficit q2 `shouldBe` 0 firefox :: IO () firefox = do