mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-02-01 22:00:26 +01:00
Add some comments
This commit is contained in:
parent
b5f562a6ff
commit
d2db9519d4
@ -16,6 +16,10 @@ import Prelude
|
|||||||
-- run to generate results. Use 'mkSingleRun' to create this value.
|
-- run to generate results. Use 'mkSingleRun' to create this value.
|
||||||
data SingleRun k v = SingleRun
|
data SingleRun k v = SingleRun
|
||||||
{ srVar :: MVar [(k, MVar (Res v))]
|
{ srVar :: MVar [(k, MVar (Res v))]
|
||||||
|
-- ^ Keys and the variables containing their blocked
|
||||||
|
-- computations. More ideal would be to use a Map, but we're
|
||||||
|
-- avoiding dependencies outside of base in case this moves into
|
||||||
|
-- auto-update.
|
||||||
, srFunc :: k -> IO v
|
, srFunc :: k -> IO v
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -50,27 +54,51 @@ toRes se =
|
|||||||
-- will retry.
|
-- will retry.
|
||||||
singleRun :: Eq k => SingleRun k v -> k -> IO v
|
singleRun :: Eq k => SingleRun k v -> k -> IO v
|
||||||
singleRun sr@(SingleRun var f) k =
|
singleRun sr@(SingleRun var f) k =
|
||||||
|
-- Mask all exceptions so that we don't get killed between exiting
|
||||||
|
-- the modifyMVar and entering the join, which could leave an
|
||||||
|
-- empty MVar for a result that will never be filled.
|
||||||
mask $ \restore ->
|
mask $ \restore ->
|
||||||
join $ modifyMVar var $ \pairs ->
|
join $ modifyMVar var $ \pairs ->
|
||||||
case lookup k pairs of
|
case lookup k pairs of
|
||||||
|
-- Another thread is already working on this, grab its result
|
||||||
Just res -> do
|
Just res -> do
|
||||||
let action = restore $ do
|
let action = restore $ do
|
||||||
res' <- readMVar res
|
res' <- readMVar res
|
||||||
case res' of
|
case res' of
|
||||||
|
-- Other thread died by sync exception, rethrow
|
||||||
SyncException e -> throwIO e
|
SyncException e -> throwIO e
|
||||||
|
-- Async exception, ignore and try again
|
||||||
AsyncException _ -> singleRun sr k
|
AsyncException _ -> singleRun sr k
|
||||||
|
-- Success!
|
||||||
Success v -> return v
|
Success v -> return v
|
||||||
|
-- Return unmodified pairs
|
||||||
return (pairs, action)
|
return (pairs, action)
|
||||||
|
|
||||||
|
-- No other thread working
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
|
-- MVar we'll add to pairs to store the result and
|
||||||
|
-- share with other threads
|
||||||
resVar <- newEmptyMVar
|
resVar <- newEmptyMVar
|
||||||
let action = do
|
let action = do
|
||||||
|
-- Run the action and capture all exceptions
|
||||||
eres <- try $ restore $ f k
|
eres <- try $ restore $ f k
|
||||||
|
|
||||||
|
-- OK, we're done running, so let other
|
||||||
|
-- threads run this again.
|
||||||
modifyMVar_ var $ return . filter (\(k', _) -> k /= k')
|
modifyMVar_ var $ return . filter (\(k', _) -> k /= k')
|
||||||
|
|
||||||
case eres of
|
case eres of
|
||||||
|
-- Exception occured. We'll rethrow it,
|
||||||
|
-- and store the exceptional result in the
|
||||||
|
-- result variable.
|
||||||
Left e -> do
|
Left e -> do
|
||||||
putMVar resVar $ toRes e
|
putMVar resVar $ toRes e
|
||||||
throwIO e
|
throwIO e
|
||||||
|
-- Success! Store in the result variable
|
||||||
|
-- and return it
|
||||||
Right v -> do
|
Right v -> do
|
||||||
putMVar resVar $ Success v
|
putMVar resVar $ Success v
|
||||||
return v
|
return v
|
||||||
|
|
||||||
|
-- Modify pairs to include this variable.
|
||||||
return ((k, resVar) : pairs, action)
|
return ((k, resVar) : pairs, action)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user