{-# LANGUAGE BangPatterns #-}
module Data.Array.Accelerate.LLVM.PTX.Array.Table (
MemoryTable,
new,
) where
import Data.Array.Accelerate.LLVM.PTX.Context ( Context, withContext )
import qualified Data.Array.Accelerate.Array.Remote as Remote
import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug
import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event
import qualified Foreign.CUDA.Ptr as CUDA
import qualified Foreign.CUDA.Driver as CUDA
import Text.Printf
type MemoryTable = Remote.MemoryTable CUDA.DevicePtr (Maybe Event)
{-# INLINEABLE new #-}
new :: Context -> IO MemoryTable
new :: Context -> IO MemoryTable
new !Context
ctx = (forall a. DevicePtr a -> IO ()) -> IO MemoryTable
forall (ptr :: * -> *) task.
(forall a. ptr a -> IO ()) -> IO (MemoryTable ptr task)
Remote.new forall a. DevicePtr a -> IO ()
freeRemote
where
freeRemote :: CUDA.DevicePtr a -> IO ()
freeRemote :: DevicePtr a -> IO ()
freeRemote !DevicePtr a
ptr = do
String -> IO ()
message (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"freeRemote %s" (DevicePtr a -> String
forall a. Show a => a -> String
show DevicePtr a
ptr))
Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withContext Context
ctx (DevicePtr a -> IO ()
forall a. DevicePtr a -> IO ()
CUDA.free DevicePtr a
ptr)
{-# INLINE trace #-}
trace :: String -> IO a -> IO a
trace :: String -> IO a -> IO a
trace String
msg IO a
next = Flag -> String -> IO ()
Debug.traceIO Flag
Debug.dump_gc (String
"gc: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg) IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 ()