{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings        #-}
-- |
-- Module      : Data.Array.Accelerate.Debug.Internal.Trace
-- Copyright   : [2008..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Functions for tracing and monitoring execution. These are useful for
-- investigating bugs and performance problems, but by default are not enabled
-- in performance code.
--

module Data.Array.Accelerate.Debug.Internal.Trace (

  showFFloatSIBase,
  formatSIBase,

  putTraceMsg,
  trace, traceM,

) where

import Data.Array.Accelerate.Debug.Internal.Flags

import Control.Monad.Trans
import Data.Double.Conversion.Text
import Data.Text.Lazy.Builder
import Formatting

#ifdef ACCELERATE_DEBUG
import Data.Array.Accelerate.Debug.Internal.Clock
import System.IO                                                    hiding ( stderr )
import System.IO.Unsafe
import qualified Data.Text.IO                                       as T

import GHC.MVar
import GHC.IO.Encoding
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import qualified GHC.IO.FD                                          as FD
#if defined(mingw32_HOST_OS)
import Foreign.C.Types
#endif
#endif


-- | Show a signed 'RealFloat' value using SI unit prefixes. In the call to:
--
-- > showFFloatSIBase prec base val
--
-- If @prec@ is @'Nothing'@ the value is shown to full precision, and if @prec@
-- is @'Just' d@, then at most @d@ digits are shown after the decimal place.
-- Here @base@ represents the increment size between multiples of the original
-- unit. For measures in base-10 this will be 1000 and for values in base-2 this
-- is usually 1024, for example when measuring seconds versus bytes,
-- respectively.
--
{-# INLINEABLE showFFloatSIBase #-}
showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> Builder -> Builder
showFFloatSIBase :: forall a. RealFloat a => Maybe Int -> a -> a -> Builder -> Builder
showFFloatSIBase Maybe Int
mp !a
b !a
k !Builder
t = Format Builder (a -> Builder -> Builder) -> a -> Builder -> Builder
forall a. Format Builder a -> a
bformat (Maybe Int
-> a -> Format (Builder -> Builder) (a -> Builder -> Builder)
forall a r. RealFloat a => Maybe Int -> a -> Format r (a -> r)
formatSIBase Maybe Int
mp a
b Format (Builder -> Builder) (a -> Builder -> Builder)
-> Format Builder (Builder -> Builder)
-> Format Builder (a -> Builder -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Builder (Builder -> Builder)
forall r. Format r (Builder -> r)
builder) a
k Builder
t

{-# INLINEABLE formatSIBase #-}
formatSIBase :: RealFloat a => Maybe Int -> a -> Format r (a -> r)
formatSIBase :: forall a r. RealFloat a => Maybe Int -> a -> Format r (a -> r)
formatSIBase Maybe Int
mp !a
b = (a -> Builder) -> Format r (a -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later a -> Builder
go
  where
    go :: a -> Builder
go a
k =
      let !pow :: Int
pow  = a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
b a
k) :: Int
          !k' :: a
k'   = a
k a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
b a -> Int -> a
forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Int
pow)
          !unit :: Maybe Builder
unit =
            case Int
pow of
              Int
4  -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"T"
              Int
3  -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"G"
              Int
2  -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"M"
              Int
1  -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"k"
              -1 -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"m"
              -2 -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"µ"
              -3 -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"n"
              -4 -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
"p"
              Int
_  -> Maybe Builder
forall a. Maybe a
Nothing
      in
      case Maybe Builder
unit of
        Maybe Builder
Nothing -> Format Builder (a -> Builder) -> a -> Builder
forall a. Format Builder a -> a
bformat (Format Builder (a -> Builder)
-> (Int -> Format Builder (a -> Builder))
-> Maybe Int
-> Format Builder (a -> Builder)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Format Builder (a -> Builder)
forall a r. Real a => Format r (a -> r)
float Int -> Format Builder (a -> Builder)
forall a r. Real a => Int -> Format r (a -> r)
prec  Maybe Int
mp Format Builder (a -> Builder)
-> Format Builder Builder -> Format Builder (a -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Builder Builder
" ") a
k
        Just Builder
t  -> Format Builder (a -> Builder -> Builder) -> a -> Builder -> Builder
forall a. Format Builder a -> a
bformat (Format (Builder -> Builder) (a -> Builder -> Builder)
-> (Int -> Format (Builder -> Builder) (a -> Builder -> Builder))
-> Maybe Int
-> Format (Builder -> Builder) (a -> Builder -> Builder)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Format (Builder -> Builder) (a -> Builder -> Builder)
forall a r. Real a => Format r (a -> r)
float Int -> Format (Builder -> Builder) (a -> Builder -> Builder)
forall a r. Real a => Int -> Format r (a -> r)
fixed Maybe Int
mp Format (Builder -> Builder) (a -> Builder -> Builder)
-> Format Builder (Builder -> Builder)
-> Format Builder (a -> Builder -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Builder -> Builder) (Builder -> Builder)
" " Format (Builder -> Builder) (Builder -> Builder)
-> Format Builder (Builder -> Builder)
-> Format Builder (Builder -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Builder (Builder -> Builder)
forall r. Format r (Builder -> r)
builder) a
k' Builder
t

{-# INLINE prec #-}
prec :: Real a => Int -> Format r (a -> r)
prec :: forall a r. Real a => Int -> Format r (a -> r)
prec Int
digits = (a -> Builder) -> Format r (a -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
fromText (Text -> Builder) -> (a -> Text) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double -> Text
toPrecision Int
digits (Double -> Text) -> (a -> Double) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac)


-- | The 'trace' function outputs the message given as its second argument when
-- the debug mode indicated by the first argument is enabled, before returning
-- the third argument as its result. The message is prefixed with a time stamp.
--
trace :: Flag -> Builder -> a -> a
#ifdef ACCELERATE_DEBUG
{-# NOINLINE trace #-}
trace f msg expr = unsafePerformIO $ do
  traceM f builder msg
  return expr
#else
{-# INLINE trace #-}
trace :: forall a. Flag -> Builder -> a -> a
trace Flag
_ Builder
_ a
expr = a
expr
#endif


-- | The 'traceM' function outputs the trace message together with a time
-- stamp from the MonadIO monad. This sequences the output with respect to
-- other IO actions.

-- TLM: Perhaps we should automatically format the log messages. Namely:
--        * prefix with a description of the mode (e.g. "gc: foo")
--        * align multi-line messages
--
{-# INLINE traceM #-}
traceM :: MonadIO m => Flag -> Format (m ()) a -> a
traceM :: forall (m :: * -> *) a. MonadIO m => Flag -> Format (m ()) a -> a
traceM Flag
_f Format (m ()) a
m =
  Format (m ()) a -> (Builder -> m ()) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format (m ()) a
m ((Builder -> m ()) -> a) -> (Builder -> m ()) -> a
forall a b. (a -> b) -> a -> b
$ \Builder
_k -> do
#ifdef ACCELERATE_DEBUG
    when _f $ putTraceMsg (now _k)
#endif
    () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Print a message prefixed with the current elapsed wall-clock time.
--
{-# INLINE putTraceMsg #-}
putTraceMsg :: MonadIO m => Format (m ()) a -> a
putTraceMsg :: forall (m :: * -> *) a. MonadIO m => Format (m ()) a -> a
putTraceMsg Format (m ()) a
m =
  Format (m ()) a -> (Builder -> m ()) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format (m ()) a
m ((Builder -> m ()) -> a) -> (Builder -> m ()) -> a
forall a b. (a -> b) -> a -> b
$ \Builder
_k -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
#ifdef ACCELERATE_DEBUG
    timestamp <- getProgramTime
    T.hPutStr stderr . sformat (squared (rfixed 8 ' ' (fixed 3)) % " " % builder % "\n") timestamp $ _k
#endif
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


#ifdef ACCELERATE_DEBUG
-- | A handle managing output to the Haskell program's standard output
-- channnel.
--
-- In contrast to 'System.IO.stderr' this output handle is (line) buffered,
-- which prevents garbled output when used my multiple threads. Stolen from
-- 'GHC.IO.Handle.FD.stderr'.
--
{-# NOINLINE stderr #-}
stderr :: Handle
stderr = unsafePerformIO $ do
  -- TODO: acquire lock
  setBinaryMode FD.stderr
  enc <- getLocaleEncoding
  mkHandle FD.stderr "<stderr>" WriteHandle True -- this stderr IS buffered
               (Just enc)
               nativeNewlineMode -- translate newlines
               (Just stdHandleFinalizer) Nothing

stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
stdHandleFinalizer fp m = do
  h_ <- takeMVar m
  flushWriteBuffer h_
  case haType h_ of
    ClosedHandle -> return ()
    _            -> closeTextCodecs h_
  putMVar m (ioe_finalizedHandle fp)

-- We have to put the FDs into binary mode on Windows to avoid the newline
-- translation that the CRT IO library does.
setBinaryMode :: FD.FD -> IO ()
#if defined(mingw32_HOST_OS)
setBinaryMode fd = do _ <- setmode (FD.fdFD fd) True
                      return ()

foreign import ccall unsafe "__hscore_setmode" setmode :: CInt -> Bool -> IO CInt
#else
setBinaryMode _ = return ()
#endif
#endif