-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE CPP, ScopedTypeVariables #-}
module MagicHaskeller.TimeOut where

import Control.Concurrent(forkIO, killThread, myThreadId, ThreadId, threadDelay, yield)
import Control.Concurrent.MVar
import Control.Exception -- (catch, Exception(..))
-- import System.Posix.Unistd(getSysVar, SysVar(..))
-- import System.Posix.Process(getProcessTimes, ProcessTimes(..))
-- import System.Posix.Types(ClockTick)
import System.CPUTime
import System.IO.Unsafe(unsafePerformIO)
#if __GLASGOW_HASKELL__ >=702
import System.IO.Unsafe(unsafeDupablePerformIO)
#endif
import Control.Monad(when)

import System.IO

import Debug.Trace -- This IS necessary to monitor errors in the subprocs.

import qualified System.Timeout

import MagicHaskeller.Options(Opt(..))
#ifdef FORCIBLETO
import qualified MagicHaskeller.ForcibleTO as ForcibleTO

unsafeWithPTOOpt :: ForcibleTO.Byte a => Opt b -> a -> Maybe a
unsafeWithPTOOpt opt = let pto = timeout opt
                       in if forcibleTimeout opt then ForcibleTO.unsafeWithPTO pto else unsafeWithPTO pto
maybeWithTOOpt opt = let pto = timeout opt
                     in if forcibleTimeout opt then ForcibleTO.maybeWithTO pto else maybeWithTO seq pto
#else
unsafeWithPTOOpt :: Opt a -> a -> Maybe a
unsafeWithPTOOpt Opt a
opt = let pto :: Maybe Int
pto = Opt a -> Maybe Int
forall a. Opt a -> Maybe Int
timeout Opt a
opt
                       in Maybe Int -> a -> Maybe a
