    module Mueval.Parallel where

    import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay, throwTo, ThreadId)
    import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar)
    import Control.Exception.Extensible as E (ErrorCall(..),SomeException,catch)
    import Control.Monad (void)
    import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering))
    import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce))

    import Mueval.Interpreter
    import Mueval.ArgsParse

    -- | Fork off a thread which will sleep and then kill off the specified thread.
    watchDog :: Int -> ThreadId -> IO ()
    watchDog :: Int -> ThreadId -> IO ()
    watchDog Int
    tout ThreadId
    tid = do Handler
    _ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
    installHandler Signal
    sigXCPU
                                              (IO () -> Handler
    CatchOnce
                                               (IO () -> Handler) -> IO () -> Handler
    forall a b. (a -> b) -> a -> b
    $ ThreadId -> ErrorCall -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    tid (ErrorCall -> IO ()) -> ErrorCall -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String -> ErrorCall
    ErrorCall String
    "Time limit exceeded.") Maybe SignalSet
    forall a. Maybe a
    Nothing
                           ThreadId
    _ <- IO () -> IO ThreadId
    forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $ do
                                       Int -> IO ()
    threadDelay (Int
    tout Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    700000)
                                       -- Time's up. It's a good day to die.
                                       ThreadId -> ErrorCall -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    tid (String -> ErrorCall
    ErrorCall String
    "Time limit exceeded")
                                       ThreadId -> IO ()
    killThread ThreadId
    tid -- Die now, srsly.
                                       String -> IO ()
    forall a. HasCallStack => String -> a
    error String
    "Time expired"
                           () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () -- Never reached. Either we error out here
                                     -- or the evaluation thread finishes.

    -- | A basic blocking operation.
    block :: (t -> MVar a -> IO t1) -> t -> IO a
    block :: forall t a t1. (t -> MVar a -> IO t1) -> t -> IO a
    block t -> MVar a -> IO t1
    f t
    opts = do  MVar a
    mvar <- IO (MVar a)
    forall a. IO (MVar a)
    newEmptyMVar
                       t1
    _ <- t -> MVar a -> IO t1
    f t
    opts MVar a
    mvar
                       MVar a -> IO a
    forall a. MVar a -> IO a
    takeMVar MVar a
    mvar -- block until ErrorCall, or forkedMain succeeds

    -- | Using MVars, block on 'forkedMain' until it finishes.
    forkedMain :: Options -> IO ()
    forkedMain :: Options -> IO ()
    forkedMain Options
    opts = IO String -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void ((Options -> MVar String -> IO ThreadId) -> Options -> IO String
    forall t a t1. (t -> MVar a -> IO t1) -> t -> IO a
    block Options -> MVar String -> IO ThreadId
    forkedMain' Options
    opts)

    -- | Set a 'watchDog' on this thread, and then continue on with whatever.
    forkedMain' :: Options -> MVar String -> IO ThreadId
    forkedMain' :: Options -> MVar String -> IO ThreadId
    forkedMain' Options
    opts MVar String
    mvar = do ThreadId
    mainId <- IO ThreadId
    myThreadId
                               Int -> ThreadId -> IO ()
    watchDog (Options -> Int
    timeLimit Options
    opts) ThreadId
    mainId
                               Handle -> BufferMode -> IO ()
    hSetBuffering Handle
    stdout BufferMode
    NoBuffering

                               -- Our modules and expression are set up. Let's do stuff.
                               IO () -> IO ThreadId
    forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $ (Options -> IO ()
    interpreterSession (Options -> Options
    checkImport Options
    opts)
                                                                IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> MVar String -> String -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar String
    mvar String
    "Done.")
                                          IO () -> (SomeException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `E.catch` \SomeException
    e -> ThreadId -> SomeException -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    mainId (SomeException
    e::SomeException)
                                                                 -- bounce exceptions to the main thread,
                                                                 -- so they are reliably printed out
              where checkImport :: Options -> Options
    checkImport Options
    x = if Options -> Bool
    noImports Options
    x then Options
    x{modules :: Maybe [String]
    modules=Maybe [String]
    forall a. Maybe a
    Nothing} else Options
    x