{-# LANGUAGE NamedFieldPuns #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute.Event
-- Copyright   : [2014..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.LLVM.PTX.Execute.Event (

  Event,
  create, destroy, query, waypoint, after, block,

) where

-- accelerate
import Data.Array.Accelerate.Lifetime
import qualified Data.Array.Accelerate.Array.Remote.LRU             as Remote

import Data.Array.Accelerate.LLVM.PTX.Array.Remote                  ( )
import Data.Array.Accelerate.LLVM.PTX.Target                        ( PTX(..) )
import Data.Array.Accelerate.LLVM.State
import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug
import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Stream

-- cuda
import Foreign.CUDA.Driver.Error
import qualified Foreign.CUDA.Driver.Event                          as Event
import qualified Foreign.CUDA.Driver.Stream                         as Stream

import Control.Exception
import Control.Monad.State


-- | Events can be used for efficient device-side synchronisation between
-- execution streams and between the host.
--
type Event = Lifetime Event.Event


-- | Create a new event. It will not be automatically garbage collected, and is
-- not suitable for timing purposes.
--
{-# INLINEABLE create #-}
create :: LLVM PTX Event
create :: LLVM PTX Event
create = do
  Event
e     <- LLVM PTX Event
create'
  Event
event <- IO Event -> LLVM PTX Event
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Event -> LLVM PTX Event) -> IO Event -> LLVM PTX Event
forall a b. (a -> b) -> a -> b
$ Event -> IO Event
forall a. a -> IO (Lifetime a)
newLifetime Event
e
  IO () -> LLVM PTX ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LLVM PTX ()) -> IO () -> LLVM PTX ()
forall a b. (a -> b) -> a -> b
$ Event -> IO () -> IO ()
forall a. Lifetime a -> IO () -> IO ()
addFinalizer Event
event (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
message (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"destroy " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
showEvent Event
e
                                   Event -> IO ()
Event.destroy Event
e
  Event -> LLVM PTX Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
event

create' :: LLVM PTX Event.Event
create' :: LLVM PTX Event
create' = do
  PTX{MemoryTable
ptxMemoryTable :: PTX -> MemoryTable
ptxMemoryTable :: MemoryTable
ptxMemoryTable} <- (PTX -> PTX) -> LLVM PTX PTX
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PTX -> PTX
forall t. t -> t
llvmTarget
  Maybe Event
me      <- String -> LLVM PTX (Maybe Event) -> LLVM PTX (Maybe Event)
forall (m :: * -> *) a.
MonadIO m =>
String -> m (Maybe a) -> m (Maybe a)
attempt String
"create/new" (IO (Maybe Event) -> LLVM PTX (Maybe Event)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Event) -> LLVM PTX (Maybe Event))
-> (IO Event -> IO (Maybe Event))
-> IO Event
-> LLVM PTX (Maybe Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Event -> IO (Maybe Event)
forall a. IO a -> IO (Maybe a)
catchOOM (IO Event -> LLVM PTX (Maybe Event))
-> IO Event -> LLVM PTX (Maybe Event)
forall a b. (a -> b) -> a -> b
$ [EventFlag] -> IO Event
Event.create [EventFlag
Event.DisableTiming])
             LLVM PTX (Maybe Event)
-> LLVM PTX (Maybe Event) -> LLVM PTX (Maybe Event)
forall (m :: * -> *) a.
MonadIO m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
`orElse` do
               MemoryTable (RemotePtr (LLVM PTX)) (Maybe Event) -> LLVM PTX ()
forall (m :: * -> *) task.
(HasCallStack, RemoteMemory m, MonadIO m) =>
MemoryTable (RemotePtr m) task -> m ()
Remote.reclaim MemoryTable (RemotePtr (LLVM PTX)) (Maybe Event)
MemoryTable
ptxMemoryTable
               IO (Maybe Event) -> LLVM PTX (Maybe Event)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Event) -> LLVM PTX (Maybe Event))
-> IO (Maybe Event) -> LLVM PTX (Maybe Event)
forall a b. (a -> b) -> a -> b
$ do
                 String -> IO ()
message String
"create/new: failed (purging)"
                 IO Event -> IO (Maybe Event)
forall a. IO a -> IO (Maybe a)
catchOOM (IO Event -> IO (Maybe Event)) -> IO Event -> IO (Maybe Event)
forall a b. (a -> b) -> a -> b
$ [EventFlag] -> IO Event
Event.create [EventFlag
Event.DisableTiming]
  case Maybe Event
me of
    Just Event
e  -> Event -> LLVM PTX Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
e
    Maybe Event
Nothing -> IO Event -> LLVM PTX Event
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Event -> LLVM PTX Event) -> IO Event -> LLVM PTX Event
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
message String
"create/new: failed (non-recoverable)"
      CUDAException -> IO Event
forall e a. Exception e => e -> IO a
throwIO (Status -> CUDAException
ExitCode Status
OutOfMemory)

  where
    catchOOM :: IO a -> IO (Maybe a)
    catchOOM :: IO a -> IO (Maybe a)
