{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
module System.IO.RecThunk
( Thunk
, thunk
, doneThunk
, force
)
where
#ifdef DEJAFU
#define Ctxt MonadConc m =>
#define Thunk_ (Thunk m)
#define ResolvingState_ (ResolvingState m)
#define KickedThunk_ (KickedThunk m)
#define ThreadId_ (ThreadId m)
#define IORef_ IORef m
#define MVar_ MVar m
#define M m
import Control.Concurrent.Classy hiding (wait)
#else
#define Ctxt
#define Thunk_ Thunk
#define ResolvingState_ ResolvingState
#define KickedThunk_ KickedThunk
#define ThreadId_ ThreadId
#define IORef_ IORef
#define MVar_ MVar
#define M IO
import Control.Concurrent.MVar
import Control.Concurrent
import Data.IORef
#endif
newtype Thunk_ = Thunk (MVar_ (Either (M [Thunk_]) KickedThunk_))
data ResolvingState_ = NotStarted | ProcessedBy ThreadId_ (MVar_ ()) | Done
data KickedThunk_ = KickedThunk (MVar_ [KickedThunk_]) (MVar_ ResolvingState_)
thunk :: Ctxt M [Thunk_] -> M Thunk_
thunk :: IO [Thunk] -> IO Thunk
thunk IO [Thunk]
act = MVar (Either (IO [Thunk]) KickedThunk) -> Thunk
Thunk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar (forall a b. a -> Either a b
Left IO [Thunk]
act)
doneThunk :: Ctxt M Thunk_
doneThunk :: IO Thunk
doneThunk = do
MVar [KickedThunk]
mv_ts <- forall a. a -> IO (MVar a)
newMVar []
MVar ResolvingState
mv_s <- forall a. a -> IO (MVar a)
newMVar ResolvingState
Done
MVar (Either (IO [Thunk]) KickedThunk) -> Thunk
Thunk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar (forall a b. b -> Either a b
Right (MVar [KickedThunk] -> MVar ResolvingState -> KickedThunk
KickedThunk MVar [KickedThunk]
mv_ts MVar ResolvingState
mv_s))
kick :: Ctxt Thunk_ -> M KickedThunk_
kick :: Thunk -> IO KickedThunk
kick (Thunk MVar (Either (IO [Thunk]) KickedThunk)
t) = forall a. MVar a -> IO a
takeMVar MVar (Either (IO [Thunk]) KickedThunk)
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left IO [Thunk]
act -> do
MVar [KickedThunk]
mv_thunks <- forall a. IO (MVar a)
newEmptyMVar
MVar ResolvingState
mv_state <- forall a. a -> IO (MVar a)
newMVar ResolvingState
NotStarted
let kt :: KickedThunk
kt = MVar [KickedThunk] -> MVar ResolvingState -> KickedThunk
KickedThunk MVar [KickedThunk]
mv_thunks MVar ResolvingState
mv_state
forall a. MVar a -> a -> IO ()
putMVar MVar (Either (IO [Thunk]) KickedThunk)
t (forall a b. b -> Either a b
Right KickedThunk
kt)
[Thunk]
ts <- IO [Thunk]
act
[KickedThunk]
kts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Thunk -> IO KickedThunk
kick [Thunk]
ts
forall a. MVar a -> a -> IO ()
putMVar MVar [KickedThunk]
mv_thunks [KickedThunk]
kts
forall (f :: * -> *) a. Applicative f => a -> f a
pure KickedThunk
kt
Right KickedThunk
kt -> do
forall a. MVar a -> a -> IO ()
putMVar MVar (Either (IO [Thunk]) KickedThunk)
t (forall a b. b -> Either a b
Right KickedThunk
kt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure KickedThunk
kt
wait :: Ctxt KickedThunk_ -> M ()
wait :: KickedThunk -> IO ()
wait (KickedThunk MVar [KickedThunk]
mv_deps MVar ResolvingState
mv_s) = do
ThreadId
my_id <- IO ThreadId
myThreadId
ResolvingState
s <- forall a. MVar a -> IO a
takeMVar MVar ResolvingState
mv_s
case ResolvingState
s of
ResolvingState
Done -> forall a. MVar a -> a -> IO ()
putMVar MVar ResolvingState
mv_s ResolvingState
s
ProcessedBy ThreadId
other_id MVar ()
done_mv | ThreadId
other_id forall a. Ord a => a -> a -> Bool
< ThreadId
my_id -> do
forall a. MVar a -> a -> IO ()
putMVar MVar ResolvingState
mv_s ResolvingState
s
forall a. MVar a -> IO a
readMVar MVar ()
done_mv
ProcessedBy ThreadId
other_id MVar ()
_done_mv | ThreadId
other_id forall a. Eq a => a -> a -> Bool
== ThreadId
my_id -> do
forall a. MVar a -> a -> IO ()
putMVar MVar ResolvingState
mv_s ResolvingState
s
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ResolvingState
_ -> do
MVar ()
done_mv <- forall a. IO (MVar a)
newEmptyMVar
forall a. MVar a -> a -> IO ()
putMVar MVar ResolvingState
mv_s (ThreadId -> MVar () -> ResolvingState
ProcessedBy ThreadId
my_id MVar ()
done_mv)
[KickedThunk]
ts <- forall a. MVar a -> IO a
readMVar MVar [KickedThunk]
mv_deps
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ KickedThunk -> IO ()
wait [KickedThunk]
ts
ResolvingState
_ <- forall a. MVar a -> a -> IO a
swapMVar MVar ResolvingState
mv_s ResolvingState
Done
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done_mv ()
force :: Ctxt Thunk_ -> M ()
force :: Thunk -> IO ()
force Thunk
t = do
KickedThunk
rt <- Thunk -> IO KickedThunk
kick Thunk
t
KickedThunk -> IO ()
wait KickedThunk
rt