Skip to content

Commit

Permalink
Merge pull request #485 from ivogabe/trace
Browse files Browse the repository at this point in the history
Add Acc debugging functionality similar to Debug.Trace
  • Loading branch information
tmcdonell committed Jan 8, 2021
2 parents 2eeac2f + fb5a543 commit 6a64aad
Show file tree
Hide file tree
Showing 14 changed files with 157 additions and 2 deletions.
19 changes: 19 additions & 0 deletions src/Data/Array/Accelerate.hs
Original file line number Diff line number Diff line change
Expand Up @@ -290,6 +290,11 @@ module Data.Array.Accelerate (
Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,
Stencil3x5x5, Stencil5x5x5,

-- ** Tracing
-- $tracing
--
atrace, atraceArray, atraceId, atraceExp,

-- -- ** Sequence operations
-- collect,

Expand Down Expand Up @@ -672,3 +677,17 @@ arrayReshape = S.reshape
-- * As well as copying data directly from raw 'Foreign.Ptr.Ptr's
--

-- $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".
--

9 changes: 9 additions & 0 deletions src/Data/Array/Accelerate/AST.hs
Original file line number Diff line number Diff line change
Expand Up @@ -150,6 +150,7 @@ import Data.Primitive.Vec
import Control.DeepSeq
import Data.Kind
import Language.Haskell.TH ( Q, TExp )
import qualified Language.Haskell.TH.Syntax as TH
import Prelude

import GHC.TypeLits
Expand Down Expand Up @@ -272,6 +273,10 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where
-> acc aenv arrs -- initial value
-> PreOpenAcc acc aenv arrs

Atrace :: String
-> acc aenv arrs1
-> acc aenv arrs2
-> PreOpenAcc acc aenv arrs2

-- Array inlet. Triggers (possibly) asynchronous host->device transfer if
-- necessary.
Expand Down Expand Up @@ -754,6 +759,7 @@ instance HasArraysR acc => HasArraysR (PreOpenAcc acc) where
arraysR (Avar (Var aR _)) = TupRsingle aR
arraysR (Apair as bs) = TupRpair (arraysR as) (arraysR bs)
arraysR Anil = TupRunit
arraysR (Atrace _ _ bs) = arraysR bs
arraysR (Apply aR _ _) = aR
arraysR (Aforeign r _ _ _) = r
arraysR (Acond _ a _) = arraysR a
Expand Down Expand Up @@ -974,6 +980,7 @@ rnfPreOpenAcc rnfA pacc =
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
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
Expand Down Expand Up @@ -1182,6 +1189,7 @@ liftPreOpenAcc liftA pacc =
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) ||]
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) ||]
Expand Down Expand Up @@ -1366,6 +1374,7 @@ showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String
showPreAccOp Alet{} = "Alet"
showPreAccOp (Avar (Var _ ix)) = "Avar a" ++ show (idxToInt ix)
showPreAccOp (Use aR a) = "Use " ++ showArrayShort 5 (showsElt (arrayRtype aR)) aR a
showPreAccOp Atrace{} = "Atrace"
showPreAccOp Apply{} = "Apply"
showPreAccOp Aforeign{} = "Aforeign"
showPreAccOp Acond{} = "Acond"
Expand Down
2 changes: 2 additions & 0 deletions src/Data/Array/Accelerate/Analysis/Hash.hs
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,7 @@ import Data.Array.Accelerate.Type
import Data.Primitive.Vec

import Crypto.Hash
import qualified Data.Hashable as Hashable
import Data.ByteString.Builder
import Data.ByteString.Builder.Extra
import Data.ByteString.Short.Internal ( ShortByteString(..) )
Expand Down Expand Up @@ -168,6 +169,7 @@ encodePreOpenAcc options encodeAcc pacc =
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)
Expand Down
9 changes: 8 additions & 1 deletion src/Data/Array/Accelerate/Interpreter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -36,7 +36,7 @@ module Data.Array.Accelerate.Interpreter (
run, run1, runN,

-- Internal (hidden)
evalPrim, evalPrimConst, evalCoerceScalar,
evalPrim, evalPrimConst, evalCoerceScalar, atraceOp,

) where

Expand Down Expand Up @@ -72,6 +72,7 @@ import Control.Monad.ST
import Data.Bits
import Data.Primitive.ByteArray
import Data.Primitive.Types
import Debug.Trace
import System.IO.Unsafe ( unsafePerformIO )
import Text.Printf ( printf )
import Unsafe.Coerce
Expand Down Expand Up @@ -205,6 +206,7 @@ evalOpenAcc (AST.Manifest pacc) aenv =
in
(TupRpair r1 r2, (a1, a2))
Anil -> (TupRunit, ())
Atrace msg as bs -> unsafePerformIO $ manifest bs <$ uncurry (atraceOp msg) (manifest as)
Apply repr afun acc -> (repr, evalOpenAfun afun aenv $ snd $ manifest acc)
Aforeign repr _ afun acc -> (repr, evalOpenAfun afun Empty $ snd $ manifest acc)
Acond p acc1 acc2
Expand Down Expand Up @@ -862,6 +864,11 @@ evalBoundary bnd aenv =
AST.Constant v -> Constant v
AST.Function f -> Function (evalFun f aenv)

