diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Network/HTTP2/Priority/PSQ.hs b/Network/HTTP2/Priority/PSQ.hs --- a/Network/HTTP2/Priority/PSQ.hs +++ b/Network/HTTP2/Priority/PSQ.hs @@ -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) diff --git a/bench-priority/BinaryHeap.hs b/bench-priority/BinaryHeap.hs new file mode 100644 --- /dev/null +++ b/bench-priority/BinaryHeap.hs @@ -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 diff --git a/bench-priority/BinaryHeapSTM.hs b/bench-priority/BinaryHeapSTM.hs new file mode 100644 --- /dev/null +++ b/bench-priority/BinaryHeapSTM.hs @@ -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 diff --git a/bench-priority/DoublyLinkedQueueIO.hs b/bench-priority/DoublyLinkedQueueIO.hs new file mode 100644 --- /dev/null +++ b/bench-priority/DoublyLinkedQueueIO.hs @@ -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 diff --git a/bench-priority/Heap.hs b/bench-priority/Heap.hs new file mode 100644 --- /dev/null +++ b/bench-priority/Heap.hs @@ -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 diff --git a/bench-priority/Main.hs b/bench-priority/Main.hs new file mode 100644 --- /dev/null +++ b/bench-priority/Main.hs @@ -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 + +---------------------------------------------------------------- diff --git a/bench-priority/RandomSkewHeap.hs b/bench-priority/RandomSkewHeap.hs new file mode 100644 --- /dev/null +++ b/bench-priority/RandomSkewHeap.hs @@ -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 diff --git a/bench-priority/RingOfQueues.hs b/bench-priority/RingOfQueues.hs new file mode 100644 --- /dev/null +++ b/bench-priority/RingOfQueues.hs @@ -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 diff --git a/bench-priority/RingOfQueuesSTM.hs b/bench-priority/RingOfQueuesSTM.hs new file mode 100644 --- /dev/null +++ b/bench-priority/RingOfQueuesSTM.hs @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -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 - ----------------------------------------------------------------- diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,5 +1,5 @@ Name: http2 -Version: 1.4.2 +Version: 1.4.3 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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 diff --git a/test/HTTP2/PrioritySpec.hs b/test/HTTP2/PrioritySpec.hs --- a/test/HTTP2/PrioritySpec.hs +++ b/test/HTTP2/PrioritySpec.hs @@ -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