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.

Utility/ResourcePool.hs

@@ -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
+