TimeOut.hs

{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}

-- |
-- Module      :  Test.ChasingBottoms.TimeOut
-- Copyright   :  (c) Nils Anders Danielsson 2004-2019
-- License     :  See the file LICENCE.
--
-- Maintainer  :  http://www.cse.chalmers.se/~nad/
-- Stability   :  experimental
-- Portability :  non-portable (preemptive scheduling)
--
-- When dealing with \"hard bottoms\", i.e. non-terminating
-- computations that do not result in exceptions, the following functions
-- may be handy.
--
-- Note that a computation is considered to have terminated when it
-- has reached weak head normal form (i.e. something distinct from
-- bottom).

module Test.ChasingBottoms.TimeOut
  ( Result(..)
  , timeOut
  , timeOut'
  , timeOutMicro
  , timeOutMicro'
  ) where

import Control.Concurrent
import Data.Dynamic
import qualified Control.Exception as E

import {-# SOURCE #-} qualified Test.ChasingBottoms.IsBottom as B

data Result a
  = Value a
  | NonTermination
  | Exception E.SomeException
    deriving (Show, Typeable)

-- | @'timeOut' n c@ runs @c@ for at most @n@ seconds (modulo
-- scheduling issues).
--
--   * If the computation terminates before that, then @'Value' v@ is
--     returned, where @v@ is the resulting value. Note that this
--     value may be equal to bottom, e.g. if @c = 'return'
--     'B.bottom'@.
--
--   * If the computation does not terminate, then 'NonTermination' is
--     returned.
--
--   * If the computation raises an exception, then @'Exception' e@ is
--     returned, where @e@ is the exception.
--
-- Note that a user-defined exception is used to terminate the
-- computation, so if @c@ catches all exceptions, or blocks
-- asynchronous exceptions, then 'timeOut' may fail to function
-- properly.

timeOut :: Int -> IO a -> IO (Result a)
timeOut = timeOutMicro . (* 10^6)

-- | 'timeOutMicro' takes a delay in microseconds. Note that the
-- resolution is not necessarily very high (the last time I checked it
-- was 0.02 seconds when using the standard runtime system settings
-- for GHC).

timeOutMicro :: Int -> IO a -> IO (Result a)
timeOutMicro delay io = do
  mv <- newEmptyMVar
  let putException = putMVar mv . Exception
  ioThread <- forkIO $
    (io >>= putMVar mv . Value)
    `E.catch` (\(e :: E.SomeException) ->
                case E.fromException e of
                  Just Die -> return ()  -- Thread properly killed.
                  Nothing  -> putException e)
  reaper <- forkIO $ do
    threadDelay delay
    putMVar mv NonTermination
  result <- takeMVar mv
  killThread' ioThread
  killThread reaper
  return result

-- Since 'ioThread' above should return exceptions raised in the code
-- it seems like a bad idea to kill the thread using killThread, which
-- raises @'AsyncException' 'ThreadKilled'@. We use the locally
-- defined type 'Die' instead.

data Die = Die deriving (Show, Typeable)

instance E.Exception Die

killThread' threadId = E.throwTo threadId Die

-- | 'timeOut'' is a variant which can be used for pure
-- computations. The definition,
--
-- @
--   'timeOut'' n = 'timeOut' n . 'E.evaluate'
-- @
--
-- ensures that @'timeOut'' 1 'B.bottom'@ usually returns @'Exception'
-- \<something\>@. (@'timeOut' 1 ('return' 'B.bottom')@ usually
-- returns @'Value' 'B.bottom'@; in other words, the computation
-- reaches whnf almost immediately, defeating the purpose of the
-- time-out.)

timeOut' :: Int -> a -> IO (Result a)
timeOut' n = timeOut n . E.evaluate

-- | 'timeOutMicro'' is the equivalent variant of 'timeOutMicro':
--
-- @
--  'timeOutMicro'' n = 'timeOutMicro' n . 'E.evaluate'
-- @

timeOutMicro' :: Int -> a -> IO (Result a)
timeOutMicro' n = timeOutMicro n . E.evaluate

------------------------------------------------------------------------

-- There shouldn't be any memory leaks in the code above. Profiling
-- the code below also seems to suggest that there aren't any
-- problems. However, GHCi (with :set +r) eats up more and more memory
-- if the computation below is rerun a couple of times. Hmm, that
-- seems to be the case also when running simply (reverse [1..]). It
-- probably means that GHCi never releases any memory.

main = do
  let n = 1; d = 000000
  {-# SCC "a" #-} timeOut' n (reverse [1..]) >>= print
  threadDelay d
  {-# SCC "b" #-} timeOut' n (reverse [1..]) >>= print
  threadDelay d
  {-# SCC "c" #-} timeOut' n (reverse [1..]) >>= print
  threadDelay d
  {-# SCC "d" #-} timeOut' n (reverse [1..]) >>= print