atraceOp :: String -> ArraysR as -> as -> IO ()
atraceOp msg TupRunit () = traceIO msg
atraceOp msg (TupRsingle (ArrayR ShapeRz eR)) as = traceIO $ printf "%s: %s" msg (showElt eR $ linearIndexArray eR as 0)
atraceOp msg (TupRsingle (ArrayR shR eR)) as = traceIO $ printf "%s: %s" msg (showArray (showsElt eR) (ArrayR shR eR) as)
atraceOp msg aR as = traceIO $ printf "%s: %s" msg (showArrays aR as)

-- Scalar expression evaluation
-- ----------------------------
Expand Down
41 changes: 40 additions & 1 deletion src/Data/Array/Accelerate/Language.hs
Original file line number Diff line number Diff line change
Expand Up @@ -73,6 +73,9 @@ module Data.Array.Accelerate.Language (
Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,
Stencil3x5x5, Stencil5x5x5,

-- * Tracing
atrace, atraceArray, atraceId, atraceExp,

-- * Foreign functions
foreignAcc,
foreignExp,
Expand Down Expand Up @@ -118,7 +121,7 @@ import Data.Array.Accelerate.Classes.Integral
import Data.Array.Accelerate.Classes.Num
import Data.Array.Accelerate.Classes.Ord

import Prelude ( ($), (.), Maybe(..), Char )
import Prelude ( ($), (.), Maybe(..), Char, String )


-- $setup
Expand Down Expand Up @@ -1172,6 +1175,42 @@ collect :: Arrays arrs => Seq arrs -> Acc arrs
collect = Acc . Collect
--}

-- Debugging
-- ---------

-- | Outputs the trace message to the console before the 'Acc' computation can proceed
-- with the result of the second argument.
--
-- @since 1.4.0.0
--
atrace :: Arrays a => String -> Acc a -> Acc a
atrace message = atraceArray message (Acc $ SmartAcc Anil :: Acc ())

-- | Outputs the trace message and the array(s) from the second argument to the console,
-- before the 'Acc' computation can proceed with the result of the third argument.
--
-- @since 1.4.0.0
--
atraceArray :: (Arrays a, Arrays b) => String -> Acc a -> Acc b -> Acc b
atraceArray message (Acc inspect) (Acc result) = Acc $ SmartAcc $ Atrace message inspect result

-- | Outputs the trace message and the array(s) to the console,
-- before the 'Acc' computation can proceed with the result of
-- that array.
--
-- @since 1.4.0.0
--
atraceId :: Arrays a => String -> Acc a -> Acc a
atraceId message value = atraceArray message value value

-- | Outputs the trace message and a scalar value to the console,
-- before the 'Acc' computation can prroceed with the result of the third argument.
--
-- @since 1.4.0.0
--
atraceExp :: (Elt e, Arrays a) => String -> Exp e -> Acc a -> Acc a
atraceExp message = atraceArray message . unit

-- Foreign function calling
-- ------------------------

Expand Down
1 change: 1 addition & 0 deletions src/Data/Array/Accelerate/Pretty/Graphviz.hs
Original file line number Diff line number Diff line change
Expand Up @@ -230,6 +230,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) =

Anil -> "()" .$ []

Atrace msg as bs -> "atrace" .$ [ return $ PDoc (fromString msg) [], ppA as, ppA bs ]
Use repr arr -> "use" .$ [ return $ PDoc (prettyArray repr arr) [] ]
Unit _ e -> "unit" .$ [ ppE e ]
Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ]
Expand Down
1 change: 1 addition & 0 deletions src/Data/Array/Accelerate/Pretty/Print.hs
Original file line number Diff line number Diff line change
Expand Up @@ -174,6 +174,7 @@ prettyPreOpenAcc config ctx prettyAcc extractAcc aenv pacc =
Alet{} -> prettyAlet config ctx prettyAcc extractAcc aenv pacc
Apair{} -> prettyAtuple config ctx prettyAcc extractAcc aenv pacc
Anil -> "()"
Atrace msg as bs -> "atrace" .$ [ fromString (show msg), ppA as, ppA bs ]
Apply _ f a -> apply
where
op = Operator ">->" Infix L 1
Expand Down
55 changes: 55 additions & 0 deletions src/Data/Array/Accelerate/Representation/Array.hs
Original file line number Diff line number Diff line change
Expand Up @@ -28,6 +28,8 @@ import Data.Array.Accelerate.Representation.Type
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.IO.Unsafe
import Data.List ( intersperse )
import Data.Maybe ( isJust )
import Text.Show ( showListWith )
import Prelude hiding ( (!!) )
import qualified Data.Vector.Unboxed as U
Expand Down Expand Up @@ -227,6 +229,59 @@ showMatrix f (ArrayR _ arrR) arr@(Array sh _)
in
before ++ cell ++ after

