cat-file resource pool
Avoid running a large number of git cat-file child processes when run with a large -J value. This implementation takes care to avoid adding any overhead to git-annex when run without -J. When run with -J, there is a small bit of added overhead, to manipulate the resource pool. That optimisation added a fair bit of complexity.
This commit is contained in:
parent
87b7b0f202
commit
cee6b344b4
14 changed files with 243 additions and 47 deletions
94
Utility/ResourcePool.hs
Normal file
94
Utility/ResourcePool.hs
Normal file
|
@ -0,0 +1,94 @@
|
|||
{- Resource pools.
|
||||
-
|
||||
- Copyright 2020 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Utility.ResourcePool (
|
||||
ResourcePool,
|
||||
mkResourcePool,
|
||||
mkResourcePoolNonConcurrent,
|
||||
withResourcePool,
|
||||
freeResourcePool,
|
||||
) where
|
||||
|
||||
import Common
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Either
|
||||
|
||||
data ResourcePool r
|
||||
= ResourcePool Int (TVar Int) (TVar [r])
|
||||
| ResourcePoolNonConcurrent r
|
||||
|
||||
{- Make a new resource pool, that can grow to contain the specified number
|
||||
- of resources. -}
|
||||
mkResourcePool :: MonadIO m => Int -> m (ResourcePool r)
|
||||
mkResourcePool maxsz = liftIO $
|
||||
ResourcePool maxsz
|
||||
<$> newTVarIO 0
|
||||
<*> newTVarIO []
|
||||
|
||||
{- When there will not be multiple threads that may
|
||||
- may concurrently try to use it, using this is more
|
||||
- efficient than mkResourcePool.
|
||||
-}
|
||||
mkResourcePoolNonConcurrent :: (MonadMask m, MonadIO m) => m r -> m (ResourcePool r)
|
||||
mkResourcePoolNonConcurrent allocresource =
|
||||
ResourcePoolNonConcurrent <$> allocresource
|
||||
|
||||
{- Runs an action with a resource.
|
||||
-
|
||||
- If no free resource is available in the pool,
|
||||
- will run the action the allocate a new resource if the pool's size
|
||||
- allows. Or will block a resource becomes available to use.
|
||||
-
|
||||
- The resource is returned to the pool at the end.
|
||||
-}
|
||||
withResourcePool :: (MonadMask m, MonadIO m) => ResourcePool r -> m r -> (r -> m a) -> m a
|
||||
withResourcePool (ResourcePoolNonConcurrent r) _ a = a r
|
||||
withResourcePool (ResourcePool maxsz currsz p) allocresource a =
|
||||
bracket setup cleanup a
|
||||
where
|
||||
setup = do
|
||||
mr <- liftIO $ atomically $ do
|
||||
l <- readTVar p
|
||||
case l of
|
||||
(r:rs) -> do
|
||||
writeTVar p rs
|
||||
return (Just r)
|
||||
[] -> do
|
||||
n <- readTVar currsz
|
||||
if n < maxsz
|
||||
then do
|
||||
let !n' = succ n
|
||||
writeTVar currsz n'
|
||||
return Nothing
|
||||
else retry
|
||||
case mr of
|
||||
Just r -> return r
|
||||
Nothing -> allocresource
|
||||
cleanup r = liftIO $ atomically $ modifyTVar' p (r:)
|
||||
|
||||
{- Frees all resources in use in the pool, running the supplied action on
|
||||
- each. (If any of the actions throw an exception, it will be rethrown
|
||||
- after all the actions have completed.)
|
||||
-
|
||||
- The pool should not have any resources in use when this is called,
|
||||
- and the pool should not be used again after calling this.
|
||||
-}
|
||||
freeResourcePool :: (MonadMask m, MonadIO m) => ResourcePool r -> (r -> m ()) -> m ()
|
||||
freeResourcePool (ResourcePoolNonConcurrent r) freeresource = freeresource r
|
||||
freeResourcePool (ResourcePool _ currsz p) freeresource = do
|
||||
rs <- liftIO $ atomically $ do
|
||||
writeTVar currsz 0
|
||||
swapTVar p []
|
||||
res <- forM rs $ tryNonAsync . freeresource
|
||||
case lefts res of
|
||||
[] -> return ()
|
||||
(e:_) -> throwM e
|
||||
|
Loading…
Add table
Add a link
Reference in a new issue