-- 
-- (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 = let pto = timeout opt
                       in unsafeWithPTO pto
maybeWithTOOpt opt = let pto = timeout opt
                     in maybeWithTO seq pto
#endif

unsafeWithPTO :: Maybe Int -> a -> Maybe a
#if 0
-- x #if __GLASGOW_HASKELL__ >= 702
unsafeWithPTO pto a = unsafeDupablePerformIO $ wrapExecution (
#else
unsafeWithPTO pto a = unsafePerformIO $ wrapExecution (
#endif
                                                       maybeWithTO seq pto (return $! 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 sq mbt action = maybeWithTO' sq mbt (const action)
newPTO t = return 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 mto op l r = unsafeWithPTO mto (op l 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' _   Nothing  action = do a <- action id
                                      return (Just 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' dsq (Just t) action = do tid <- myThreadId
                                      bracket (forkIO (threadDelay t >> -- hPutStrLn stderr "throwing Timeout" >>
                                                                        throwTo tid (ErrorCall "Timeout")))
                                              (\th -> {- block $ -} killThread th)
                                              (\_ -> fmap Just $ action (yield>>))
                                        `Control.Exception.catch` \(e :: SomeException) -> -- trace ("within maybeWithTO': " ++ show e) $
                                                                         return 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' dsq timeInMicroSecs action
    = do -- clk_tck <- getSysVar ClockTick
         -- let ticks = fromInteger (clk_tck * toInteger timeInMicroSecs `div` 1000000)
         resMV <- newEmptyMVar
         do
           (catchIt resMV (do
                                   tid <- myThreadId
                                   chtid <- forkIO (do threadDelay 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.
                                                       hPutStrLn stderr "writing Nothing"
                                                       putMVar resMV Nothing
                                                       hPutStrLn stderr "killing the main"
                                                       killThread tid)
                                   -- res <- action (catchYield tid resMV)
                                   res <- action (yield>>)
                                   hPutStrLn stderr "writing Just"
                                   res `dsq` putMVar resMV (Just res)
                                   hPutStrLn stderr "killing the thread for timeout"
                                   killThread chtid))
           hPutStrLn stderr "reading MV"
           readMVar resMV

wrapExecution = id
--wrapExecution = measureExecutionTime

measureExecutionTime act
    = do begin <- getCPUTime
         res <- act
         end <- getCPUTime
         hPutStrLn stderr (show (end - begin))
         return res

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

handler sv err = Control.Exception.catch (realHandler sv (err::SomeException)) (handler 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 sv err = putMVar sv Nothing

catchYield       tid sv action = Control.Exception.catch (yield >> action) (childHandler tid sv)
childHandler     tid sv err    = Control.Exception.catch (realChildHandler tid sv (err::SomeException)) (childHandler tid sv)
realChildHandler tid sv err    = do putMVar sv Nothing
                                    killThread tid
                                    error "This thread must have been killed...."
{-
wait deadline = do ticksNow <- getProcessTimes
                   let tickNow = userTime ticksNow
                   when (tickNow < deadline) $ do threadDelay 20000
                                                  wait deadline
-}