catchOOM IO a
it =
      (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just IO a
it IO (Maybe a) -> (CUDAException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \CUDAException
e -> case CUDAException
e of
                                    ExitCode Status
OutOfMemory -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                                    CUDAException
_                    -> CUDAException -> IO (Maybe a)
forall e a. Exception e => e -> IO a
throwIO CUDAException
e

    attempt :: MonadIO m => String -> m (Maybe a) -> m (Maybe a)
    attempt :: String -> m (Maybe a) -> m (Maybe a)
attempt String
msg m (Maybe a)
ea = do
      Maybe a
ma <- m (Maybe a)
ea
      case Maybe a
ma of
        Maybe a
Nothing -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Just a
a  -> do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
message String
msg)
                      Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)

    orElse :: MonadIO m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
    orElse :: m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orElse m (Maybe a)
ea m (Maybe a)
eb = do
      Maybe a
ma <- m (Maybe a)
ea
      case Maybe a
ma of
        Just a
a  -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
        Maybe a
Nothing -> m (Maybe a)
eb


-- | Delete an event
--
{-# INLINEABLE destroy #-}
destroy :: Event -> IO ()
destroy :: Event -> IO ()
destroy = Event -> IO ()
forall a. Lifetime a -> IO ()
finalize

-- | Create a new event marker that will be filled once execution in the
-- specified stream has completed all previously submitted work.
--
{-# INLINEABLE waypoint #-}
waypoint :: Stream -> LLVM PTX Event
waypoint :: Stream -> LLVM PTX Event
waypoint Stream
stream = do
  Event
event <- LLVM PTX Event
create
  IO Event -> LLVM PTX Event
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Event -> LLVM PTX Event) -> IO Event -> LLVM PTX Event
forall a b. (a -> b) -> a -> b
$
    Stream -> (Stream -> IO Event) -> IO Event
forall a b. Lifetime a -> (a -> IO b) -> IO b
withLifetime Stream
stream  ((Stream -> IO Event) -> IO Event)
-> (Stream -> IO Event) -> IO Event
forall a b. (a -> b) -> a -> b
$ \Stream
s -> do
      Event -> (Event -> IO Event) -> IO Event
forall a b. Lifetime a -> (a -> IO b) -> IO b
withLifetime Event
event ((Event -> IO Event) -> IO Event)
-> (Event -> IO Event) -> IO Event
forall a b. (a -> b) -> a -> b
$ \Event
e -> do
        String -> IO ()
message (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"add waypoint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
showEvent Event
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in stream " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Stream -> String
showStream Stream
s
        Event -> Maybe Stream -> IO ()
Event.record Event
e (Stream -> Maybe Stream
forall a. a -> Maybe a
Just Stream
s)
        Event -> IO Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
event

-- | Make all future work submitted to the given stream wait until the event
-- reports completion before beginning execution.
--
{-# INLINEABLE after #-}
after :: Event -> Stream -> IO ()
after :: Event -> Stream -> IO ()
after Event
event Stream
stream =
  Stream -> (Stream -> IO ()) -> IO ()
forall a b. Lifetime a -> (a -> IO b) -> IO b
withLifetime Stream
stream ((Stream -> IO ()) -> IO ()) -> (Stream -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Stream
s ->
  Event -> (Event -> IO ()) -> IO ()
forall a b. Lifetime a -> (a -> IO b) -> IO b
withLifetime Event
event  ((Event -> IO ()) -> IO ()) -> (Event -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Event
e -> do
    String -> IO ()
message (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
showEvent Event
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in stream " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Stream -> String
showStream Stream
s
    Event -> Maybe Stream -> [WaitFlag] -> IO ()
Event.wait Event
e (Stream -> Maybe Stream
forall a. a -> Maybe a
Just Stream
s) []

-- | Block the calling thread until the event is recorded
--
{-# INLINEABLE block #-}
block :: Event -> IO ()
block :: Event -> IO ()
block Event
event =
  Event -> (Event -> IO ()) -> IO ()
forall a b. Lifetime a -> (a -> IO b) -> IO b
withLifetime Event
event ((Event -> IO ()) -> IO ()) -> (Event -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Event
e -> do
    String -> IO ()
message (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"blocked on event " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
showEvent Event
e
    Event -> IO ()
Event.block Event
e

-- | Test whether an event has completed
--
{-# INLINEABLE query #-}
query :: Event -> IO Bool
query :: Event -> IO Bool
query Event
event = Event -> (Event -> IO Bool) -> IO Bool
forall a b. Lifetime a -> (a -> IO b) -> IO b
withLifetime Event
event Event -> IO Bool
Event.query


-- Debug
-- -----

{-# INLINE trace #-}
trace :: String -> IO a -> IO a
trace :: String -> IO a -> IO a
trace String
msg IO a
next = do
  Flag -> String -> IO ()
Debug.traceIO Flag
Debug.dump_sched (String
"event: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)
  IO a
next

{-# INLINE message #-}
message :: String -> IO ()
message :: String -> IO ()
message String
s = String
s String -> IO () -> IO ()
forall a. String -> IO a -> IO a
`trace` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-# INLINE showEvent #-}
showEvent :: Event.Event -> String
showEvent :: Event -> String
showEvent (Event.Event Ptr ()
e) = Ptr () -> String
forall a. Show a => a -> String
show Ptr ()
e

{-# INLINE showStream #-}
showStream :: Stream.Stream -> String
showStream :: Stream -> String
showStream (Stream.Stream Ptr ()
s) = Ptr () -> String
forall a. Show a => a -> String
show Ptr ()
s