showArrays :: ArraysR arrs -> arrs -> String
showArrays repr arrs = showsArrays repr arrs ""

showsArrays :: ArraysR arrs -> arrs -> ShowS
showsArrays repr arrs = go 0 repr arrs
where
go :: Int -> ArraysR a -> a -> ShowS
go _ TupRunit ()
= showString "()"
go level repr' arrs'
| Just tuple <- extractTuple repr' arrs'
= let
constructor = 'T' : show (length tuple)
level' = level + length constructor + 1
content = intersperse (('\n' :) . indent level') $ map ($ level') tuple
in
showString constructor . (' ' :) . foldr (flip (.)) id content
go level (TupRpair repr1 repr2) (arrs1, arrs2)
= showString "( " . go (level + 2) repr1 arrs1 . showString "\n"
. indent level . showString ", " . go (level + 1) repr2 arrs2 . showString "\n"
. indent level . showString ")"
go level (TupRsingle r@ArrayR{}) arr
= showString $ indents level $ showArray (showsElt $ arrayRtype r) r arr

indent :: Int -> ShowS
indent 0 str = str
indent n str = ' ' : indent (n - 1) str

indents :: Int -> String -> String
indents _ [] = []
indents level ('\n' : xs) = '\n' : indent level (indents level xs)
indents level (x : xs) = x : indents level xs

-- Tries to extract the representation of a tuple.
-- Tuples are represented as a snoc-list built with
-- pairs and nil.
-- The tuple is returned a list of pretty-printed
-- elements, in reverse order.
extractTuple :: ArraysR a -> a -> Maybe [Int -> ShowS]
extractTuple TupRunit () = Just []
extractTuple (TupRpair rs r) (as, a) = (current :) <$> extractTuple rs as
where
current level
-- Avoid duplicate parentheses for () and pairs which don't form a tuple
| needsParens r a = showString "( " . go (level + 2) r a . showString " )"
| otherwise = go level r a
extractTuple _ _ = Nothing

needsParens :: ArraysR a -> a -> Bool
needsParens TupRunit _ = False
needsParens repr'@(TupRpair _ _) as = isJust $ extractTuple repr' as
needsParens _ _ = True

reduceRank :: ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e)
reduceRank (ArrayR (ShapeRsnoc shR) aeR) = ArrayR shR aeR

Expand Down
7 changes: 7 additions & 0 deletions src/Data/Array/Accelerate/Smart.hs
Original file line number Diff line number Diff line change
Expand Up @@ -354,6 +354,11 @@ data PreSmartAcc acc exp as where
-> acc (arrs1, arrs2)
-> PreSmartAcc acc exp arrs

Atrace :: String
-> acc arrs1
-> acc arrs2
-> PreSmartAcc acc exp arrs2

Use :: ArrayR (Array sh e)
-> Array sh e
-> PreSmartAcc acc exp (Array sh e)
Expand Down Expand Up @@ -799,6 +804,7 @@ instance HasArraysR acc => HasArraysR (PreSmartAcc acc exp) where
PairIdxLeft -> t1
PairIdxRight -> t2
Aprj _ _ -> error "Ejector seat? You're joking!"
Atrace _ _ a -> arraysR a
Use repr _ -> TupRsingle repr
Unit tp _ -> TupRsingle $ ArrayR ShapeRz $ tp
Generate repr _ _ -> TupRsingle repr
Expand Down Expand Up @@ -1308,6 +1314,7 @@ showPreAccOp Awhile{} = "Awhile"
showPreAccOp Apair{} = "Apair"
showPreAccOp Anil{} = "Anil"
showPreAccOp Aprj{} = "Aprj"
showPreAccOp Atrace{} = "Atrace"
showPreAccOp Unit{} = "Unit"
showPreAccOp Generate{} = "Generate"
showPreAccOp Reshape{} = "Reshape"
Expand Down
2 changes: 2 additions & 0 deletions src/Data/Array/Accelerate/Trafo/Fusion.hs
Original file line number Diff line number Diff line change
Expand Up @@ -176,6 +176,7 @@ manifest config (OpenAcc pacc) =
Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (manifest config a)
Apair a1 a2 -> Apair (manifest config a1) (manifest config a2)
Anil -> Anil
Atrace msg a1 a2 -> Atrace msg (manifest config a1) (manifest config a2)
Apply repr f a -> apply repr (cvtAF f) (manifest config a)
Aforeign repr ff f a -> Aforeign repr ff (cvtAF f) (manifest config a)

