accelerate-cuda 0.13.0.1 → 0.13.0.2
raw patch · 13 files changed
+109/−74 lines, 13 files
Files
- Data/Array/Accelerate/CUDA.hs +1/−11
- Data/Array/Accelerate/CUDA/Array/Table.hs +4/−3
- Data/Array/Accelerate/CUDA/Async.hs +2/−4
- Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs +1/−1
- Data/Array/Accelerate/CUDA/Compile.hs +25/−18
- Data/Array/Accelerate/CUDA/Context.hs +18/−3
- Data/Array/Accelerate/CUDA/Execute.hs +8/−9
- Data/Array/Accelerate/CUDA/Foreign.hs +1/−3
- Data/Array/Accelerate/CUDA/Persistent.hs +22/−6
- Data/Array/Accelerate/CUDA/State.hs +16/−5
- accelerate-cuda.cabal +1/−1
- configure +9/−9
- cubits/accelerate_cuda_shape.h +1/−1
Data/Array/Accelerate/CUDA.hs view
@@ -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.
Data/Array/Accelerate/CUDA/Array/Table.hs view
@@ -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 ()
Data/Array/Accelerate/CUDA/Async.hs view
@@ -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)
Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs view
@@ -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) )
Data/Array/Accelerate/CUDA/Compile.hs view
@@ -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")
Data/Array/Accelerate/CUDA/Context.hs view
@@ -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
Data/Array/Accelerate/CUDA/Execute.hs view
@@ -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
Data/Array/Accelerate/CUDA/Foreign.hs view
@@ -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 --
Data/Array/Accelerate/CUDA/Persistent.hs view
@@ -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 -----------------------------------------------------------------
Data/Array/Accelerate/CUDA/State.hs view
@@ -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
accelerate-cuda.cabal view
@@ -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
configure view
@@ -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 <accelerate-haskell@googlegroups.com>. #@@ -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\\"
cubits/accelerate_cuda_shape.h view
@@ -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;