Merge branch 'wip/debug'

robbert-vdh · Feb 19, 2021 · b23f41f · b23f41f
2 parents 39b1266 + c8aa7e3
commit b23f41f
Show file tree

Hide file tree

Showing 35 changed files with 603 additions and 523 deletions.
diff --git a/accelerate.cabal b/accelerate.cabal
@@ -329,6 +329,7 @@ library
         Data.Array.Accelerate.Data.Maybe
         Data.Array.Accelerate.Data.Monoid
         Data.Array.Accelerate.Data.Ratio
+        Data.Array.Accelerate.Debug.Trace
         Data.Array.Accelerate.Unsafe
 
         -- For backend development (hidden)
@@ -346,8 +347,8 @@ library
         Data.Array.Accelerate.Array.Remote.Table
         Data.Array.Accelerate.Array.Unique
         Data.Array.Accelerate.Async
-        Data.Array.Accelerate.Debug
         Data.Array.Accelerate.Error
+        Data.Array.Accelerate.Debug.Internal
         Data.Array.Accelerate.Lifetime
         Data.Array.Accelerate.Pretty
         Data.Array.Accelerate.Representation.Array
@@ -398,12 +399,13 @@ library
         Data.Array.Accelerate.Classes.RealFloat
         Data.Array.Accelerate.Classes.RealFrac
         Data.Array.Accelerate.Classes.ToFloating
-        Data.Array.Accelerate.Debug.Clock
-        Data.Array.Accelerate.Debug.Flags
-        Data.Array.Accelerate.Debug.Monitoring
-        Data.Array.Accelerate.Debug.Stats
-        Data.Array.Accelerate.Debug.Timed
-        Data.Array.Accelerate.Debug.Trace
+        Data.Array.Accelerate.Debug.Internal.Clock
+        Data.Array.Accelerate.Debug.Internal.Flags
+        Data.Array.Accelerate.Debug.Internal.Graph
+        Data.Array.Accelerate.Debug.Internal.Monitoring
+        Data.Array.Accelerate.Debug.Internal.Stats
+        Data.Array.Accelerate.Debug.Internal.Timed
+        Data.Array.Accelerate.Debug.Internal.Trace
         Data.Array.Accelerate.Language
         Data.Array.Accelerate.Lift
         Data.Array.Accelerate.Orphans

diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs
@@ -290,11 +290,6 @@ module Data.Array.Accelerate (
   Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,
   Stencil3x5x5, Stencil5x5x5,
 
-  -- ** Tracing
-  -- $tracing
-  --
-  atrace, atraceArray, atraceId, atraceExp,
-
   -- -- ** Sequence operations
   -- collect,
 
@@ -700,17 +695,3 @@ arrayReshape = S.reshape
 --  * <https://hackage.haskell.org/package/accelerate-io-vector accelerate-io-vector>: efficient boxed and unboxed one-dimensional arrays
 --
 
--- $tracing
---
--- The 'atrace', 'atraceArray', 'atraceId', and 'atraceExp' functions print
--- messages to an output stream. They are intended for \"printf
--- debugging\", that is: tracing the flow of execution and printing
--- interesting values.
---
--- Note that arrays are printed in their internal representation (using
--- 'Data.Array.Accelerate.Sugar.Array.ArraysR'), which causes that tuples
--- or custom data types are shown differently.
---
--- These functions have the same caveats as those defined in "Debug.Trace".
---
-
diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs
@@ -77,7 +77,7 @@ module Data.Array.Accelerate.AST (
   -- * Internal AST
   -- ** Array computations
   Afun, PreAfun, OpenAfun, PreOpenAfun(..),
-  Acc, OpenAcc(..), PreOpenAcc(..), Direction(..),
+  Acc, OpenAcc(..), PreOpenAcc(..), Direction(..), Message(..),
   ALeftHandSide, ArrayVar, ArrayVars,
 
   -- ** Scalar expressions
@@ -124,6 +124,7 @@ module Data.Array.Accelerate.AST (
   liftBoundary,
   liftPrimConst,
   liftPrimFun,
+  liftMessage,
 
   -- ** Miscellaneous
   showPreAccOp,
@@ -149,6 +150,7 @@ import Data.Primitive.Vec
 
 import Control.DeepSeq
 import Data.Kind
+import Data.Maybe
 import Language.Haskell.TH                                          ( Q, TExp )
 import qualified Language.Haskell.TH.Syntax as TH
 import Prelude
@@ -195,6 +197,12 @@ type ArrayVars aenv = Vars ArrayR aenv
 type PrimBool    = TAG
 type PrimMaybe a = (TAG, ((), a))
 
+-- Trace messages
+data Message a where
+  Message :: (a -> String)                    -- embedded show
+          -> Maybe (Q (TExp (a -> String)))   -- lifted version of show, for TH
+          -> String
+          -> Message a
 
 -- | Collective array computations parametrised over array variables
 -- represented with de Bruijn indices.
@@ -273,7 +281,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where
               -> acc             aenv arrs                      -- initial value
               -> PreOpenAcc  acc aenv arrs
 
-  Atrace      :: String
+  Atrace      :: Message              arrs1
               -> acc             aenv arrs1
               -> acc             aenv arrs2
               -> PreOpenAcc  acc aenv arrs2
@@ -974,13 +982,16 @@ rnfPreOpenAcc rnfA pacc =
 
       rnfB :: ArrayR (Array sh e) -> Boundary aenv' (Array sh e) -> ()
       rnfB = rnfBoundary
+
+      rnfM :: Message a -> ()
+      rnfM (Message f g msg) = f `seq` rnfMaybe (\x -> x `seq` ()) g `seq` rnf msg
   in
   case pacc of
     Alet lhs bnd body         -> rnfALeftHandSide lhs `seq` rnfA bnd `seq` rnfA body
     Avar var                  -> rnfArrayVar var
     Apair as bs               -> rnfA as `seq` rnfA bs
     Anil                      -> ()
-    Atrace msg as bs          -> rnf msg `seq` rnfA as `seq` rnfA bs
+    Atrace msg as bs          -> rnfM msg `seq` rnfA as `seq` rnfA bs
     Apply repr afun acc       -> rnfTupR rnfArrayR repr `seq` rnfAF afun `seq` rnfA acc
     Aforeign repr asm afun a  -> rnfTupR rnfArrayR repr `seq` rnf (strForeign asm) `seq` rnfAF afun `seq` rnfA a
     Acond p a1 a2             -> rnfE p `seq` rnfA a1 `seq` rnfA a2
@@ -1182,14 +1193,13 @@ liftPreOpenAcc liftA pacc =
 
       liftB :: ArrayR (Array sh e) -> Boundary aenv (Array sh e) -> Q (TExp (Boundary aenv (Array sh e)))
       liftB = liftBoundary
-
   in
   case pacc of
     Alet lhs bnd body         -> [|| Alet $$(liftALeftHandSide lhs) $$(liftA bnd) $$(liftA body) ||]
     Avar var                  -> [|| Avar $$(liftArrayVar var) ||]
     Apair as bs               -> [|| Apair $$(liftA as) $$(liftA bs) ||]
     Anil                      -> [|| Anil ||]
-    Atrace msg as bs          -> [|| Atrace $$(TH.unsafeTExpCoerce $ return $ TH.LitE $ TH.StringL msg) $$(liftA as) $$(liftA bs) ||]
+    Atrace msg as bs          -> [|| Atrace $$(liftMessage (arraysR as) msg) $$(liftA as) $$(liftA bs) ||]
     Apply repr f a            -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||]
     Aforeign repr asm f a     -> [|| Aforeign $$(liftArraysR repr) $$(liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||]
     Acond p t e               -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||]
@@ -1210,16 +1220,14 @@ liftPreOpenAcc liftA pacc =
     Permute f d p a           -> [|| Permute $$(liftF f) $$(liftA d) $$(liftF p) $$(liftA a) ||]
     Backpermute shr sh p a    -> [|| Backpermute $$(liftShapeR shr) $$(liftE sh) $$(liftF p) $$(liftA a) ||]
     Stencil sr tp f b a       ->
-      let
-        TupRsingle (ArrayR shr _) = arraysR a
-        repr = ArrayR shr $ stencilEltR sr
-      in [|| Stencil $$(liftStencilR sr) $$(liftTypeR tp) $$(liftF f) $$(liftB repr b) $$(liftA a) ||]
+      let TupRsingle (ArrayR shr _) = arraysR a
+          repr = ArrayR shr $ stencilEltR sr
+       in [|| Stencil $$(liftStencilR sr) $$(liftTypeR tp) $$(liftF f) $$(liftB repr b) $$(liftA a) ||]
     Stencil2 sr1 sr2 tp f b1 a1 b2 a2 ->
-      let
-        TupRsingle (ArrayR shr _) = arraysR a1
-        repr1 = ArrayR shr $ stencilEltR sr1
-        repr2 = ArrayR shr $ stencilEltR sr2
-      in [|| Stencil2 $$(liftStencilR sr1) $$(liftStencilR sr2) $$(liftTypeR tp) $$(liftF f) $$(liftB repr1 b1) $$(liftA a1) $$(liftB repr2 b2) $$(liftA a2) ||]
+      let TupRsingle (ArrayR shr _) = arraysR a1
+          repr1 = ArrayR shr $ stencilEltR sr1
+          repr2 = ArrayR shr $ stencilEltR sr2
+       in [|| Stencil2 $$(liftStencilR sr1) $$(liftStencilR sr2) $$(liftTypeR tp) $$(liftF f) $$(liftB repr1 b1) $$(liftA a1) $$(liftB repr2 b2) $$(liftA a2) ||]
 
 
 liftALeftHandSide :: ALeftHandSide arrs aenv aenv' -> Q (TExp (ALeftHandSide arrs aenv aenv'))
