Add Acc debugging functionality similar to Debug.Trace

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

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

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

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) ||]

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

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.

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