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 tout :: Int
tout tid :: 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 "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
* 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 "Time limit exceeded")
                                   ThreadId -> IO ()
killThread ThreadId
tid -- Die now, srsly.
                                   String -> IO ()
forall a. HasCallStack => String -> a
error "Time expired"
                       () -> IO ()
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 :: (t -> MVar a -> IO t1) -> t -> IO a
block f :: t -> MVar a -> IO t1
f opts :: 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 opts :: 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' opts :: Options
opts mvar :: 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 (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 "Done.")
                                      IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: 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 x :: 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