@@ -1232,6 +1240,19 @@ liftDirection :: Direction -> Q (TExp Direction)
 liftDirection LeftToRight = [|| LeftToRight ||]
 liftDirection RightToLeft = [|| RightToLeft ||]
 
+liftMessage :: ArraysR a -> Message a -> Q (TExp (Message a))
+liftMessage aR (Message _ fmt msg) =
+  let
+      -- We (ironically?) can't lift TExp, so nested occurrences must fall
+      -- back to displaying in representation format
+      fmtR :: ArraysR arrs' -> Q (TExp (arrs' -> String))
+      fmtR TupRunit                         = [|| \() -> "()" ||]
+      fmtR (TupRsingle (ArrayR ShapeRz eR)) = [|| \as -> showElt $$(liftTypeR eR) $ linearIndexArray $$(liftTypeR eR) as 0 ||]
+      fmtR (TupRsingle (ArrayR shR eR))     = [|| \as -> showArray (showsElt $$(liftTypeR eR)) (ArrayR $$(liftShapeR shR) $$(liftTypeR eR)) as ||]
+      fmtR aR'                              = [|| \as -> showArrays $$(liftArraysR aR') as ||]
+  in
+  [|| Message $$(fromMaybe (fmtR aR) fmt) Nothing $$(TH.unsafeTExpCoerce $ return $ TH.LitE $ TH.StringL msg) ||]
+
 liftMaybe :: (a -> Q (TExp a)) -> Maybe a -> Q (TExp (Maybe a))
 liftMaybe _ Nothing  = [|| Nothing ||]
 liftMaybe f (Just x) = [|| Just $$(f x) ||]

diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs
@@ -165,34 +165,34 @@ encodePreOpenAcc options encodeAcc pacc =
         | otherwise       = encodeTypeR $ expType e
   in
   case pacc of
-    Alet lhs bnd body            -> intHost $(hashQ "Alet")        <> encodeLeftHandSide encodeArrayType lhs <> travA bnd <> travA body
-    Avar (Var repr v)            -> intHost $(hashQ "Avar")        <> encodeArrayType repr <> deep (encodeIdx v)
-    Apair a1 a2                  -> intHost $(hashQ "Apair")       <> travA a1 <> travA a2
-    Anil                         -> intHost $(hashQ "Anil")
-    Atrace msg as bs             -> intHost $(hashQ "Atrace")      <> intHost (Hashable.hash msg) <> travA as <> travA bs
-    Apply _ f a                  -> intHost $(hashQ "Apply")       <> travAF f <> travA a
-    Aforeign _ _ f a             -> intHost $(hashQ "Aforeign")    <> travAF f <> travA a
-    Use repr a                   -> intHost $(hashQ "Use")         <> encodeArrayType repr <> deep (encodeArray a)
-    Awhile p f a                 -> intHost $(hashQ "Awhile")      <> travAF f <> travAF p <> travA a
-    Unit _ e                     -> intHost $(hashQ "Unit")        <> travE e
-    Generate _ e f               -> intHost $(hashQ "Generate")    <> deepE e <> travF f
+    Alet lhs bnd body               -> intHost $(hashQ "Alet")        <> encodeLeftHandSide encodeArrayType lhs <> travA bnd <> travA body
+    Avar (Var repr v)               -> intHost $(hashQ "Avar")        <> encodeArrayType repr <> deep (encodeIdx v)
+    Apair a1 a2                     -> intHost $(hashQ "Apair")       <> travA a1 <> travA a2
+    Anil                            -> intHost $(hashQ "Anil")
+    Atrace (Message _ _ msg) as bs  -> intHost $(hashQ "Atrace")      <> intHost (Hashable.hash msg) <> travA as <> travA bs
+    Apply _ f a                     -> intHost $(hashQ "Apply")       <> travAF f <> travA a
+    Aforeign _ _ f a                -> intHost $(hashQ "Aforeign")    <> travAF f <> travA a
+    Use repr a                      -> intHost $(hashQ "Use")         <> encodeArrayType repr <> deep (encodeArray a)
+    Awhile p f a                    -> intHost $(hashQ "Awhile")      <> travAF f <> travAF p <> travA a
+    Unit _ e                        -> intHost $(hashQ "Unit")        <> travE e
+    Generate _ e f                  -> intHost $(hashQ "Generate")    <> deepE e <> travF f
     -- We don't need to encode the type of 'e' when perfect is False, as 'e' is an expression of type Bool.
     -- We thus use `deep (travE e)` instead of `deepE e`.
