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:
Joey Hess 2020-04-20 13:53:27 -04:00
parent 87b7b0f202
commit cee6b344b4
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
14 changed files with 243 additions and 47 deletions

94
Utility/ResourcePool.hs Normal file
View 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