forall a. Maybe Int -> a -> Maybe a
unsafeWithPTO Maybe Int
pto
maybeWithTOOpt :: Opt a -> IO a -> IO (Maybe a)
maybeWithTOOpt Opt a
opt = let pto :: Maybe Int
pto = Opt a -> Maybe Int
forall a. Opt a -> Maybe Int
timeout Opt a
opt
                     in (a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO a -> IO () -> IO ()
seq Maybe Int
pto
#endif

unsafeWithPTO :: Maybe Int -> a -> Maybe a
#if 0
-- x #if __GLASGOW_HASKELL__ >= 702
unsafeWithPTO pto a = unsafeDupablePerformIO $ wrapExecution (
#else
unsafeWithPTO :: Maybe Int -> a -> Maybe a
unsafeWithPTO Maybe Int
pto a
a = IO (Maybe a) -> Maybe a
forall a. IO a -> a
unsafePerformIO (IO (Maybe a) -> Maybe a) -> IO (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> IO (Maybe a)
forall a. a -> a
wrapExecution (
#endif
                                                       (a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO a -> IO () -> IO ()
seq Maybe Int
pto (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! a
a)
                                                      )
maybeWithTO :: (a -> IO () -> IO ()) -- ^ seq or deepSeq(=Control.Parallel.Strategies.sforce). For our purposes seq is enough, because @a@ is either 'Bool' or 'Ordering'.
            -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO :: (a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO a -> IO () -> IO ()
sq Maybe Int
mbt IO a
action = (a -> IO () -> IO ())
-> Maybe Int -> ((IO Any -> IO Any) -> IO a) -> IO (Maybe a)
forall a b.
(a -> IO () -> IO ())
-> Maybe Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)
maybeWithTO' a -> IO () -> IO ()
sq Maybe Int
mbt (IO a -> (IO Any -> IO Any) -> IO a
forall a b. a -> b -> a
const IO a
action)
newPTO :: a -> m a
newPTO a
t = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t
{- x
-- x #else
unsafeWithPTO _ = Just
maybeWithTO :: c -> b -> IO a -> IO (Maybe a)
maybeWithTO _ _ action = do a <- action
                            return (Just a)
newPTO = error "not implemented on this platform."
-- x #endif
-}
unsafeOpWithPTO :: Maybe Int -> (a->b->c) -> a -> b -> Maybe c
unsafeOpWithPTO :: Maybe Int -> (a -> b -> c) -> a -> b -> Maybe c
unsafeOpWithPTO Maybe Int
mto a -> b -> c
op a
l b
r = Maybe Int -> c -> Maybe c
forall a. Maybe Int -> a -> Maybe a
unsafeWithPTO Maybe Int
mto (a -> b -> c
op a
l b
r)

-- ソースをみた感じ，MVarやMSampleVarを作るoverheadは無視できそう．
-- data CHTO a = CHTO {timeInMicroSecs :: Int, sv :: MSampleVar (Maybe a)}

{-
unsafeEvaluate :: Int -> a -> Maybe a
unsafeEvaluate t e = unsafePerformIO (withTO t (return e)) -- Should I use Control.OldException.evaluate? I do not want to evaluate long lists deeply. 
-}

maybeWithTO' :: (a -> IO () -> IO ()) -> Maybe Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)
maybeWithTO' :: (a -> IO () -> IO ())
-> Maybe Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)
maybeWithTO' a -> IO () -> IO ()
_   Maybe Int
Nothing  (IO b -> IO b) -> IO a
action = do a
a <- (IO b -> IO b) -> IO a
action IO b -> IO b
forall a. a -> a
id
                                      Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
--maybeWithTO' dsq (Just t) action = withTO' dsq t action -- 古いやつ
{-
maybeWithTO' dsq (Just t) action = System.Timeout.timeout t (action undefined) -- System.Timeout.timeoutを使うと速くなる．
                                        `catch` \(e :: SomeException) -> -- trace ("within maybeWithTO': " ++ show e) $
                                                                         return Nothing
-}

maybeWithTO' a -> IO () -> IO ()
dsq (Just Int
t) (IO b -> IO b) -> IO a
action = do ThreadId
tid <- IO ThreadId
myThreadId
                                      IO ThreadId
-> (ThreadId -> IO ())
-> (ThreadId -> IO (Maybe a))
-> IO (Maybe a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO () -> IO ThreadId
forkIO (Int -> IO ()
threadDelay Int
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> -- hPutStrLn stderr "throwing Timeout" >>
                                                                        ThreadId -> ErrorCall -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (String -> ErrorCall
ErrorCall String
"Timeout")))
                                              (\ThreadId
th -> {- block $ -} ThreadId -> IO ()
killThread ThreadId
th)
                                              (\ThreadId
_ -> (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ (IO b -> IO b) -> IO a
action (IO ()
yieldIO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>))
                                        IO (Maybe a) -> (SomeException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` \(SomeException
e :: SomeException) -> -- trace ("within maybeWithTO': " ++ show e) $
                                                                         Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

--  'withTO' creates CHTO every time it is called. Currently unused.
-- withTO :: DeepSeq a => Int -> IO a -> IO (Maybe a)
-- withTO timeInMicroSecs action = withTO' deepSeq timeInMicroSecs (const action)
withTO' :: (a -> IO () -> IO ()) -> Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)
withTO' :: (a -> IO () -> IO ())
-> Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)
withTO' a -> IO () -> IO ()
dsq Int
timeInMicroSecs (IO b -> IO b) -> IO a
action
    = do -- clk_tck <- getSysVar ClockTick
         -- let ticks = fromInteger (clk_tck * toInteger timeInMicroSecs `div` 1000000)
         MVar (Maybe a)
resMV <- IO (MVar (Maybe a))
forall a. IO (MVar a)
newEmptyMVar
         do
           (MVar (Maybe a) -> IO () -> IO ()
forall a. MVar (Maybe a) -> IO () -> IO ()
catchIt MVar (Maybe a)
resMV (do
                                   ThreadId
tid <- IO ThreadId
myThreadId
                                   ThreadId
chtid <- IO () -> IO ThreadId
forkIO (do Int -> IO ()
threadDelay Int
timeInMicroSecs
                                                       -- wait deadline -- this line makes sure that timeInMicroSecs has really passed in the process time, but I guess this has no sense, because userTime is shared among Concurrent Haskell threads.
                                                       Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"writing Nothing"
                                                       MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
resMV Maybe a
forall a. Maybe a
Nothing
                                                       Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"killing the main"
                                                       ThreadId -> IO ()
killThread ThreadId
tid)
                                   -- res <- action (catchYield tid resMV)
                                   a
res <- (IO b -> IO b) -> IO a
action (IO ()
yieldIO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>)
                                   Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"writing Just"
                                   a
res a -> IO () -> IO ()
`dsq` MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
resMV (a -> Maybe a
forall a. a -> Maybe a
Just a
res)
                                   Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"killing the thread for timeout"
                                   ThreadId -> IO ()
killThread ThreadId
chtid))
           Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"reading MV"
           MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar MVar (Maybe a)
resMV

wrapExecution :: a -> a
wrapExecution = a -> a
forall a. a -> a
id
--wrapExecution = measureExecutionTime

measureExecutionTime :: IO b -> IO b
measureExecutionTime IO b
act
    = do Integer
begin <- IO Integer
getCPUTime
         b
res <- IO b
act
         Integer
end <- IO Integer
getCPUTime
         Handle -> String -> IO ()
hPutStrLn Handle
stderr (Integer -> String
forall a. Show a => a -> String
show (Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
begin))
         b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res

-- Catch exceptions such as stack space overflow
catchIt :: (MVar (Maybe a)) -> IO () -> IO ()
#ifdef REALDYNAMIC
catchIt sv act = act -- disable
#else
catchIt :: MVar (Maybe a) -> IO () -> IO ()
catchIt MVar (Maybe a)
sv IO ()
act = IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO ()
act (MVar (Maybe a) -> SomeException -> IO ()
forall a. MVar (Maybe a) -> SomeException -> IO ()
handler MVar (Maybe a)
sv)
#endif

handler :: MVar (Maybe a) -> SomeException -> IO ()
handler MVar (Maybe a)
sv SomeException
err = IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch (MVar (Maybe a) -> SomeException -> IO ()
forall a p. MVar (Maybe a) -> p -> IO ()
realHandler MVar (Maybe a)
sv (SomeException
err::SomeException)) (MVar (Maybe a) -> SomeException -> IO ()
handler MVar (Maybe a)
sv)
-- realHandler sv (AsyncException ThreadKilled) = return () -- If the thread is killed by ^C (i.e. not by another thread), sv is left empty. So, the parent thread can catch ^C while waiting.
{-
#ifdef REALDYNAMIC
-- realHandler sv err = trace (show err) $ putMVar sv Nothing
realHandler sv (ErrorCall str) = trace str $ putMVar sv Nothing
#endif
-}
realHandler :: MVar (Maybe a) -> p -> IO ()
realHandler MVar (Maybe a)
sv p
err = MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
sv Maybe a
forall a. Maybe a
Nothing

catchYield :: ThreadId -> MVar (Maybe a) -> IO a -> IO a
catchYield       ThreadId
tid MVar (Maybe a)
sv IO a
action = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch (IO ()
yield IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
action) (ThreadId -> MVar (Maybe a) -> SomeException -> IO a
forall a a. ThreadId -> MVar (Maybe a) -> SomeException -> IO a
childHandler ThreadId
tid MVar (Maybe a)
sv)
childHandler :: ThreadId -> MVar (Maybe a) -> SomeException -> IO a
childHandler     ThreadId
tid MVar (Maybe a)
sv SomeException
err    = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch (ThreadId -> MVar (Maybe a) -> SomeException -> IO a
forall a p b. ThreadId -> MVar (Maybe a) -> p -> IO b
realChildHandler ThreadId
tid MVar (Maybe a)
sv (SomeException
err::SomeException)) (ThreadId -> MVar (Maybe a) -> SomeException -> IO a
childHandler ThreadId
tid MVar (Maybe a)
sv)
realChildHandler :: ThreadId -> MVar (Maybe a) -> p -> IO b
realChildHandler ThreadId
tid MVar (Maybe a)
sv p
err    = do MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
sv Maybe a
forall a. Maybe a
Nothing
                                    ThreadId -> IO ()
killThread ThreadId
tid
                                    String -> IO b
forall a. HasCallStack => String -> a
error String
"This thread must have been killed...."
{-
wait deadline = do ticksNow <- getProcessTimes
                   let tickNow = userTime ticksNow
                   when (tickNow < deadline) $ do threadDelay 20000
                                                  wait deadline
-}