module Data.Array.Accelerate.CUDA.State (
CIO, Context, evalCUDA,
defaultContext, deviceProperties, activeContext, kernelTable, memoryTable, streamReservoir,
) where
import Data.Array.Accelerate.Error
import Data.Array.Accelerate.CUDA.Context
import Data.Array.Accelerate.CUDA.Debug ( message, dump_gc )
import Data.Array.Accelerate.CUDA.Persistent as KT ( KernelTable, new )
import Data.Array.Accelerate.CUDA.Array.Table as MT ( MemoryTable, new )
import Data.Array.Accelerate.CUDA.Execute.Stream as ST ( Reservoir, new )
import Data.Array.Accelerate.CUDA.Analysis.Device
import Control.Applicative ( Applicative )
import Control.Concurrent ( runInBoundThread )
import Control.Exception ( catch, bracket_ )
import Control.Monad.Trans ( MonadIO )
import Control.Monad.Reader ( MonadReader, ReaderT(..), runReaderT )
import Control.Monad.State.Strict ( MonadState, StateT(..), evalStateT )
import System.Mem ( performGC )
import System.IO.Unsafe ( unsafePerformIO )
import Foreign.CUDA.Driver.Error
import qualified Foreign.CUDA.Driver as CUDA
data State = State {
memoryTable :: !MemoryTable,
kernelTable :: !KernelTable,
streamReservoir :: !Reservoir
}
newtype CIO a = CIO {
runCIO :: ReaderT Context (StateT State IO) a
}
deriving ( Functor, Applicative, Monad, MonadIO
, MonadReader Context, MonadState State )
activeContext :: Context -> Context
activeContext = id
evalCUDA :: Context -> CIO a -> IO a
evalCUDA !ctx !acc =
runInBoundThread (bracket_ setup teardown action)
`catch`
\e -> $internalError "unhandled" (show (e :: CUDAException))
where
setup = push ctx
teardown = pop >> performGC
action = evalStateT (runReaderT (runCIO acc) ctx) theState
theState :: State
theState
= unsafePerformIO
$ do message dump_gc "gc: initialise CUDA state"
mtb <- keepAlive =<< MT.new
ktb <- keepAlive =<< KT.new
rsv <- keepAlive =<< ST.new
return $! State mtb ktb rsv
defaultContext :: Context
defaultContext = unsafePerformIO $ do
message dump_gc "gc: initialise default context"
CUDA.initialise []
(dev,_) <- selectBestDevice
create dev [CUDA.SchedAuto]