-    Acond e a1 a2                -> intHost $(hashQ "Acond")       <> deep (travE e) <> travA a1 <> travA a2
-    Reshape _ sh a               -> intHost $(hashQ "Reshape")     <> deepE sh <> travA a
-    Backpermute _ sh f a         -> intHost $(hashQ "Backpermute") <> deepE sh <> travF f  <> travA a
-    Transform _ sh f1 f2 a       -> intHost $(hashQ "Transform")   <> deepE sh <> travF f1 <> travF f2 <> travA a
-    Replicate spec ix a          -> intHost $(hashQ "Replicate")   <> deepE ix <> travA a  <> encodeSliceIndex spec
-    Slice spec a ix              -> intHost $(hashQ "Slice")       <> deepE ix <> travA a  <> encodeSliceIndex spec
-    Map _ f a                    -> intHost $(hashQ "Map")         <> travF f  <> travA a
-    ZipWith _ f a1 a2            -> intHost $(hashQ "ZipWith")     <> travF f  <> travA a1 <> travA a2
-    Fold f e a                   -> intHost $(hashQ "Fold")        <> travF f  <> encodeMaybe travE e  <> travA a
-    FoldSeg _ f e a s            -> intHost $(hashQ "FoldSeg")     <> travF f  <> encodeMaybe travE e  <> travA a  <> travA s
-    Scan  d f e a                -> intHost $(hashQ "Scan")        <> travD d  <> travF f  <> encodeMaybe travE e  <> travA a
-    Scan' d f e a                -> intHost $(hashQ "Scan'")       <> travD d  <> travF f  <>           travE e  <> travA a
-    Permute f1 a1 f2 a2          -> intHost $(hashQ "Permute")     <> travF f1 <> travA a1 <> travF f2 <> travA a2
-    Stencil s _ f b a            -> intHost $(hashQ "Stencil")     <> travF f  <> encodeBoundary (stencilEltR s) b  <> travA a
-    Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2")  <> travF f  <> encodeBoundary (stencilEltR s1) b1 <> travA a1 <> encodeBoundary (stencilEltR s2) b2 <> travA a2
+    Acond e a1 a2                   -> intHost $(hashQ "Acond")       <> deep (travE e) <> travA a1 <> travA a2
+    Reshape _ sh a                  -> intHost $(hashQ "Reshape")     <> deepE sh <> travA a
+    Backpermute _ sh f a            -> intHost $(hashQ "Backpermute") <> deepE sh <> travF f  <> travA a
+    Transform _ sh f1 f2 a          -> intHost $(hashQ "Transform")   <> deepE sh <> travF f1 <> travF f2 <> travA a
+    Replicate spec ix a             -> intHost $(hashQ "Replicate")   <> deepE ix <> travA a  <> encodeSliceIndex spec
+    Slice spec a ix                 -> intHost $(hashQ "Slice")       <> deepE ix <> travA a  <> encodeSliceIndex spec
+    Map _ f a                       -> intHost $(hashQ "Map")         <> travF f  <> travA a
+    ZipWith _ f a1 a2               -> intHost $(hashQ "ZipWith")     <> travF f  <> travA a1 <> travA a2
+    Fold f e a                      -> intHost $(hashQ "Fold")        <> travF f  <> encodeMaybe travE e  <> travA a
+    FoldSeg _ f e a s               -> intHost $(hashQ "FoldSeg")     <> travF f  <> encodeMaybe travE e  <> travA a  <> travA s
+    Scan  d f e a                   -> intHost $(hashQ "Scan")        <> travD d  <> travF f  <> encodeMaybe travE e  <> travA a
+    Scan' d f e a                   -> intHost $(hashQ "Scan'")       <> travD d  <> travF f  <>           travE e  <> travA a
+    Permute f1 a1 f2 a2             -> intHost $(hashQ "Permute")     <> travF f1 <> travA a1 <> travF f2 <> travA a2
+    Stencil s _ f b a               -> intHost $(hashQ "Stencil")     <> travF f  <> encodeBoundary (stencilEltR s) b  <> travA a
+    Stencil2 s1 s2 _ f b1 a1 b2 a2  -> intHost $(hashQ "Stencil2")    <> travF f  <> encodeBoundary (stencilEltR s1) b1 <> travA a1 <> encodeBoundary (stencilEltR s2) b2 <> travA a2
 
 {--
 {-# INLINEABLE encodePreOpenSeq #-}

diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs
@@ -55,9 +55,9 @@ import Data.Array.Accelerate.Error
 import Data.Array.Accelerate.Type
 import Data.Primitive.Vec
 
-import Data.Array.Accelerate.Debug.Flags
-import Data.Array.Accelerate.Debug.Monitoring
-import Data.Array.Accelerate.Debug.Trace
+import Data.Array.Accelerate.Debug.Internal.Flags
+import Data.Array.Accelerate.Debug.Internal.Monitoring
+import Data.Array.Accelerate.Debug.Internal.Trace
 
 
 -- standard libraries

diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs
@@ -36,31 +36,33 @@ module Data.Array.Accelerate.Array.Remote.LRU (
 
 ) where
 
-import Data.Array.Accelerate.Analysis.Match                     ( matchSingleType, (:~:)(..) )
+import Data.Array.Accelerate.Analysis.Match                         ( matchSingleType, (:~:)(..) )
 import Data.Array.Accelerate.Array.Data
 import Data.Array.Accelerate.Array.Remote.Class
-import Data.Array.Accelerate.Array.Remote.Table                 ( StableArray, makeWeakArrayData )
-import Data.Array.Accelerate.Array.Unique                       ( touchUniqueArray )
-import Data.Array.Accelerate.Error                              ( internalError )
+import Data.Array.Accelerate.Array.Remote.Table                     ( StableArray, makeWeakArrayData )
+import Data.Array.Accelerate.Array.Unique                           ( touchUniqueArray )
+import Data.Array.Accelerate.Error                                  ( internalError )
 import Data.Array.Accelerate.Representation.Elt
 import Data.Array.Accelerate.Representation.Type
 import Data.Array.Accelerate.Type
-import qualified Data.Array.Accelerate.Array.Remote.Table       as Basic
-import qualified Data.Array.Accelerate.Debug                    as D
+import qualified Data.Array.Accelerate.Array.Remote.Table           as Basic
+import qualified Data.Array.Accelerate.Debug.Internal.Flags         as Debug
+import qualified Data.Array.Accelerate.Debug.Internal.Monitoring    as Debug
+import qualified Data.Array.Accelerate.Debug.Internal.Trace         as Debug
 
-import Control.Concurrent.MVar                                  ( MVar, newMVar, withMVar, takeMVar, putMVar, mkWeakMVar )
-import Control.Monad                                            ( filterM )
+import Control.Concurrent.MVar                                      ( MVar, newMVar, withMVar, takeMVar, putMVar, mkWeakMVar )
+import Control.Monad                                                ( filterM )
 import Control.Monad.Catch
-import Control.Monad.IO.Class                                   ( MonadIO, liftIO )
+import Control.Monad.IO.Class                                       ( MonadIO, liftIO )
 import Data.Functor
 #if __GLASGOW_HASKELL__ < 808
-import Data.Int                                                 ( Int64 )
+import Data.Int                                                     ( Int64 )
 #endif
-import Data.Maybe                                               ( isNothing )
+import Data.Maybe                                                   ( isNothing )
 import System.CPUTime
-import System.Mem.Weak                                          ( Weak, deRefWeak, finalize )
-import Prelude                                                  hiding ( lookup )
-import qualified Data.HashTable.IO                              as HT
+import System.Mem.Weak                                              ( Weak, deRefWeak, finalize )
+import Prelude                                                      hiding ( lookup )
+import qualified Data.HashTable.IO                                  as HT
 
 import GHC.Stack
 
@@ -296,7 +298,7 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do
         Just arr -> do
           message ("evictLRU/evicting " ++ show sa)
           copyIfNecessary status n tp arr
-          liftIO $ D.didEvictBytes (remoteBytes tp n)
+          liftIO $ Debug.didEvictBytes (remoteBytes tp n)
           liftIO $ Basic.freeStable @m mt sa
           liftIO $ HT.insert utbl sa (Used ts Evicted count tasks n tp weak_arr)
       return True
@@ -446,5 +448,5 @@ trace msg next = message msg >> next
 
 {-# INLINE message #-}
 message :: MonadIO m => String -> m ()
-message msg = liftIO $ D.traceIO D.dump_gc ("gc: " ++ msg)
+message msg = liftIO $ Debug.traceIO Debug.dump_gc ("gc: " ++ msg)