Expand Down Expand Up @@ -366,6 +367,7 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc
Apply aR f a -> done $ Apply aR (cvtAF f) (cvtA a)
Awhile p f a -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a)
Apair a1 a2 -> done $ Apair (cvtA a1) (cvtA a2)
Atrace msg a1 a2 -> done $ Atrace msg (cvtA a1) (cvtA a2)
Aforeign aR ff f a -> done $ Aforeign aR ff (cvtAF f) (cvtA a)
-- Collect s -> collectD s

Expand Down
1 change: 1 addition & 0 deletions src/Data/Array/Accelerate/Trafo/LetSplit.hs
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,7 @@ convertPreOpenAcc = \case
Avar var -> Avar var
Apair a1 a2 -> Apair (convertAcc a1) (convertAcc a2)
Anil -> Anil
Atrace msg as bs -> Atrace msg (convertAcc as) (convertAcc bs)
Apply repr f a -> Apply repr (convertAfun f) (convertAcc a)
Aforeign repr asm f a -> Aforeign repr asm (convertAfun f) (convertAcc a)
Acond e a1 a2 -> Acond e (convertAcc a1) (convertAcc a2)
Expand Down
10 changes: 10 additions & 0 deletions src/Data/Array/Accelerate/Trafo/Sharing.hs
Original file line number Diff line number Diff line change
Expand Up @@ -339,6 +339,7 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc))
Apair acc1 acc2 -> AST.Apair (cvtA acc1) (cvtA acc2)
Aprj ix a -> let AST.OpenAcc a' = cvtAprj ix a
in a'
Atrace msg acc1 acc2 -> AST.Atrace msg (cvtA acc1) (cvtA acc2)
Use repr array -> AST.Use repr array
Unit tp e -> AST.Unit tp (cvtE e)
Generate repr@(ArrayR shr _) sh f
Expand Down Expand Up @@ -1502,6 +1503,10 @@ makeOccMapSharingAcc config accOccMap = traverseAcc
return (Apair a' b', h1 `max` h2 + 1)
Aprj ix a -> travA (Aprj ix) a

Atrace msg acc1 acc2 -> do
(a', h1) <- traverseAcc lvl acc1
(b', h2) <- traverseAcc lvl acc2
return (Atrace msg a' b', h1 `max` h2 + 1)
Use repr arr -> return (Use repr arr, 1)
Unit tp e -> do
(e', h) <- traverseExp lvl e
Expand Down Expand Up @@ -2358,6 +2363,11 @@ determineScopesSharingAcc config accOccMap = scopesAcc
reconstruct (Apair a1' a2') (accCount1 +++ accCount2)
Aprj ix a -> travA (Aprj ix) a

Atrace msg a1 a2 -> let
(a1', accCount1) = scopesAcc a1
(a2', accCount2) = scopesAcc a2
in
reconstruct (Atrace msg a1' a2') (accCount1 +++ accCount2)
Use repr arr -> reconstruct (Use repr arr) noNodeCounts
Unit tp e -> let
(e', accCount) = scopesExp e
Expand Down
1 change: 1 addition & 0 deletions src/Data/Array/Accelerate/Trafo/Shrink.hs
Original file line number Diff line number Diff line change
Expand Up @@ -543,6 +543,7 @@ usesOfPreAcc withShape countAcc idx = count
Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs >:> idx) body
Apair a1 a2 -> countA a1 + countA a2
Anil -> 0
Atrace _ a1 a2 -> countA a1 + countA a2
Apply _ f a -> countAF f idx + countA a
Aforeign _ _ _ a -> countA a
Acond p t e -> countE p + countA t + countA e
Expand Down
1 change: 1 addition & 0 deletions src/Data/Array/Accelerate/Trafo/Substitution.hs
Original file line number Diff line number Diff line change
Expand Up @@ -680,6 +680,7 @@ rebuildPreOpenAcc k av acc =
Avar ix -> accOut <$> av ix
Apair as bs -> Apair <$> k av as <*> k av bs
Anil -> pure Anil
Atrace msg as bs -> Atrace msg <$> k av as <*> k av bs
Apply repr f a -> Apply repr <$> rebuildAfun k av f <*> k av a
Acond p t e -> Acond <$> rebuildOpenExp (pure . IE) av' p <*> k av t <*> k av e
Awhile p f a -> Awhile <$> rebuildAfun k av p <*> rebuildAfun k av f <*> k av a
Expand Down

0 comments on commit 6a64aad

Please sign in to comment.