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

import Control.Concurrent(forkIO, killThread, myThreadId, ThreadId, threadDelay, yield)
import Control.Concurrent.SampleVar
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)
import Control.Monad(when)

import System.IO

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

-- import 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
-- x #ifdef CHTO
unsafeWithPTO pto a = unsafePerformIO $ wrapExecution (
                                                       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やSampleVarを作るoverheadは無視できそう．
-- data CHTO a = CHTO {timeInMicroSecs :: Int, sv :: SampleVar (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 = timeout t (action undefined) -- System.Timeout.timeoutを使うと速くなる．

--  '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)
         resSV <- newEmptySampleVar
         do
	   forkIO (catchIt resSV (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.
                                                       writeSampleVar resSV Nothing
                                                       killThread tid)
		                   -- res <- action (catchYield tid resSV)
                                   res <- action (yield>>)
		                   res `dsq` writeSampleVar resSV (Just res)
                                   killThread chtid))
           readSampleVar resSV

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 :: (SampleVar (Maybe a)) -> IO () -> IO ()
#ifdef SHOWEXCEPTIONS
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) $ writeSampleVar sv Nothing
realHandler sv (ErrorCall str) = trace str $ writeSampleVar sv Nothing
#endif
-}
realHandler sv err = writeSampleVar 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 writeSampleVar 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
-}