diff --git a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/AST.hs b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/AST.hs index 2c10046e5..1feb9e1ac 100644 --- a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/AST.hs +++ b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/AST.hs @@ -65,6 +65,11 @@ data PreOpenAccCommand acc arch aenv a where Anil :: PreOpenAccCommand acc arch aenv () + Atrace :: String + -> acc arch aenv arrs1 + -> acc arch aenv arrs2 + -> PreOpenAccCommand acc arch aenv arrs2 + Apply :: ArraysR bs -> PreOpenAfun (acc arch) aenv (as -> bs) -> acc arch aenv as @@ -194,6 +199,7 @@ instance HasArraysR (acc arch) => HasArraysR (PreOpenAccCommand acc arch) where arraysR (Unit tp _) = TupRsingle $ ArrayR ShapeRz tp arraysR (Apair a1 a2) = arraysR a1 `TupRpair` arraysR a2 arraysR Anil = TupRunit + arraysR (Atrace _ _ a2) = arraysR a2 arraysR (Apply repr _ _) = repr arraysR (Aforeign repr _ _ _) = repr arraysR (Acond _ a1 _) = arraysR a1 diff --git a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/CodeGen.hs b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/CodeGen.hs index 94a788c0d..574d33af0 100644 --- a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/CodeGen.hs +++ b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/CodeGen.hs @@ -83,6 +83,7 @@ llvmOfPreOpenAcc uid pacc aenv = evalCodeGen $ Awhile{} -> unexpectedError Apair{} -> unexpectedError Anil -> unexpectedError + Atrace{} -> unexpectedError Use{} -> unexpectedError Unit{} -> unexpectedError Aforeign{} -> unexpectedError diff --git a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Compile.hs b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Compile.hs index 31b986deb..d1e632b40 100644 --- a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Compile.hs +++ b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Compile.hs @@ -149,6 +149,7 @@ compileOpenAcc = traverseAcc Acond p t e -> plain =<< liftA3 AST.Acond <$> travE p <*> travA t <*> travA e Apair a1 a2 -> plain =<< liftA2 AST.Apair <$> travA a1 <*> travA a2 Anil -> plain $ pure AST.Anil + Atrace msg a1 a2 -> plain =<< liftA2 (AST.Atrace msg) <$> travA a1 <*> travA a2 -- Foreign arrays operations Aforeign repr ff afun a -> foreignA repr ff afun a diff --git a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Embed.hs b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Embed.hs index 02312f72b..062a725ff 100644 --- a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Embed.hs +++ b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Embed.hs @@ -164,6 +164,7 @@ liftPreOpenAccCommand arch pacc = Unit tp e -> [|| Unit $$(liftTypeR tp) $$(liftE e) ||] Apair a1 a2 -> [|| Apair $$(liftA a1) $$(liftA a2) ||] Anil -> [|| Anil ||] + Atrace msg a1 a2 -> [|| Atrace $$(TH.unsafeTExpCoerce $ return $ TH.LitE $ TH.StringL msg) $$(liftA a1) $$(liftA a2) ||] Apply repr f a -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||] Acond p t e -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||] Awhile p f a -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||] diff --git a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute.hs b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute.hs index d0884a5a0..59ed383ad 100644 --- a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute.hs +++ b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute.hs @@ -31,7 +31,7 @@ import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalCoerceScalar ) +import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalCoerceScalar, atraceOp ) import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape @@ -51,6 +51,7 @@ import Data.Array.Accelerate.LLVM.Link import qualified Data.Array.Accelerate.LLVM.AST as AST import Control.Monad +import Control.Monad.Trans ( liftIO ) import System.IO.Unsafe import Prelude hiding ( exp, map, unzip, scanl, scanr, scanl1, scanr1 ) @@ -279,6 +280,12 @@ executeOpenAcc !topAcc !aenv = travA topAcc Anil -> return () Alloc repr sh -> allocate repr sh Apply _ f a -> travAF f =<< spawn (travA a) + Atrace msg a1 a2 -> do + let repr = arraysR a1 + a1' <- travA a1 >>= blockArrays repr >>= copyToHost repr + liftIO $ atraceOp msg repr a1' + travA a2 + -- We need quite some type applications in the rules for acond and awhile, and cannot use do notation. -- For some unknown reason, GHC will "simplify" 'FutureArraysR arch a' to 'FutureR arch a', which is not sound. -- It then complains that 'FutureR arch a' isn't assignable to 'FutureArraysR arch a'. By adding explicit diff --git a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute/Async.hs b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute/Async.hs index 58d0e9413..642864f13 100644 --- a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute/Async.hs +++ b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Execute/Async.hs @@ -22,10 +22,11 @@ import Data.Array.Accelerate.LLVM.State ( LLVM ) import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Type +import Control.Monad.Trans ( MonadIO ) import GHC.Stack -class Monad (Par arch) => Async arch where +class (Monad (Par arch), MonadIO (Par arch)) => Async arch where -- | The monad parallel computations will be executed in. Presumably a stack -- with the LLVM monad at the base. diff --git a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Link.hs b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Link.hs index 3f567a244..d15244b2c 100644 --- a/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Link.hs +++ b/accelerate-llvm/src/Data/Array/Accelerate/LLVM/Link.hs @@ -122,6 +122,7 @@ linkOpenAcc = travA Awhile p f a -> Awhile <$> travAF p <*> travAF f <*> travA a Acond p t e -> Acond p <$> travA t <*> travA e Apair a1 a2 -> Apair <$> travA a1 <*> travA a2 + Atrace msg a1 a2 -> Atrace msg <$> travA a1 <*> travA a2 Anil -> return Anil Reshape shr s ix -> Reshape shr s <$> pure ix Aforeign s r f a -> Aforeign s r f <$> travA a