{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-binds   #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-- |
-- Module      : Data.Array.Accelerate.Debug.Simpl
-- Copyright   : [2008..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Tick-count statistics collection of the compiler passes, for debugging
-- purposes.
--

module Data.Array.Accelerate.Debug.Stats (

  simplCount, resetSimplCount, dumpSimplStats,
  inline, ruleFired, knownBranch, caseElim, caseDefault, betaReduce, substitution, simplifierDone, fusionDone,

) where

import Data.Array.Accelerate.Debug.Flags
import Data.Array.Accelerate.Debug.Trace

import Data.Function                                      ( on )
import Data.IORef
import Data.List                                          ( groupBy, sortBy )
import Data.Map                                           ( Map )
import Data.Ord                                           ( comparing )
import Data.Text                                          ( Text )
import Data.Text.Prettyprint.Doc                          hiding ( annotate, Doc )
-- import Data.Text.Prettyprint.Doc.Render.Terminal
import Data.Text.Prettyprint.Doc.Render.String
import System.IO.Unsafe
import qualified Data.Map                                 as Map
import qualified Data.Text.Prettyprint.Doc                as Pretty


-- Recording statistics
-- --------------------

ruleFired, inline, knownBranch, caseElim, caseDefault, betaReduce, substitution :: Text -> a -> a
inline :: Text -> a -> a
inline          = (Id -> Tick) -> Text -> a -> a
forall a. (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
Inline
ruleFired :: Text -> a -> a
ruleFired       = (Id -> Tick) -> Text -> a -> a
forall a. (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
RuleFired
knownBranch :: Text -> a -> a
knownBranch     = (Id -> Tick) -> Text -> a -> a
forall a. (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
KnownBranch
caseElim :: Text -> a -> a
caseElim        = (Id -> Tick) -> Text -> a -> a
forall a. (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
CaseElim
caseDefault :: Text -> a -> a
caseDefault     = (Id -> Tick) -> Text -> a -> a
forall a. (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
CaseDefault
betaReduce :: Text -> a -> a
betaReduce      = (Id -> Tick) -> Text -> a -> a
forall a. (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
BetaReduce
substitution :: Text -> a -> a
substitution    = (Id -> Tick) -> Text -> a -> a
forall a. (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
Substitution

simplifierDone, fusionDone :: a -> a
simplifierDone :: a -> a
simplifierDone  = Tick -> a -> a
forall a. Tick -> a -> a
tick Tick
SimplifierDone
fusionDone :: a -> a
fusionDone      = Tick -> a -> a
forall a. Tick -> a -> a
tick Tick
FusionDone

-- Add an entry to the statistics counters
--
tick :: Tick -> a -> a
#ifdef ACCELERATE_DEBUG
{-# NOINLINE tick #-}
tick t expr = unsafeDupablePerformIO $ do
  modifyIORef' statistics (simplTick t)
  return expr
#else
{-# INLINE tick #-}
tick :: Tick -> a -> a
tick Tick
_ a
expr = a
expr
#endif

-- Add an entry to the statistics counters with an annotation
--
annotate :: (Id -> Tick) -> Text -> a -> a
annotate :: (Id -> Tick) -> Text -> a -> a
annotate Id -> Tick
name Text
ctx = Tick -> a -> a
forall a. Tick -> a -> a
tick (Id -> Tick
name (Text -> Id
Id Text
ctx))


-- Simplifier counts
-- -----------------

data SimplStats
  = Simple         {-# UNPACK #-} !Int          -- when we don't want detailed stats

  | Detail {
      SimplStats -> Int
ticks     :: {-# UNPACK #-} !Int,         -- total ticks
      SimplStats -> TickCount
details   :: !TickCount                   -- how many of each type
    }

instance Show SimplStats where
  show :: SimplStats -> String
show = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (SimplStats -> Doc) -> SimplStats -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimplStats -> Doc
pprSimplCount


-- Stores the current statistics counters
--
{-# NOINLINE statistics #-}
statistics :: IORef SimplStats
statistics :: IORef SimplStats
statistics = IO (IORef SimplStats) -> IORef SimplStats
forall a. IO a -> a
unsafePerformIO (IO (IORef SimplStats) -> IORef SimplStats)
-> IO (IORef SimplStats) -> IORef SimplStats
forall a b. (a -> b) -> a -> b
$ SimplStats -> IO (IORef SimplStats)
forall a. a -> IO (IORef a)
newIORef (SimplStats -> IO (IORef SimplStats))
-> IO SimplStats -> IO (IORef SimplStats)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO SimplStats
initSimplCount

-- Initialise the statistics counters. If we are dumping the stats
-- (-ddump-simpl-stats) record extra information, else just a total tick count.
--
initSimplCount :: IO SimplStats
#ifdef ACCELERATE_DEBUG
initSimplCount = do
  d <- getFlag dump_simpl_stats
  return $! if d then Detail { ticks = 0, details = Map.empty }
                 else Simple 0
#else
initSimplCount :: IO SimplStats
initSimplCount = SimplStats -> IO SimplStats
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplStats -> IO SimplStats) -> SimplStats -> IO SimplStats
forall a b. (a -> b) -> a -> b
$! Int -> SimplStats
Simple Int
0
#endif


-- Reset the statistics counters. Do this at the beginning at each HOAS -> de
-- Bruijn conversion + optimisation pass.
--
resetSimplCount :: IO ()
#ifdef ACCELERATE_DEBUG
resetSimplCount = writeIORef statistics =<< initSimplCount
#else
resetSimplCount :: IO ()
resetSimplCount = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

-- Display simplifier statistics. The counts are reset afterwards.
--
{-# INLINEABLE dumpSimplStats #-}
dumpSimplStats :: IO ()
#ifdef ACCELERATE_DEBUG
dumpSimplStats = do
  when dump_simpl_stats $ do
    stats <- simplCount
    putTraceMsg (renderString (layoutPretty defaultLayoutOptions stats))
    resetSimplCount
#else
dumpSimplStats :: IO ()
dumpSimplStats = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif



-- Tick a counter
--
simplTick :: Tick -> SimplStats -> SimplStats
simplTick :: Tick -> SimplStats -> SimplStats
simplTick Tick
_ (Simple Int
n)     = Int -> SimplStats
Simple (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
simplTick Tick
t (Detail Int
n TickCount
dts) = Int -> TickCount -> SimplStats
Detail (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (TickCount
dts TickCount -> Tick -> TickCount
`addTick` Tick
t)

-- Pretty print the tick counts. Remarkably reminiscent of GHC style...
--
pprSimplCount :: SimplStats -> Doc
pprSimplCount :: SimplStats -> Doc
pprSimplCount (Simple Int
n)     = Doc
"Total ticks:" Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty Int
n
pprSimplCount (Detail Int
n TickCount
dts)
  = [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
vcat [ Doc
"Total ticks:" Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty Int
n
         , Doc
forall a. Monoid a => a
mempty
         , TickCount -> Doc
pprTickCount TickCount
dts
         ]

simplCount :: IO Doc
simplCount :: IO Doc
simplCount = SimplStats -> Doc
pprSimplCount (SimplStats -> Doc) -> IO SimplStats -> IO Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IORef SimplStats -> IO SimplStats
forall a. IORef a -> IO a
readIORef IORef SimplStats
statistics


-- Ticks
-- -----

type Doc       = Pretty.Doc ()
type TickCount = Map Tick Int

data Id = Id Text
  deriving (Id -> Id -> Bool
(Id -> Id -> Bool) -> (Id -> Id -> Bool) -> Eq Id
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Id -> Id -> Bool
$c/= :: Id -> Id -> Bool
== :: Id -> Id -> Bool
$c== :: Id -> Id -> Bool
Eq, Eq Id
Eq Id
-> (Id -> Id -> Ordering)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Id)
-> (Id -> Id -> Id)
-> Ord Id
Id -> Id -> Bool
Id -> Id -> Ordering
Id -> Id -> Id
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Id -> Id -> Id
$cmin :: Id -> Id -> Id
max :: Id -> Id -> Id
$cmax :: Id -> Id -> Id
>= :: Id -> Id -> Bool
$c>= :: Id -> Id -> Bool
> :: Id -> Id -> Bool
$c> :: Id -> Id -> Bool
<= :: Id -> Id -> Bool
$c<= :: Id -> Id -> Bool
< :: Id -> Id -> Bool
$c< :: Id -> Id -> Bool
compare :: Id -> Id -> Ordering
$ccompare :: Id -> Id -> Ordering
$cp1Ord :: Eq Id
Ord)

data Tick
  = Inline              Id
  | RuleFired           Id
  | KnownBranch         Id
  | CaseElim            Id
  | CaseDefault         Id
  | BetaReduce          Id
  | Substitution        Id

  -- tick at each iteration
  | SimplifierDone
  | FusionDone
  deriving (Tick -> Tick -> Bool
(Tick -> Tick -> Bool) -> (Tick -> Tick -> Bool) -> Eq Tick
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tick -> Tick -> Bool
$c/= :: Tick -> Tick -> Bool
== :: Tick -> Tick -> Bool
$c== :: Tick -> Tick -> Bool
Eq, Eq Tick
Eq Tick
-> (Tick -> Tick -> Ordering)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> Ord Tick
Tick -> Tick -> Bool
Tick -> Tick -> Ordering
Tick -> Tick -> Tick
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tick -> Tick -> Tick
$cmin :: Tick -> Tick -> Tick
max :: Tick -> Tick -> Tick
$cmax :: Tick -> Tick -> Tick
>= :: Tick -> Tick -> Bool
$c>= :: Tick -> Tick -> Bool
> :: Tick -> Tick -> Bool
$c> :: Tick -> Tick -> Bool
<= :: Tick -> Tick -> Bool
$c<= :: Tick -> Tick -> Bool
< :: Tick -> Tick -> Bool
$c< :: Tick -> Tick -> Bool
compare :: Tick -> Tick -> Ordering
$ccompare :: Tick -> Tick -> Ordering
$cp1Ord :: Eq Tick
Ord)


addTick :: TickCount -> Tick -> TickCount
addTick :: TickCount -> Tick -> TickCount
addTick TickCount
tc Tick
t =
  (Maybe Int -> Maybe Int) -> Tick -> TickCount -> TickCount
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Int -> Maybe Int
forall a. Num a => Maybe a -> Maybe a
f Tick
t TickCount
tc
  where
    f :: Maybe a -> Maybe a
f Maybe a
Nothing  = a -> Maybe a
forall a. a -> Maybe a
Just a
1
    f (Just a
x) = let x' :: a
x' = a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
1 in a
x' a -> Maybe a -> Maybe a
`seq` a -> Maybe a
forall a. a -> Maybe a
Just a
x'

pprTickCount :: TickCount -> Doc
pprTickCount :: TickCount -> Doc
pprTickCount TickCount
counts =
  [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
vcat (([(Tick, Int)] -> Doc) -> [[(Tick, Int)]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [(Tick, Int)] -> Doc
pprTickGroup [[(Tick, Int)]]
groups)
  where
    groups :: [[(Tick, Int)]]
groups  = ((Tick, Int) -> (Tick, Int) -> Bool)
-> [(Tick, Int)] -> [[(Tick, Int)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Tick, Int) -> (Tick, Int) -> Bool
forall b. (Tick, b) -> (Tick, b) -> Bool
sameTag (TickCount -> [(Tick, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList TickCount
counts)
    sameTag :: (Tick, b) -> (Tick, b) -> Bool
sameTag = Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Tick, b) -> Int) -> (Tick, b) -> (Tick, b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Tick -> Int
tickToTag (Tick -> Int) -> ((Tick, b) -> Tick) -> (Tick, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tick, b) -> Tick
forall a b. (a, b) -> a
fst

pprTickGroup :: [(Tick,Int)] -> Doc
pprTickGroup :: [(Tick, Int)] -> Doc
pprTickGroup []  = String -> Doc
forall a. HasCallStack => String -> a
error String
"pprTickGroup"
pprTickGroup [(Tick, Int)]
grp =
  Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 ([Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Int -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty Int
groupTotal Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc
groupName)
               Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [ Int -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty Int
n Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Tick -> Doc
pprTickCtx Tick
t | (Tick
t,Int
n) <- ((Tick, Int) -> (Tick, Int) -> Ordering)
-> [(Tick, Int)] -> [(Tick, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Tick, Int) -> (Tick, Int) -> Ordering)
-> (Tick, Int) -> (Tick, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Tick, Int) -> Int) -> (Tick, Int) -> (Tick, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Tick, Int) -> Int
forall a b. (a, b) -> b
snd)) [(Tick, Int)]
grp ])
  where
    groupName :: Doc
groupName  = Tick -> Doc
tickToStr ((Tick, Int) -> Tick
forall a b. (a, b) -> a
fst ([(Tick, Int)] -> (Tick, Int)
forall a. [a] -> a
head [(Tick, Int)]
grp))
    groupTotal :: Int
groupTotal = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
n | (Tick
_,Int
n) <- [(Tick, Int)]
grp]

tickToTag :: Tick -> Int
tickToTag :: Tick -> Int
tickToTag Inline{}              = Int
0
tickToTag RuleFired{}           = Int
1
tickToTag KnownBranch{}         = Int
2
tickToTag CaseElim{}            = Int
3
tickToTag CaseDefault{}         = Int
4
tickToTag BetaReduce{}          = Int
5
tickToTag Substitution{}        = Int
6
tickToTag Tick
SimplifierDone        = Int
99
tickToTag Tick
FusionDone            = Int
100

tickToStr :: Tick -> Doc
tickToStr :: Tick -> Doc
tickToStr Inline{}              = Doc
"Inline"
tickToStr RuleFired{}           = Doc
"RuleFired"
tickToStr KnownBranch{}         = Doc
"KnownBranch"
tickToStr CaseElim{}            = Doc
"CaseElim"
tickToStr CaseDefault{}         = Doc
"CaseDefault"
tickToStr BetaReduce{}          = Doc
"BetaReduce"
tickToStr Substitution{}        = Doc
"Substitution"
tickToStr Tick
SimplifierDone        = Doc
"SimplifierDone"
tickToStr Tick
FusionDone            = Doc
"FusionDone"

pprTickCtx :: Tick -> Doc
pprTickCtx :: Tick -> Doc
pprTickCtx (Inline Id
v)           = Id -> Doc
pprId Id
v
pprTickCtx (RuleFired Id
v)        = Id -> Doc
pprId Id
v
pprTickCtx (KnownBranch Id
v)      = Id -> Doc
pprId Id
v
pprTickCtx (CaseElim Id
v)         = Id -> Doc
pprId Id
v
pprTickCtx (CaseDefault Id
v)      = Id -> Doc
pprId Id
v
pprTickCtx (BetaReduce Id
v)       = Id -> Doc
pprId Id
v
pprTickCtx (Substitution Id
v)     = Id -> Doc
pprId Id
v
pprTickCtx Tick
SimplifierDone       = Doc
forall a. Monoid a => a
mempty
pprTickCtx Tick
FusionDone           = Doc
forall a. Monoid a => a
mempty

pprId :: Id -> Doc
pprId :: Id -> Doc
pprId (Id Text
s) = Text -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty Text
s