{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Threads (
createScope,
forkThread,
forkThread_,
linkThread,
waitThread,
waitThread_,
waitThread',
waitThreads',
cancelThread,
concurrentThreads,
concurrentThreads_,
raceThreads,
raceThreads_,
Thread,
unThread,
) where
import Control.Concurrent (ThreadId, forkIO, killThread)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVarIO)
import Control.Exception.Safe qualified as Safe (catch, finally, onException, throw)
import Control.Monad (
forM,
forM_,
void,
)
import Control.Monad.Reader.Class (MonadReader (ask))
import Core.Data.Structures
import Core.Program.Context
import Core.Program.Logging
import Core.System.Base
import Core.Text.Rope
data Thread α = Thread
{ forall α. Thread α -> ThreadId
threadPointerOf :: ThreadId
, forall α. Thread α -> MVar (Either SomeException α)
threadOutcomeOf :: MVar (Either SomeException α)
}
unThread :: Thread α -> ThreadId
unThread :: forall α. Thread α -> ThreadId
unThread = forall α. Thread α -> ThreadId
threadPointerOf
createScope :: Program τ α -> Program τ α
createScope :: forall τ α. Program τ α -> Program τ α
createScope Program τ α
program = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
TVar (Set ThreadId)
scope <- forall a. a -> IO (TVar a)
newTVarIO forall ε. Key ε => Set ε
emptySet
let context' :: Context τ
context' =
Context τ
context
{ $sel:currentScopeFrom:Context :: TVar (Set ThreadId)
currentScopeFrom = TVar (Set ThreadId)
scope
}
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
Safe.finally
( do
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context' Program τ α
program
)
( do
Set ThreadId
pointers <- forall a. TVar a -> IO a
readTVarIO TVar (Set ThreadId)
scope
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set ThreadId
pointers ThreadId -> IO ()
killThread
)
forkThread :: Program τ α -> Program τ (Thread α)
forkThread :: forall τ α. Program τ α -> Program τ (Thread α)
forkThread Program τ α
program = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
let i :: MVar Time
i = forall τ. Context τ -> MVar Time
startTimeFrom Context τ
context
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
let scope :: TVar (Set ThreadId)
scope = forall τ. Context τ -> TVar (Set ThreadId)
currentScopeFrom Context τ
context
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Time
start <- forall a. MVar a -> IO a
readMVar MVar Time
i
MVar Time
i' <- forall a. a -> IO (MVar a)
newMVar Time
start
Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v
MVar Datum
v' <- forall a. a -> IO (MVar a)
newMVar Datum
datum
let context' :: Context τ
context' =
Context τ
context
{ $sel:startTimeFrom:Context :: MVar Time
startTimeFrom = MVar Time
i'
, $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v'
}
MVar (Either SomeException α)
outcome <- forall a. IO (MVar a)
newEmptyMVar
ThreadId
pointer <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
( do
α
actual <- forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context' Program τ α
program
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException α)
outcome (forall a b. b -> Either a b
Right α
actual)
)
( \(SomeException
e :: SomeException) -> do
let text :: Rope
text = forall α. Textual α => α -> Rope
intoRope (forall e. Exception e => e -> String
displayException SomeException
e)
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context' forall a b. (a -> b) -> a -> b
$ do
forall τ. Rope -> Program τ ()
internal Rope
"Uncaught exception ending thread"
forall τ. Rope -> Program τ ()
internal (Rope
"e = " forall a. Semigroup a => a -> a -> a
<> Rope
text)
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException α)
outcome (forall a b. a -> Either a b
Left SomeException
e)
)
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set ThreadId)
scope (\Set ThreadId
pointers -> forall ε. Key ε => ε -> Set ε -> Set ε
insertElement ThreadId
pointer Set ThreadId
pointers)
forall (m :: * -> *) a. Monad m => a -> m a
return
( Thread
{ threadPointerOf :: ThreadId
threadPointerOf = ThreadId
pointer
, threadOutcomeOf :: MVar (Either SomeException α)
threadOutcomeOf = MVar (Either SomeException α)
outcome
}
)
forkThread_ :: Program τ α -> Program τ ()
forkThread_ :: forall τ α. Program τ α -> Program τ ()
forkThread_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall τ α. Program τ α -> Program τ (Thread α)
forkThread
waitThread :: Thread α -> Program τ α
waitThread :: forall α τ. Thread α -> Program τ α
waitThread Thread α
thread = do
Either SomeException α
result <- forall α τ. Thread α -> Program τ (Either SomeException α)
waitThread' Thread α
thread
case Either SomeException α
result of
Left SomeException
problem -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw SomeException
problem
Right α
actual -> forall (f :: * -> *) a. Applicative f => a -> f a
pure α
actual
waitThread_ :: Thread α -> Program τ ()
waitThread_ :: forall α τ. Thread α -> Program τ ()
waitThread_ Thread α
thread = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall α τ. Thread α -> Program τ α
waitThread Thread α
thread)
waitThread' :: Thread α -> Program τ (Either SomeException α)
waitThread' :: forall α τ. Thread α -> Program τ (Either SomeException α)
waitThread' Thread α
thread = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
let scope :: TVar (Set ThreadId)
scope = forall τ. Context τ -> TVar (Set ThreadId)
currentScopeFrom Context τ
context
let outcome :: MVar (Either SomeException α)
outcome = forall α. Thread α -> MVar (Either SomeException α)
threadOutcomeOf Thread α
thread
let pointer :: ThreadId
pointer = forall α. Thread α -> ThreadId
threadPointerOf Thread α
thread
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
Safe.onException
( do
Either SomeException α
result <- forall a. MVar a -> IO a
readMVar MVar (Either SomeException α)
outcome
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set ThreadId)
scope (\Set ThreadId
pointers -> forall ε. Key ε => ε -> Set ε -> Set ε
removeElement ThreadId
pointer Set ThreadId
pointers)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException α
result
)
( do
ThreadId -> IO ()
killThread ThreadId
pointer
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set ThreadId)
scope (\Set ThreadId
pointers -> forall ε. Key ε => ε -> Set ε -> Set ε
removeElement ThreadId
pointer Set ThreadId
pointers)
)
waitThreads' :: [Thread α] -> Program τ [Either SomeException α]
waitThreads' :: forall α τ. [Thread α] -> Program τ [Either SomeException α]
waitThreads' [Thread α]
threads = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
Safe.onException
( do
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Thread α]
threads forall α τ. Thread α -> Program τ (Either SomeException α)
waitThread'
)
( do
let scope :: TVar (Set ThreadId)
scope = forall τ. Context τ -> TVar (Set ThreadId)
currentScopeFrom Context τ
context
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Thread α]
threads forall a b. (a -> b) -> a -> b
$ \Thread α
thread -> do
let pointer :: ThreadId
pointer = forall α. Thread α -> ThreadId
threadPointerOf Thread α
thread
ThreadId -> IO ()
killThread ThreadId
pointer
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set ThreadId)
scope (\Set ThreadId
pointers -> forall ε. Key ε => ε -> Set ε -> Set ε
removeElement ThreadId
pointer Set ThreadId
pointers)
)
cancelThread :: Thread α -> Program τ ()
cancelThread :: forall α τ. Thread α -> Program τ ()
cancelThread Thread α
thread = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
ThreadId -> IO ()
killThread (forall α. Thread α -> ThreadId
threadPointerOf Thread α
thread)
concurrentThreads :: Program τ α -> Program τ β -> Program τ (α, β)
concurrentThreads :: forall τ α β. Program τ α -> Program τ β -> Program τ (α, β)
concurrentThreads Program τ α
one Program τ β
two = do
forall τ α. Program τ α -> Program τ α
createScope forall a b. (a -> b) -> a -> b
$ do
Thread α
a1 <- forall τ α. Program τ α -> Program τ (Thread α)
forkThread Program τ α
one
Thread β
a2 <- forall τ α. Program τ α -> Program τ (Thread α)
forkThread Program τ β
two
α
result1 <- forall α τ. Thread α -> Program τ α
waitThread Thread α
a1
β
result2 <- forall α τ. Thread α -> Program τ α
waitThread Thread β
a2
forall (f :: * -> *) a. Applicative f => a -> f a
pure (α
result1, β
result2)
concurrentThreads_ :: Program τ α -> Program τ β -> Program τ ()
concurrentThreads_ :: forall τ α β. Program τ α -> Program τ β -> Program τ ()
concurrentThreads_ Program τ α
one Program τ β
two = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall τ α β. Program τ α -> Program τ β -> Program τ (α, β)
concurrentThreads Program τ α
one Program τ β
two)
raceThreads :: Program τ α -> Program τ β -> Program τ (Either α β)
raceThreads :: forall τ α β. Program τ α -> Program τ β -> Program τ (Either α β)
raceThreads Program τ α
one Program τ β
two = do
forall τ α. Program τ α -> Program τ α
createScope forall a b. (a -> b) -> a -> b
$ do
MVar (Either α β)
outcome <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall a. IO (MVar a)
newEmptyMVar
Thread ()
_ <- forall τ α. Program τ α -> Program τ (Thread α)
forkThread forall a b. (a -> b) -> a -> b
$ do
!α
result1 <- Program τ α
one
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> a -> IO ()
putMVar MVar (Either α β)
outcome (forall a b. a -> Either a b
Left α
result1)
Thread ()
_ <- forall τ α. Program τ α -> Program τ (Thread α)
forkThread forall a b. (a -> b) -> a -> b
$ do
!β
result2 <- Program τ β
two
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> a -> IO ()
putMVar MVar (Either α β)
outcome (forall a b. b -> Either a b
Right β
result2)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> IO a
readMVar MVar (Either α β)
outcome
raceThreads_ :: Program τ α -> Program τ β -> Program τ ()
raceThreads_ :: forall τ α β. Program τ α -> Program τ β -> Program τ ()
raceThreads_ Program τ α
one Program τ β
two = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall τ α β. Program τ α -> Program τ β -> Program τ (Either α β)
raceThreads Program τ α
one Program τ β
two)
linkThread :: Thread α -> Program τ ()
linkThread :: forall α τ. Thread α -> Program τ ()
linkThread Thread α
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# DEPRECATED linkThread "Exceptions are bidirectional so linkThread no longer needed" #-}