diff --git a/Data/Array/Accelerate/CUDA.hs b/Data/Array/Accelerate/CUDA.hs --- a/Data/Array/Accelerate/CUDA.hs +++ b/Data/Array/Accelerate/CUDA.hs @@ -161,14 +161,10 @@ ) where -- standard library -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding ( catch ) -#endif import Control.Exception import Control.Applicative import Control.Monad.Trans import System.IO.Unsafe -import Foreign.CUDA.Driver.Error -- friends import Data.Array.Accelerate.Trafo @@ -185,9 +181,7 @@ import Data.Array.Accelerate.Debug #endif -#include "accelerate.h" - -- Accelerate: CUDA -- ---------------- @@ -242,8 +236,6 @@ where !acc = convertAccWith config a execute = evalCUDA ctx (compileAcc acc >>= dumpStats >>= executeAcc >>= collect) - `catch` - \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) -- | Prepare and execute an embedded array program of one argument. @@ -302,11 +294,9 @@ run1AsyncIn :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> Async b run1AsyncIn ctx f = \a -> unsafePerformIO $ async (execute a) where - !acc = convertAccFun1With config f + !acc = convertAfunWith config f !afun = unsafePerformIO $ evalCUDA ctx (compileAfun acc) >>= dumpStats execute a = evalCUDA ctx (executeAfun1 afun a >>= collect) - `catch` - \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) -- TLM: We need to be very careful with run1* variants, to ensure that the -- returned closure shortcuts directly to the execution phase. diff --git a/Data/Array/Accelerate/CUDA/Array/Table.hs b/Data/Array/Accelerate/CUDA/Array/Table.hs --- a/Data/Array/Accelerate/CUDA/Array/Table.hs +++ b/Data/Array/Accelerate/CUDA/Array/Table.hs @@ -106,6 +106,7 @@ -- new :: IO MemoryTable new = do + message "initialise memory table" tbl <- HT.new ref <- newIORef tbl nrs <- N.new @@ -213,7 +214,7 @@ mr <- deRefWeak weak_ref case mr of Nothing -> message ("finalise/dead table: " ++ show key) - Just ref -> trace ("finalise: " ++ show key) $ withIORef ref (`HT.delete` key) + Just ref -> withIORef ref (`HT.delete` key) -- mc <- deRefWeak weak_ctx case mc of @@ -222,8 +223,8 @@ -- mn <- deRefWeak weak_nrs case mn of - Nothing -> trace ("finalise/dead nursery: " ++ show key) $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.free ptr) - Just nrs -> trace ("finalise/nursery: " ++ show key) $ N.insert bytes ctx nrs ptr + Nothing -> trace ("finalise/free: " ++ show key) $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.free ptr) + Just nrs -> trace ("finalise/nursery: " ++ show key) $ N.insert bytes ctx nrs ptr table_finalizer :: HashTable HostArray DeviceArray -> IO () diff --git a/Data/Array/Accelerate/CUDA/Async.hs b/Data/Array/Accelerate/CUDA/Async.hs --- a/Data/Array/Accelerate/CUDA/Async.hs +++ b/Data/Array/Accelerate/CUDA/Async.hs @@ -26,14 +26,12 @@ data Async a = Async {-# UNPACK #-} !ThreadId {-# UNPACK #-} !(MVar (Either SomeException a)) --- Fork an action to execute asynchronously. Moreover, this will be forked into --- a _bound_ thread, which allows the thread to call foreign libraries that make --- use of thread-local state, such as CUDA. +-- | Fork an action to execute asynchronously. -- async :: IO a -> IO (Async a) async action = do var <- newEmptyMVar - tid <- forkOS $ (putMVar var . Right =<< action) + tid <- forkIO $ (putMVar var . Right =<< action) `catch` \e -> putMVar var (Left e) return (Async tid var) diff --git a/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs @@ -200,7 +200,7 @@ { typename DimOut dst; - const int src = fromIndex( shIn, ix ); + const typename DimIn src = fromIndex( shIn, ix ); $items:(dst .=. prj src) if ( !ignore(dst) ) diff --git a/Data/Array/Accelerate/CUDA/Compile.hs b/Data/Array/Accelerate/CUDA/Compile.hs --- a/Data/Array/Accelerate/CUDA/Compile.hs +++ b/Data/Array/Accelerate/CUDA/Compile.hs @@ -29,6 +29,7 @@ import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.State +import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.CodeGen import Data.Array.Accelerate.CUDA.Array.Sugar import Data.Array.Accelerate.CUDA.Analysis.Launch @@ -59,6 +60,7 @@ import System.IO.Unsafe import System.Time import System.Process +import System.Mem.Weak import Text.PrettyPrint.Mainland ( ppr, renderCompact, displayLazyText ) import qualified Data.ByteString as B import qualified Data.Text.Lazy as T @@ -88,19 +90,19 @@ -- * kernel object(s) required to executed the kernel -- compileAcc :: DelayedAcc a -> CIO (ExecAcc a) -compileAcc = prepareOpenAcc +compileAcc = compileOpenAcc compileAfun :: DelayedAfun f -> CIO (ExecAfun f) -compileAfun = prepareOpenAfun +compileAfun = compileOpenAfun -prepareOpenAfun :: DelayedOpenAfun aenv f -> CIO (PreOpenAfun ExecOpenAcc aenv f) -prepareOpenAfun (Alam l) = Alam <$> prepareOpenAfun l -prepareOpenAfun (Abody b) = Abody <$> prepareOpenAcc b +compileOpenAfun :: DelayedOpenAfun aenv f -> CIO (PreOpenAfun ExecOpenAcc aenv f) +compileOpenAfun (Alam l) = Alam <$> compileOpenAfun l +compileOpenAfun (Abody b) = Abody <$> compileOpenAcc b -prepareOpenAcc :: DelayedOpenAcc aenv a -> CIO (ExecOpenAcc aenv a) -prepareOpenAcc = traverseAcc +compileOpenAcc :: DelayedOpenAcc aenv a -> CIO (ExecOpenAcc aenv a) +compileOpenAcc = traverseAcc where -- Traverse an open array expression in depth-first order. The top-level -- function traverseAcc is intended for manifest arrays that we will @@ -112,13 +114,13 @@ -- are merged at every step. -- traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> CIO (ExecOpenAcc aenv arrs) - traverseAcc Delayed{} = INTERNAL_ERROR(error) "prepareOpenAcc" "unexpected delayed array" + traverseAcc Delayed{} = INTERNAL_ERROR(error) "compileOpenAcc" "unexpected delayed array" traverseAcc topAcc@(Manifest pacc) = case pacc of -- Environment and control flow Avar ix -> node $ pure (Avar ix) - Alet a b -> node . pure =<< Alet <$> traverseAcc a <*> traverseAcc b - Apply f a -> node . pure =<< Apply <$> compileAfun f <*> traverseAcc a + Alet a b -> node . pure =<< Alet <$> traverseAcc a <*> traverseAcc b + Apply f a -> node . pure =<< Apply <$> compileOpenAfun f <*> traverseAcc a Acond p t e -> node =<< liftA3 Acond <$> travE p <*> travA t <*> travA e Atuple tup -> node =<< liftA Atuple <$> travAtup tup Aprj ix tup -> node =<< liftA (Aprj ix) <$> travA tup @@ -323,12 +325,13 @@ build1 :: DelayedOpenAcc aenv a -> CUTranslSkel aenv a -> CIO (AccKernel a) build1 acc code = do - dev <- asks deviceProperties + context <- asks activeContext + let dev = deviceProperties context table <- gets kernelTable (entry,key) <- compile table dev code let (cta,blocks,smem) = launchConfig acc dev occ (mdl,fun,occ) = unsafePerformIO $ do - m <- link table key + m <- link context table key f <- CUDA.getFun m entry l <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock o <- determineOccupancy acc dev f l @@ -360,12 +363,13 @@ -- table. This may entail waiting for the external compilation process to -- complete. If successful, the temporary files are removed. -- -link :: KernelTable -> KernelKey -> IO CUDA.Module -link table key = - let intErr = INTERNAL_ERROR(error) "link" "missing kernel entry" +link :: Context -> KernelTable -> KernelKey -> IO CUDA.Module +link context table key = + let intErr = INTERNAL_ERROR(error) "link" "missing kernel entry" + ctx = deviceContext context + weak_ctx = weakContext context in do - ctx <- CUDA.get - entry <- fromMaybe intErr `fmap` KT.lookup table key + entry <- fromMaybe intErr `fmap` KT.lookup context table key case entry of CompileProcess cufile done -> do -- Wait for the compiler to finish and load the binary object into the @@ -381,6 +385,7 @@ let cubin = replaceExtension cufile ".cubin" bin <- B.readFile cubin mdl <- CUDA.loadData bin + addFinalizer mdl (module_finalizer weak_ctx key mdl) -- Update hash tables and stash the binary object into the persistent -- cache @@ -408,6 +413,7 @@ | otherwise -> do message "re-linking module for current context" mdl <- CUDA.loadData bin + addFinalizer mdl (module_finalizer weak_ctx key mdl) KT.insert table key $! KernelObject bin (FL.cons ctx mdl active) return mdl @@ -416,7 +422,8 @@ -- compile :: KernelTable -> CUDA.DeviceProperties -> CUTranslSkel aenv a -> CIO (String, KernelKey) compile table dev cunit = do - exists <- isJust `fmap` liftIO (KT.lookup table key) + context <- asks activeContext + exists <- isJust `fmap` liftIO (KT.lookup context table key) unless exists $ do message $ unlines [ show key, T.unpack code ] nvcc <- fromMaybe (error "nvcc: command not found") <$> liftIO (findExecutable "nvcc") diff --git a/Data/Array/Accelerate/CUDA/Context.hs b/Data/Array/Accelerate/CUDA/Context.hs --- a/Data/Array/Accelerate/CUDA/Context.hs +++ b/Data/Array/Accelerate/CUDA/Context.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.Context -- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell @@ -16,7 +17,7 @@ module Data.Array.Accelerate.CUDA.Context ( -- An execution context - Context(..), create, push, destroy, + Context(..), create, push, pop, destroy, keepAlive, ) where @@ -79,14 +80,28 @@ -- {-# INLINE destroy #-} destroy :: Context -> IO () -destroy = CUDA.destroy . deviceContext +destroy (deviceContext -> ctx) = do + message dump_gc ("gc: destroy context: #" ++ show (CUDA.useContext ctx)) + CUDA.destroy ctx + -- | Push the given context onto the CPU's thread stack of current contexts. The -- context must be floating (via 'pop'), i.e. not attached to any thread. -- {-# INLINE push #-} push :: Context -> IO () -push = CUDA.push . deviceContext +push (deviceContext -> ctx) = do + message dump_gc ("gc: push context: #" ++ show (CUDA.useContext ctx)) + CUDA.push ctx + + +-- | Pop the current context. +-- +{-# INLINE pop #-} +pop :: IO () +pop = do + ctx <- CUDA.pop + message dump_gc ("gc: pop context: #" ++ show (CUDA.useContext ctx)) -- Make a weak pointer to a CUDA context. We need to be careful to put the diff --git a/Data/Array/Accelerate/CUDA/Execute.hs b/Data/Array/Accelerate/CUDA/Execute.hs --- a/Data/Array/Accelerate/CUDA/Execute.hs +++ b/Data/Array/Accelerate/CUDA/Execute.hs @@ -95,21 +95,20 @@ executeAcc !acc = executeOpenAcc acc Empty executeAfun1 :: (Arrays a, Arrays b) => ExecAfun (a -> b) -> a -> CIO b -executeAfun1 !afun !arrs - | Alam (Abody f) <- afun - = do useArrays (arrays arrs) (fromArr arrs) - executeOpenAcc f (Empty `Push` arrs) - - | otherwise - = error "the sword comes out after you swallow it, right?" - +executeAfun1 !afun !arrs = do + useArrays (arrays arrs) (fromArr arrs) + executeOpenAfun1 afun Empty arrs where useArrays :: ArraysR arrs -> arrs -> CIO () useArrays ArraysRunit () = return () useArrays (ArraysRpair r1 r0) (a1, a0) = useArrays r1 a1 >> useArrays r0 a0 useArrays ArraysRarray arr = useArray arr +executeOpenAfun1 :: PreOpenAfun ExecOpenAcc aenv (a -> b) -> Val aenv -> a -> CIO b +executeOpenAfun1 (Alam (Abody f)) aenv x = executeOpenAcc f (aenv `Push` x) +executeOpenAfun1 _ _ _ = error "the sword comes out after you swallow it, right?" + -- Evaluate an open array computation -- executeOpenAcc @@ -131,7 +130,7 @@ Alet bnd body -> executeOpenAcc body . (aenv `Push`) =<< travA bnd Atuple tup -> toTuple <$> travT tup Aprj ix tup -> evalPrj ix . fromTuple <$> travA tup - Apply f a -> executeAfun1 f =<< travA a + Apply f a -> executeOpenAfun1 f aenv =<< travA a Acond p t e -> travE p >>= \x -> if x then travA t else travA e -- Foreign diff --git a/Data/Array/Accelerate/CUDA/Foreign.hs b/Data/Array/Accelerate/CUDA/Foreign.hs --- a/Data/Array/Accelerate/CUDA/Foreign.hs +++ b/Data/Array/Accelerate/CUDA/Foreign.hs @@ -60,8 +60,6 @@ import Data.Array.Accelerate.CUDA.Array.Data import Data.Array.Accelerate.CUDA.Array.Prim ( DevicePtrs ) -import qualified Foreign.CUDA.Driver as CUDA - import Data.Dynamic import Control.Applicative import Control.Exception ( bracket_ ) @@ -149,7 +147,7 @@ -- inContext :: Context -> IO a -> IO a inContext ctx action = - bracket_ (push ctx) CUDA.pop action + bracket_ (push ctx) pop action -- |Run an IO action in the default CUDA context -- diff --git a/Data/Array/Accelerate/CUDA/Persistent.hs b/Data/Array/Accelerate/CUDA/Persistent.hs --- a/Data/Array/Accelerate/CUDA/Persistent.hs +++ b/Data/Array/Accelerate/CUDA/Persistent.hs @@ -15,11 +15,14 @@ module Data.Array.Accelerate.CUDA.Persistent ( KernelTable, KernelKey, KernelEntry(..), - new, lookup, insert, persist + new, lookup, insert, persist, + module_finalizer, + ) where -- friends +import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.FullList ( FullList ) import qualified Data.Array.Accelerate.CUDA.Debug as D import qualified Data.Array.Accelerate.CUDA.FullList as FL @@ -32,6 +35,7 @@ import System.FilePath import System.Directory import System.IO.Error +import System.Mem.Weak import Control.Applicative import Control.Concurrent import Control.Exception @@ -68,6 +72,7 @@ new :: IO KernelTable new = do + message "initialise kernel table" cacheDir <- cacheDirectory createDirectoryIfMissing True cacheDir -- @@ -80,8 +85,8 @@ -- Lookup a kernel through the two-level cache system. If the kernel is found in -- the persistent cache, it is loaded and linked into the current context. -- -lookup :: KernelTable -> KernelKey -> IO (Maybe KernelEntry) -lookup (KT kt pt) !key = do +lookup :: Context -> KernelTable -> KernelKey -> IO (Maybe KernelEntry) +lookup context (KT kt pt) !key = do -- First check the local cache. If we get a hit, this could be: -- a) currently compiling -- b) compiled, but not linked into the current context @@ -104,10 +109,10 @@ Just () -> do message "found/persistent" cubin <- () <$> cacheDirectory <*> pure (cacheFilePath key) - ctx <- CUDA.get bin <- B.readFile cubin - mdl <- CUDA.loadData bin - let obj = KernelObject bin (FL.singleton ctx mdl) + !mdl <- CUDA.loadData bin + let obj = KernelObject bin (FL.singleton (deviceContext context) mdl) + addFinalizer mdl (module_finalizer (weakContext context) key mdl) HT.insert kt key obj return $! Just obj @@ -121,6 +126,17 @@ -- insert :: KernelTable -> KernelKey -> KernelEntry -> IO () insert (KT kt _) !key !val = HT.insert kt key val + + +-- Unload a kernel module from the specified context +-- +module_finalizer :: Weak CUDA.Context -> KernelKey -> CUDA.Module -> IO () +module_finalizer weak_ctx (_,key) mdl = do + mc <- deRefWeak weak_ctx + case mc of + Nothing -> D.message D.dump_gc ("gc: finalise module/dead context: " ++ show key) + Just ctx -> D.message D.dump_gc ("gc: finalise module: " ++ show ctx ++ "/" ++ show key) + >> bracket_ (CUDA.push ctx) CUDA.pop (CUDA.unload mdl) -- Local cache ----------------------------------------------------------------- diff --git a/Data/Array/Accelerate/CUDA/State.hs b/Data/Array/Accelerate/CUDA/State.hs --- a/Data/Array/Accelerate/CUDA/State.hs +++ b/Data/Array/Accelerate/CUDA/State.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.State -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee @@ -33,16 +35,23 @@ import Data.Array.Accelerate.CUDA.Analysis.Device -- library +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding ( catch ) +#endif import Control.Applicative ( Applicative ) -import Control.Exception ( bracket_ ) +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 +#include "accelerate.h" + -- Execution State -- --------------- @@ -72,12 +81,14 @@ -- {-# NOINLINE evalCUDA #-} evalCUDA :: Context -> CIO a -> IO a -evalCUDA !ctx !acc - = bracket_ setup teardown - $ evalStateT (runReaderT (runCIO acc) ctx) theState +evalCUDA !ctx !acc = + runInBoundThread (bracket_ setup teardown action) + `catch` + \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) where - teardown = CUDA.pop >> performGC setup = push ctx + teardown = pop >> performGC + action = evalStateT (runReaderT (runCIO acc) ctx) theState -- Top-level mutable state diff --git a/accelerate-cuda.cabal b/accelerate-cuda.cabal --- a/accelerate-cuda.cabal +++ b/accelerate-cuda.cabal @@ -1,5 +1,5 @@ Name: accelerate-cuda -Version: 0.13.0.1 +Version: 0.13.0.2 Cabal-version: >= 1.6 Tested-with: GHC >= 7.4 Build-type: Custom diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for accelerate-cuda 0.13.0.0. +# Generated by GNU Autoconf 2.69 for accelerate-cuda 0.14.0.0. # # Report bugs to . # @@ -579,8 +579,8 @@ # Identity of this package. PACKAGE_NAME='accelerate-cuda' PACKAGE_TARNAME='accelerate-cuda' -PACKAGE_VERSION='0.13.0.0' -PACKAGE_STRING='accelerate-cuda 0.13.0.0' +PACKAGE_VERSION='0.14.0.0' +PACKAGE_STRING='accelerate-cuda 0.14.0.0' PACKAGE_BUGREPORT='accelerate-haskell@googlegroups.com' PACKAGE_URL='' @@ -1192,7 +1192,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures accelerate-cuda 0.13.0.0 to adapt to many kinds of systems. +\`configure' configures accelerate-cuda 0.14.0.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1253,7 +1253,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of accelerate-cuda 0.13.0.0:";; + short | recursive ) echo "Configuration of accelerate-cuda 0.14.0.0:";; esac cat <<\_ACEOF @@ -1339,7 +1339,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -accelerate-cuda configure 0.13.0.0 +accelerate-cuda configure 0.14.0.0 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1394,7 +1394,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by accelerate-cuda $as_me 0.13.0.0, which was +It was created by accelerate-cuda $as_me 0.14.0.0, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2954,7 +2954,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by accelerate-cuda $as_me 0.13.0.0, which was +This file was extended by accelerate-cuda $as_me 0.14.0.0, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -3007,7 +3007,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -accelerate-cuda config.status 0.13.0.0 +accelerate-cuda config.status 0.14.0.0 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/cubits/accelerate_cuda_shape.h b/cubits/accelerate_cuda_shape.h --- a/cubits/accelerate_cuda_shape.h +++ b/cubits/accelerate_cuda_shape.h @@ -23,7 +23,7 @@ * future hardware gains better 64-bit support and/or we need to access very * large arrays. * - * typedef Int32 Ix; + * typedef Int64 Ix; */ typedef Int32 Ix; typedef void* DIM0;