diff --git a/Data/Pool.hs b/Data/Pool.hs
--- a/Data/Pool.hs
+++ b/Data/Pool.hs
@@ -3,18 +3,19 @@
 module Data.Pool
     ( -- * Using pools
       createPool
+    , createPoolCheckAlive
     , withPool
     , withPool'
+    , withPoolAllocate
     , Pool
       -- * Diagnostics
     , PoolStats (..)
     , poolStats
     ) where
 
-import Control.Concurrent.STM (atomically)
-import Control.Concurrent.STM.TVar
-    (TVar, newTVarIO, readTVar, writeTVar)
+import Data.IORef (IORef, newIORef, atomicModifyIORef, readIORef)
 import Control.Exception (throwIO, Exception)
+import qualified Control.Exception as E
 import Data.Typeable
 import qualified Control.Monad.IO.Peel as I
 import qualified Control.Exception.Peel as I
@@ -28,8 +29,10 @@
 
 data Pool a = Pool
     { poolMax :: Int
-    , poolData :: TVar (PoolData a)
+    , poolData :: IORef (PoolData a)
     , poolMake :: IO a
+    , poolFree :: a -> IO ()
+    , poolCheckAlive :: a -> IO Bool
     }
 
 data PoolStats = PoolStats
@@ -39,22 +42,31 @@
     }
 
 poolStats :: Pool a -> IO PoolStats
-poolStats (Pool m td _) = do
-    d <- atomically $ readTVar td
-    return $ PoolStats m (length $ poolAvail d) (poolCreated d)
+poolStats p = do
+    d <- readIORef $ poolData p
+    return $ PoolStats (poolMax p) (length $ poolAvail d) (poolCreated d)
 
 createPool :: (MonadIO m, I.MonadPeelIO m)
            => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b
-createPool mk fr mx f = do
-    pd <- liftIO $ newTVarIO $ PoolData [] 0
-    I.finally (f $ Pool mx pd mk) $ liftIO $ do
-        PoolData ress _ <- atomically $ readTVar pd
+createPool mk fr mx f = createPoolCheckAlive mk fr mx f $ const $ return True
+
+createPoolCheckAlive
+    :: (MonadIO m, I.MonadPeelIO m)
+    => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b)
+    -> (a -> IO Bool) -- ^ is the resource alive?
+    -> m b
+createPoolCheckAlive mk fr mx f ca = do
+    pd <- liftIO $ newIORef $ PoolData [] 0
+    I.finally (f $ Pool mx pd mk fr ca) $ liftIO $ do
+        PoolData ress _ <- readIORef pd
         mapM_ fr ress
 
 data PoolExhaustedException = PoolExhaustedException
     deriving (Show, Typeable)
 instance Exception PoolExhaustedException
 
+-- | This function throws a 'PoolExhaustedException' when no resources are
+-- available. See 'withPoolAllocate' to avoid this.
 withPool' :: (MonadIO m, I.MonadPeelIO m) => Pool a -> (a -> m b) -> m b
 withPool' p f = do
     x <- withPool p f
@@ -62,17 +74,27 @@
         Nothing -> liftIO $ throwIO PoolExhaustedException
         Just x' -> return x'
 
+-- | Same as @withPool'@, but instead of throwing a 'PoolExhaustedException'
+-- when there the maximum number of resources are created and allocated, it
+-- allocates a new resource, passes it to the subprocess and then frees it.
+withPoolAllocate :: I.MonadPeelIO m => Pool a -> (a -> m b) -> m b
+withPoolAllocate p f = do
+    x <- withPool p f
+    case x of
+        Just x' -> return x'
+        Nothing ->
+            I.bracket
+                (liftIO $ poolMake p)
+                (liftIO . poolFree p)
+                f
+
 withPool :: (MonadIO m, I.MonadPeelIO m)
          => Pool a -> (a -> m b) -> m (Maybe b)
 withPool p f = I.block $ do
-    eres <- liftIO $ atomically $ do
-        pd <- readTVar $ poolData p
-        let (pd', eres) =
-                case poolAvail pd of
-                    (x:xs) -> (pd { poolAvail = xs }, Right x)
-                    [] -> (pd, Left $ poolCreated pd)
-        writeTVar (poolData p) pd'
-        return eres
+    eres <- liftIO $ atomicModifyIORef (poolData p) $ \pd ->
+        case poolAvail pd of
+            x:xs -> (pd { poolAvail = xs }, Right x)
+            [] -> (pd, Left $ poolCreated pd)
     case eres of
         Left pc ->
             if pc >= poolMax p
@@ -81,13 +103,20 @@
                     (liftIO $ poolMake p)
                     (insertResource 1)
                     (liftM Just . I.unblock . f)
-        Right res -> I.finally
+        Right res -> do
+            isAlive <- liftIO $ E.try $ E.unblock $ poolCheckAlive p res
+            case isAlive :: Either E.SomeException Bool of
+                Right True ->
+                    I.finally
                         (liftM Just $ I.unblock $ f res)
                         (insertResource 0 res)
+                _ -> do
+                    -- decrement the poolCreated count and then start over
+                    liftIO $ atomicModifyIORef (poolData p) $ \pd ->
+                        (pd { poolCreated = poolCreated pd - 1}, ())
+                    I.unblock $ withPool p f
   where
-    insertResource i x = liftIO $ atomically $ do
-        pd <- readTVar $ poolData p
-        writeTVar (poolData p)
-            pd { poolAvail = x : poolAvail pd
-               , poolCreated = i + poolCreated pd
-               }
+    insertResource i x = liftIO $ atomicModifyIORef (poolData p) $ \pd ->
+        (pd { poolAvail = x : poolAvail pd
+                , poolCreated = i + poolCreated pd
+                }, ())
diff --git a/pool.cabal b/pool.cabal
--- a/pool.cabal
+++ b/pool.cabal
@@ -1,5 +1,5 @@
 name:            pool
-version:         0.0.0
+version:         0.0.1
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>