{-# LANGUAGE NamedFieldPuns #-}
module Data.Array.Accelerate.LLVM.PTX.Execute.Event (
Event,
create, destroy, query, waypoint, after, block,
) where
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
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
type Event = Lifetime Event.Event
{-# 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
{-# INLINEABLE destroy #-}
destroy :: Event -> IO ()
destroy :: Event -> IO ()
destroy = Event -> IO ()
forall a. Lifetime a -> IO ()
finalize
{-# 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
{-# 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) []
{-# 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
{-# 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
{-# 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