{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards, ViewPatterns #-}
module Development.Shake.Internal.Resource(
Resource, newResourceIO, newThrottleIO, withResource
) where
import Data.Function
import System.IO.Unsafe
import Control.Concurrent.Extra
import General.Fence
import Control.Exception.Extra
import Data.Tuple.Extra
import Data.IORef
import Control.Monad.Extra
import General.Bilist
import General.Pool
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Core.Pool
import Control.Monad.IO.Class
import System.Time.Extra
{-# NOINLINE resourceId #-}
resourceId :: IO Int
resourceId :: IO Int
resourceId = forall a. IO a -> a
unsafePerformIO IO (IO Int)
resourceCounter
{-# NOINLINE resourceCounter #-}
resourceCounter :: IO (IO Int)
resourceCounter :: IO (IO Int)
resourceCounter = do
IORef Int
ref <- forall a. a -> IO (IORef a)
newIORef Int
0
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
ref forall a b. (a -> b) -> a -> b
$ \Int
i -> let j :: Int
j = Int
i forall a. Num a => a -> a -> a
+ Int
1 in (Int
j, Int
j)
withResource :: Resource -> Int -> Action a -> Action a
withResource :: forall a. Resource -> Int -> Action a -> Action a
withResource Resource
r Int
i Action a
act = do
Global{Bool
Maybe Shared
Maybe Cloud
IO Seconds
IO Progress
IORef [IO ()]
IORef [(Key, Key)]
HashMap TypeRep BuiltinRule
Cleanup
ShakeOptions
Database
Pool
Map UserRuleVersioned
Step
[String] -> [Key] -> Action [Value]
IO String -> IO ()
Key -> Action ()
Verbosity -> String -> IO ()
globalOneShot :: Global -> Bool
globalStep :: Global -> Step
globalCloud :: Global -> Maybe Cloud
globalShared :: Global -> Maybe Shared
globalUserRules :: Global -> Map UserRuleVersioned
globalProgress :: Global -> IO Progress
globalTrackAbsent :: Global -> IORef [(Key, Key)]
globalAfter :: Global -> IORef [IO ()]
globalRuleFinished :: Global -> Key -> Action ()
globalDiagnostic :: Global -> IO String -> IO ()
globalOptions :: Global -> ShakeOptions
globalOutput :: Global -> Verbosity -> String -> IO ()
globalRules :: Global -> HashMap TypeRep BuiltinRule
globalTimestamp :: Global -> IO Seconds
globalCleanup :: Global -> Cleanup
globalPool :: Global -> Pool
globalDatabase :: Global -> Database
globalBuild :: Global -> [String] -> [Key] -> Action [Value]
globalOneShot :: Bool
globalStep :: Step
globalCloud :: Maybe Cloud
globalShared :: Maybe Shared
globalUserRules :: Map UserRuleVersioned
globalProgress :: IO Progress
globalTrackAbsent :: IORef [(Key, Key)]
globalAfter :: IORef [IO ()]
globalRuleFinished :: Key -> Action ()
globalDiagnostic :: IO String -> IO ()
globalOptions :: ShakeOptions
globalOutput :: Verbosity -> String -> IO ()
globalRules :: HashMap TypeRep BuiltinRule
globalTimestamp :: IO Seconds
globalCleanup :: Cleanup
globalPool :: Pool
globalDatabase :: Database
globalBuild :: [String] -> [Key] -> Action [Value]
..} <- forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action forall k v ro rw. RAW k v ro rw ro
getRO
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Resource
r forall a. [a] -> [a] -> [a]
++ String
" waiting to acquire " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
Maybe (Fence IO ())
fence <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Resource -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquireResource Resource
r Pool
globalPool Int
i
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Fence IO ())
fence forall a b. (a -> b) -> a -> b
$ \Fence IO ()
fence -> do
(Seconds
offset, ()) <- forall a b.
(a -> Either SomeException b) -> Fence IO a -> Action (Seconds, b)
actionFenceRequeueBy forall a b. b -> Either a b
Right Fence IO ()
fence
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall rw k v ro. (rw -> rw) -> RAW k v ro rw ()
modifyRW forall a b. (a -> b) -> a -> b
$ Seconds -> Local -> Local
addDiscount Seconds
offset
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Resource
r forall a. [a] -> [a] -> [a]
++ String
" running with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
forall a. RAW ([String], [Key]) [Value] Global Local a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall a. Action a -> RAW ([String], [Key]) [Value] Global Local a
fromAction (forall a. String -> Action a -> Action a
blockApply (String
"Within withResource using " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Resource
r) Action a
act) forall k v ro rw a b.
RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw a
`finallyRAW` do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Resource -> Pool -> Int -> IO ()
releaseResource Resource
r Pool
globalPool Int
i
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
globalDiagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Resource
r forall a. [a] -> [a] -> [a]
++ String
" released " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
data Resource = Resource
{Resource -> Int
resourceOrd :: Int
,Resource -> String
resourceShow :: String
,Resource -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquireResource :: Pool -> Int -> IO (Maybe (Fence IO ()))
,Resource -> Pool -> Int -> IO ()
releaseResource :: Pool -> Int -> IO ()
}
instance Show Resource where show :: Resource -> String
show = Resource -> String
resourceShow
instance Eq Resource where == :: Resource -> Resource -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Resource -> Int
resourceOrd
instance Ord Resource where compare :: Resource -> Resource -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Resource -> Int
resourceOrd
data Finite = Finite
{Finite -> Int
finiteAvailable :: !Int
,Finite -> Bilist (Int, Fence IO ())
finiteWaiting :: Bilist (Int, Fence IO ())
}
newResourceIO :: String -> Int -> IO Resource
newResourceIO :: String -> Int -> IO Resource
newResourceIO String
name Int
mx = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
mx forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$
forall a. Partial => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"You cannot create a resource named " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" with a negative quantity, you used " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
mx
Int
key <- IO Int
resourceId
Var Finite
var <- forall a. a -> IO (Var a)
newVar forall a b. (a -> b) -> a -> b
$ Int -> Bilist (Int, Fence IO ()) -> Finite
Finite Int
mx forall a. Monoid a => a
mempty
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int
-> String
-> (Pool -> Int -> IO (Maybe (Fence IO ())))
-> (Pool -> Int -> IO ())
-> Resource
Resource (forall a. Num a => a -> a
negate Int
key) String
shw (Var Finite -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire Var Finite
var) (Var Finite -> Pool -> Int -> IO ()
release Var Finite
var)
where
shw :: String
shw = String
"Resource " forall a. [a] -> [a] -> [a]
++ String
name
acquire :: Var Finite -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire :: Var Finite -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire Var Finite
var Pool
_ Int
want
| Int
want forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Partial => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"You cannot acquire a negative quantity of " forall a. [a] -> [a] -> [a]
++ String
shw forall a. [a] -> [a] -> [a]
++ String
", requested " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
want
| Int
want forall a. Ord a => a -> a -> Bool
> Int
mx = forall a. Partial => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"You cannot acquire more than " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
mx forall a. [a] -> [a] -> [a]
++ String
" of " forall a. [a] -> [a] -> [a]
++ String
shw forall a. [a] -> [a] -> [a]
++ String
", requested " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
want
| Bool
otherwise = forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Finite
var forall a b. (a -> b) -> a -> b
$ \x :: Finite
x@Finite{Int
Bilist (Int, Fence IO ())
finiteWaiting :: Bilist (Int, Fence IO ())
finiteAvailable :: Int
finiteWaiting :: Finite -> Bilist (Int, Fence IO ())
finiteAvailable :: Finite -> Int
..} ->
if Int
want forall a. Ord a => a -> a -> Bool
<= Int
finiteAvailable then
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Finite
x{finiteAvailable :: Int
finiteAvailable = Int
finiteAvailable forall a. Num a => a -> a -> a
- Int
want}, forall a. Maybe a
Nothing)
else do
Fence IO ()
fence <- forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Finite
x{finiteWaiting :: Bilist (Int, Fence IO ())
finiteWaiting = Bilist (Int, Fence IO ())
finiteWaiting forall a. Bilist a -> a -> Bilist a
`snoc` (Int
want, Fence IO ()
fence)}, forall a. a -> Maybe a
Just Fence IO ()
fence)
release :: Var Finite -> Pool -> Int -> IO ()
release :: Var Finite -> Pool -> Int -> IO ()
release Var Finite
var Pool
_ Int
i = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Finite
var forall a b. (a -> b) -> a -> b
$ \Finite
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Finite -> (Finite, IO ())
f Finite
x{finiteAvailable :: Int
finiteAvailable = Finite -> Int
finiteAvailable Finite
x forall a. Num a => a -> a -> a
+ Int
i}
where
f :: Finite -> (Finite, IO ())
f (Finite Int
i (forall a. Bilist a -> Maybe (a, Bilist a)
uncons -> Just ((Int
wi,Fence IO ()
wa),Bilist (Int, Fence IO ())
ws)))
| Int
wi forall a. Ord a => a -> a -> Bool
<= Int
i = forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (forall (m :: * -> *) a.
(Partial, MonadIO m) =>
Fence m a -> a -> m ()
signalFence Fence IO ()
wa () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>) forall a b. (a -> b) -> a -> b
$ Finite -> (Finite, IO ())
f forall a b. (a -> b) -> a -> b
$ Int -> Bilist (Int, Fence IO ()) -> Finite
Finite (Int
iforall a. Num a => a -> a -> a
-Int
wi) Bilist (Int, Fence IO ())
ws
| Bool
otherwise = forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((Int, Fence IO ()) -> Finite -> Finite
add (Int
wi,Fence IO ()
wa)) forall a b. (a -> b) -> a -> b
$ Finite -> (Finite, IO ())
f forall a b. (a -> b) -> a -> b
$ Int -> Bilist (Int, Fence IO ()) -> Finite
Finite Int
i Bilist (Int, Fence IO ())
ws
f (Finite Int
i Bilist (Int, Fence IO ())
_) = (Int -> Bilist (Int, Fence IO ()) -> Finite
Finite Int
i forall a. Monoid a => a
mempty, forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
add :: (Int, Fence IO ()) -> Finite -> Finite
add (Int, Fence IO ())
a Finite
s = Finite
s{finiteWaiting :: Bilist (Int, Fence IO ())
finiteWaiting = (Int, Fence IO ())
a forall a. a -> Bilist a -> Bilist a
`cons` Finite -> Bilist (Int, Fence IO ())
finiteWaiting Finite
s}
waiter :: Seconds -> IO () -> IO ()
waiter :: Seconds -> IO () -> IO ()
waiter Seconds
period IO ()
act = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
Seconds -> IO ()
sleep Seconds
period
IO ()
act
data Throttle
= ThrottleAvailable !Int
| ThrottleWaiting (IO ()) (Bilist (Int, Fence IO ()))
newThrottleIO :: String -> Int -> Double -> IO Resource
newThrottleIO :: String -> Int -> Seconds -> IO Resource
newThrottleIO String
name Int
count Seconds
period = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$
forall a. Partial => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"You cannot create a throttle named " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" with a negative quantity, you used " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count
Int
key <- IO Int
resourceId
Var Throttle
var <- forall a. a -> IO (Var a)
newVar forall a b. (a -> b) -> a -> b
$ Int -> Throttle
ThrottleAvailable Int
count
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int
-> String
-> (Pool -> Int -> IO (Maybe (Fence IO ())))
-> (Pool -> Int -> IO ())
-> Resource
Resource Int
key String
shw (Var Throttle -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire Var Throttle
var) (Var Throttle -> Pool -> Int -> IO ()
release Var Throttle
var)
where
shw :: String
shw = String
"Throttle " forall a. [a] -> [a] -> [a]
++ String
name
acquire :: Var Throttle -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire :: Var Throttle -> Pool -> Int -> IO (Maybe (Fence IO ()))
acquire Var Throttle
var Pool
pool Int
want
| Int
want forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Partial => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"You cannot acquire a negative quantity of " forall a. [a] -> [a] -> [a]
++ String
shw forall a. [a] -> [a] -> [a]
++ String
", requested " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
want
| Int
want forall a. Ord a => a -> a -> Bool
> Int
count = forall a. Partial => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"You cannot acquire more than " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count forall a. [a] -> [a] -> [a]
++ String
" of " forall a. [a] -> [a] -> [a]
++ String
shw forall a. [a] -> [a] -> [a]
++ String
", requested " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
want
| Bool
otherwise = forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Throttle
var forall a b. (a -> b) -> a -> b
$ \case
ThrottleAvailable Int
i
| Int
i forall a. Ord a => a -> a -> Bool
>= Int
want -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Throttle
ThrottleAvailable forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
- Int
want, forall a. Maybe a
Nothing)
| Bool
otherwise -> do
IO ()
stop <- Pool -> IO (IO ())
keepAlivePool Pool
pool
Fence IO ()
fence <- forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Bilist (Int, Fence IO ()) -> Throttle
ThrottleWaiting IO ()
stop forall a b. (a -> b) -> a -> b
$ (Int
want forall a. Num a => a -> a -> a
- Int
i, Fence IO ()
fence) forall a. a -> Bilist a -> Bilist a
`cons` forall a. Monoid a => a
mempty, forall a. a -> Maybe a
Just Fence IO ()
fence)
ThrottleWaiting IO ()
stop Bilist (Int, Fence IO ())
xs -> do
Fence IO ()
fence <- forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Bilist (Int, Fence IO ()) -> Throttle
ThrottleWaiting IO ()
stop forall a b. (a -> b) -> a -> b
$ Bilist (Int, Fence IO ())
xs forall a. Bilist a -> a -> Bilist a
`snoc` (Int
want, Fence IO ()
fence), forall a. a -> Maybe a
Just Fence IO ()
fence)
release :: Var Throttle -> Pool -> Int -> IO ()
release :: Var Throttle -> Pool -> Int -> IO ()
release Var Throttle
var Pool
_ Int
n = Seconds -> IO () -> IO ()
waiter Seconds
period forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var Throttle
var forall a b. (a -> b) -> a -> b
$ \Throttle
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Throttle
x of
ThrottleAvailable Int
i -> (Int -> Throttle
ThrottleAvailable forall a b. (a -> b) -> a -> b
$ Int
iforall a. Num a => a -> a -> a
+Int
n, forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
ThrottleWaiting IO ()
stop Bilist (Int, Fence IO ())
xs -> IO () -> Int -> Bilist (Int, Fence IO ()) -> (Throttle, IO ())
f IO ()
stop Int
n Bilist (Int, Fence IO ())
xs
where
f :: IO () -> Int -> Bilist (Int, Fence IO ()) -> (Throttle, IO ())
f IO ()
stop Int
i (forall a. Bilist a -> Maybe (a, Bilist a)
uncons -> Just ((Int
wi,Fence IO ()
wa),Bilist (Int, Fence IO ())
ws))
| Int
i forall a. Ord a => a -> a -> Bool
>= Int
wi = forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (forall (m :: * -> *) a.
(Partial, MonadIO m) =>
Fence m a -> a -> m ()
signalFence Fence IO ()
wa () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>) forall a b. (a -> b) -> a -> b
$ IO () -> Int -> Bilist (Int, Fence IO ()) -> (Throttle, IO ())
f IO ()
stop (Int
iforall a. Num a => a -> a -> a
-Int
wi) Bilist (Int, Fence IO ())
ws
| Bool
otherwise = (IO () -> Bilist (Int, Fence IO ()) -> Throttle
ThrottleWaiting IO ()
stop forall a b. (a -> b) -> a -> b
$ (Int
wiforall a. Num a => a -> a -> a
-Int
i,Fence IO ()
wa) forall a. a -> Bilist a -> Bilist a
`cons` Bilist (Int, Fence IO ())
ws, forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
f IO ()
stop Int
i Bilist (Int, Fence IO ())
_ = (Int -> Throttle
ThrottleAvailable Int
i, IO ()
stop)