Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Hakyll.Core.Runtime: use MVar instead of TVar #863

Merged
merged 1 commit into from
Jul 18, 2021
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 0 additions & 1 deletion hakyll.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -193,7 +193,6 @@ Library
regex-tdfa >= 1.1 && < 1.4,
resourcet >= 1.1 && < 1.3,
scientific >= 0.3.4 && < 0.4,
stm >= 2.3 && < 3,
tagsoup >= 0.13.1 && < 0.15,
template-haskell >= 2.14 && < 2.18,
text >= 0.11 && < 1.3,
Expand Down
30 changes: 14 additions & 16 deletions lib/Hakyll/Core/Runtime.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,12 +6,12 @@ module Hakyll.Core.Runtime

--------------------------------------------------------------------------------
import Control.Concurrent.Async.Lifted (forConcurrently_)
import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO, newTVarIO, TVar)
import Control.Concurrent.MVar (modifyMVar_, readMVar, newMVar, MVar)
Minoru marked this conversation as resolved.
Show resolved Hide resolved
import Control.Monad (unless)
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.Reader (ask)
import Control.Monad.RWS (RWST, runRWST)
import Control.Monad.State (get)
import Control.Monad.State (get)
import Control.Monad.Trans (liftIO)
import qualified Data.Array as A
import Data.Graph (Graph)
Expand Down Expand Up @@ -73,7 +73,7 @@ run config logger rules = do
, runtimeUniverse = M.fromList compilers
}

state <- newTVarIO $ RuntimeState
state <- newMVar $ RuntimeState
{ runtimeDone = S.empty
, runtimeSnapshots = S.empty
, runtimeTodo = M.empty
Expand All @@ -90,7 +90,7 @@ run config logger rules = do
return (ExitFailure 1, ruleSet)

Right (_, s, _) -> do
facts <- fmap runtimeFacts . liftIO . readTVarIO $ s
facts <- fmap runtimeFacts . liftIO . readMVar $ s
Store.set store factsKey facts

Logger.debug logger "Removing tmp directory..."
Expand Down Expand Up @@ -124,21 +124,19 @@ data RuntimeState = RuntimeState


--------------------------------------------------------------------------------
type Runtime a = RWST RuntimeRead () (TVar RuntimeState) (ExceptT String IO) a
type Runtime a = RWST RuntimeRead () (MVar RuntimeState) (ExceptT String IO) a


--------------------------------------------------------------------------------
-- Because compilation of rules often revolves around IO,
-- it is not possible to live in the STM monad and hence benefit from
-- its guarantees.
-- Be very careful when modifying the state
-- be very careful when modifying the state
modifyRuntimeState :: (RuntimeState -> RuntimeState) -> Runtime ()
modifyRuntimeState f = get >>= \s -> liftIO . atomically $ modifyTVar' s f
modifyRuntimeState f = get >>= \s -> liftIO $ modifyMVar_ s (pure . f)


--------------------------------------------------------------------------------
getRuntimeState :: Runtime RuntimeState
getRuntimeState = liftIO . readTVarIO =<< get
getRuntimeState = liftIO . readMVar =<< get


--------------------------------------------------------------------------------
Expand All @@ -162,11 +160,11 @@ scheduleOutOfDate = do
let identifiers = M.keys universe
modified = S.fromList $ flip filter identifiers $
resourceModified provider

state <- getRuntimeState
let facts = runtimeFacts state
todo = runtimeTodo state

let (ood, facts', msgs) = outOfDate identifiers modified facts
todo' = M.filterWithKey
(\id' _ -> id' `S.member` ood) universe
Expand Down Expand Up @@ -309,15 +307,15 @@ chase id' = do

let deps' = if depDone
then deps
else M.insertWith S.union id' (S.singleton depId) deps
else M.insertWith S.union id' (S.singleton depId) deps

modifyRuntimeState $ \s -> s
{ runtimeTodo = M.insert id'
(if depDone then c else compilerResult result)
{ runtimeTodo = M.insert id'
(if depDone then c else compilerResult result)
(runtimeTodo s)
, runtimeDependencies = deps'
}

Logger.debug logger $ "Require " ++ show depId ++
" (snapshot " ++ depSnapshot ++ ") "