{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}

module GHC.RTS.Events.Incremental
  ( -- * Incremental API
    Decoder(..)
  , decodeHeader
  , decodeEvents
  , decodeEventLog

  -- * Lazy API
  , readHeader
  , readEvents
  , readEventLog
  ) where
import Control.Monad
import Data.Either
import Data.Maybe
import Prelude

import qualified Data.Binary.Get as G
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Internal as BL
import qualified Data.IntMap.Strict as IM

import GHC.RTS.EventParserUtils
import GHC.RTS.EventTypes
import GHC.RTS.Events.Binary

#define EVENTLOG_CONSTANTS_ONLY
#include "EventLogFormat.h"

-- | The unfolding of the decoding process.
data Decoder a
  = Consume (B.ByteString -> Decoder a)
  -- ^ The decoder has consumed all the available input and needs more to
  -- continue.
  | Produce !a (Decoder a)
  -- ^ The decoder has returned a decoded value and the next decoder state to
  -- continue.
  | Done B.ByteString
  -- ^ The decoder has ended with leftover input.
  | Error B.ByteString String
  -- ^ The decoder has encountered an error with leftover input and an error
  -- message.

-- | Push an input chunk to the decoder
pushChunk :: Decoder a -> B.ByteString -> Decoder a
pushChunk :: Decoder a -> ByteString -> Decoder a
pushChunk Decoder a
decoder ByteString
chunk = case Decoder a
decoder of
  Consume ByteString -> Decoder a
k -> ByteString -> Decoder a
k ByteString
chunk
  Produce a
a Decoder a
decoder' -> a -> Decoder a -> Decoder a
forall a. a -> Decoder a -> Decoder a
Produce a
a (Decoder a -> Decoder a) -> Decoder a -> Decoder a
forall a b. (a -> b) -> a -> b
$ Decoder a
decoder' Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
chunk
  Done ByteString
leftover -> ByteString -> Decoder a
forall a. ByteString -> Decoder a
Done (ByteString -> Decoder a) -> ByteString -> Decoder a
forall a b. (a -> b) -> a -> b
$ ByteString
leftover ByteString -> ByteString -> ByteString
`B.append` ByteString
chunk
  Error ByteString
leftover String
err -> ByteString -> String -> Decoder a
forall a. ByteString -> String -> Decoder a
Error (ByteString
leftover ByteString -> ByteString -> ByteString
`B.append` ByteString
chunk) String
err

-- | Decode a header and continue with the provided decoder
withHeader
  :: (Header -> B.ByteString -> Decoder r)
  -- ^ Continuation
  -> Decoder r
withHeader :: (Header -> ByteString -> Decoder r) -> Decoder r
withHeader Header -> ByteString -> Decoder r
f = Decoder Header -> Decoder r
go (Decoder Header -> Decoder r) -> Decoder Header -> Decoder r
forall a b. (a -> b) -> a -> b
$ Get Header -> Decoder Header
forall a. Get a -> Decoder a
G.runGetIncremental Get Header
getHeader
  where
    go :: Decoder Header -> Decoder r
go Decoder Header
decoder = case Decoder Header
decoder of
      G.Done ByteString
leftover ByteOffset
_ Header
header -> Header -> ByteString -> Decoder r
f Header
header ByteString
leftover
      G.Partial Maybe ByteString -> Decoder Header
k -> (ByteString -> Decoder r) -> Decoder r
forall a. (ByteString -> Decoder a) -> Decoder a
Consume ((ByteString -> Decoder r) -> Decoder r)
-> (ByteString -> Decoder r) -> Decoder r
forall a b. (a -> b) -> a -> b
$ \ByteString
chunk -> Decoder Header -> Decoder r
go (Decoder Header -> Decoder r) -> Decoder Header -> Decoder r
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Decoder Header
k (Maybe ByteString -> Decoder Header)
-> Maybe ByteString -> Decoder Header
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk
      G.Fail ByteString
leftover ByteOffset
_ String
err -> ByteString -> String -> Decoder r
forall a. ByteString -> String -> Decoder a
Error ByteString
leftover String
err

-- | Decode a header
decodeHeader :: Decoder Header
decodeHeader :: Decoder Header
decodeHeader = (Header -> ByteString -> Decoder Header) -> Decoder Header
forall r. (Header -> ByteString -> Decoder r) -> Decoder r
withHeader ((Header -> ByteString -> Decoder Header) -> Decoder Header)
-> (Header -> ByteString -> Decoder Header) -> Decoder Header
forall a b. (a -> b) -> a -> b
$ \Header
header ByteString
leftover -> Header -> Decoder Header -> Decoder Header
forall a. a -> Decoder a -> Decoder a
Produce Header
header (Decoder Header -> Decoder Header)
-> Decoder Header -> Decoder Header
forall a b. (a -> b) -> a -> b
$ ByteString -> Decoder Header
forall a. ByteString -> Decoder a
Done ByteString
leftover

-- | Decode events
decodeEvents :: Header -> Decoder Event
decodeEvents :: Header -> Decoder Event
decodeEvents Header
header = Int -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
forall t.
(Ord t, Num t) =>
t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go (Int
0 :: Int) Maybe Int
forall a. Maybe a
Nothing Decoder (Maybe Event)
decoder0
  where
    decoder0 :: Decoder (Maybe Event)
decoder0 = Header -> Decoder (Maybe Event)
mkEventDecoder Header
header
    go :: t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go !t
remaining !Maybe Int
blockCap Decoder (Maybe Event)
decoder = case Decoder (Maybe Event)
decoder of
      G.Done ByteString
leftover ByteOffset
consumed Maybe Event
r -> do
        let !decoder' :: Decoder (Maybe Event)
decoder' = Decoder (Maybe Event)
decoder0 Decoder (Maybe Event) -> ByteString -> Decoder (Maybe Event)
forall a. Decoder a -> ByteString -> Decoder a
`G.pushChunk` ByteString
leftover
        case Maybe Event
r of
          Just Event
event -> case Event -> EventInfo
evSpec Event
event of
            EventBlock {Int
BlockSize
Timestamp
block_size :: EventInfo -> BlockSize
cap :: EventInfo -> Int
end_time :: EventInfo -> Timestamp
block_size :: BlockSize
cap :: Int
end_time :: Timestamp
..} ->
              t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go (BlockSize -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral BlockSize
block_size) (Int -> Maybe Int
mkCap Int
cap) Decoder (Maybe Event)
decoder'
            EventInfo
_ -> do
              let
                !remaining' :: t
remaining' = t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- ByteOffset -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
consumed
                !blockCap' :: Maybe Int
blockCap' = if t
remaining' t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
0 then Maybe Int
blockCap else Maybe Int
forall a. Maybe a
Nothing
                !event' :: Event
event' = Event
event { evCap :: Maybe Int
evCap = Maybe Int
blockCap }
              Event -> Decoder Event -> Decoder Event
forall a. a -> Decoder a -> Decoder a
Produce Event
event' (Decoder Event -> Decoder Event) -> Decoder Event -> Decoder Event
forall a b. (a -> b) -> a -> b
$ t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go t
remaining' Maybe Int
blockCap' Decoder (Maybe Event)
decoder'
          Maybe Event
Nothing -> t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go t
remaining Maybe Int
blockCap Decoder (Maybe Event)
decoder'
      G.Partial Maybe ByteString -> Decoder (Maybe Event)
k ->
        (ByteString -> Decoder Event) -> Decoder Event
forall a. (ByteString -> Decoder a) -> Decoder a
Consume ((ByteString -> Decoder Event) -> Decoder Event)
-> (ByteString -> Decoder Event) -> Decoder Event
forall a b. (a -> b) -> a -> b
$ \ByteString
chunk -> t -> Maybe Int -> Decoder (Maybe Event) -> Decoder Event
go t
remaining Maybe Int
blockCap (Decoder (Maybe Event) -> Decoder Event)
-> Decoder (Maybe Event) -> Decoder Event
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Decoder (Maybe Event)
k (Maybe ByteString -> Decoder (Maybe Event))
-> Maybe ByteString -> Decoder (Maybe Event)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
chunk
      G.Fail ByteString
leftover ByteOffset
_ String
err ->
        ByteString -> String -> Decoder Event
forall a. ByteString -> String -> Decoder a
Error ByteString
leftover String
err

-- | Decode a header and events
decodeEventLog :: Decoder Event
decodeEventLog :: Decoder Event
decodeEventLog = (Header -> ByteString -> Decoder Event) -> Decoder Event
forall r. (Header -> ByteString -> Decoder r) -> Decoder r
withHeader ((Header -> ByteString -> Decoder Event) -> Decoder Event)
-> (Header -> ByteString -> Decoder Event) -> Decoder Event
forall a b. (a -> b) -> a -> b
$ \Header
header ByteString
leftover ->
  Header -> Decoder Event
decodeEvents Header
header Decoder Event -> ByteString -> Decoder Event
forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
leftover

-- | Read a header from a lazy bytestring and return the header and the
-- leftover input for subsequent decoding.
--
-- Note that the input must contain a whole header in one go. If incremental
-- parsing of a header is necessary, use 'decodeHeader' instead.
readHeader :: BL.ByteString -> Either String (Header, BL.ByteString)
readHeader :: ByteString -> Either String (Header, ByteString)
readHeader = Either (Decoder Header) Header
-> ByteString -> Either String (Header, ByteString)
forall b.
Either (Decoder b) b -> ByteString -> Either String (b, ByteString)
go (Either (Decoder Header) Header
 -> ByteString -> Either String (Header, ByteString))
-> Either (Decoder Header) Header
-> ByteString
-> Either String (Header, ByteString)
forall a b. (a -> b) -> a -> b
$ Decoder Header -> Either (Decoder Header) Header
forall a b. a -> Either a b
Left Decoder Header
decodeHeader
  where
    go :: Either (Decoder b) b -> ByteString -> Either String (b, ByteString)
go Either (Decoder b) b
r ByteString
bytes = case Either (Decoder b) b
r of
      Left Decoder b
decoder -> case Decoder b
decoder of
        Produce b
header Decoder b
decoder' -> case Decoder b
decoder' of
          Done ByteString
leftover -> (b, ByteString) -> Either String (b, ByteString)
forall a b. b -> Either a b
Right (b
header, ByteString -> ByteString -> ByteString
BL.Chunk ByteString
leftover ByteString
bytes)
          Decoder b
_ -> String -> Either String (b, ByteString)
forall a b. a -> Either a b
Left String
"readHeader: unexpected decoder"
        Consume ByteString -> Decoder b
k -> case ByteString
bytes of
          ByteString
BL.Empty -> String -> Either String (b, ByteString)
forall a b. a -> Either a b
Left String
"readHeader: not enough bytes"
          BL.Chunk ByteString
chunk ByteString
chunks -> Either (Decoder b) b -> ByteString -> Either String (b, ByteString)
go (Decoder b -> Either (Decoder b) b
forall a b. a -> Either a b
Left (Decoder b -> Either (Decoder b) b)
-> Decoder b -> Either (Decoder b) b
forall a b. (a -> b) -> a -> b
$! ByteString -> Decoder b
k ByteString
chunk) ByteString
chunks
        Done ByteString
_ -> String -> Either String (b, ByteString)
forall a b. a -> Either a b
Left String
"readHeader: unexpected termination"
        Error ByteString
_ String
err -> String -> Either String (b, ByteString)
forall a b. a -> Either a b
Left String
err
      Right b
header -> (b, ByteString) -> Either String (b, ByteString)
forall a b. b -> Either a b
Right (b
header, ByteString
bytes)


-- | Read events from a lazy bytestring. It returns an error message if it
-- encounters an error while decoding.
--
-- Note that it doesn't fail if it consumes all input in the middle of decoding
-- of an event.
readEvents :: Header -> BL.ByteString -> ([Event], Maybe String)
readEvents :: Header -> ByteString -> ([Event], Maybe String)
readEvents Header
header = ([Either String Event], [Either String Event])
-> ([Event], Maybe String)
forall a b a b. ([Either a b], [Either a b]) -> ([b], Maybe a)
f (([Either String Event], [Either String Event])
 -> ([Event], Maybe String))
-> (ByteString -> ([Either String Event], [Either String Event]))
-> ByteString
-> ([Event], Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either String Event -> Bool)
-> [Either String Event]
-> ([Either String Event], [Either String Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Either String Event -> Bool
forall a b. Either a b -> Bool
isLeft ([Either String Event]
 -> ([Either String Event], [Either String Event]))
-> (ByteString -> [Either String Event])
-> ByteString
-> ([Either String Event], [Either String Event])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decoder Event -> ByteString -> [Either String Event]
go (Header -> Decoder Event
decodeEvents Header
header)
  where
    f :: ([Either a b], [Either a b]) -> ([b], Maybe a)
f ([Either a b]
rs, [Either a b]
ls) = ([Either a b] -> [b]
forall a b. [Either a b] -> [b]
rights [Either a b]
rs, [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([Either a b] -> [a]
forall a b. [Either a b] -> [a]
lefts [Either a b]
ls))
#if !MIN_VERSION_base(4, 7, 0)
    isLeft (Left _) = True
    isLeft _ = False
#endif

    go :: Decoder Event -> BL.ByteString -> [Either String Event]
    go :: Decoder Event -> ByteString -> [Either String Event]
go Decoder Event
decoder ByteString
bytes = case Decoder Event
decoder of
      Produce Event
event Decoder Event
decoder' -> Event -> Either String Event
forall a b. b -> Either a b
Right Event
event Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Decoder Event -> ByteString -> [Either String Event]
go Decoder Event
decoder' ByteString
bytes
      Consume ByteString -> Decoder Event
k -> case ByteString
bytes of
        ByteString
BL.Empty -> []
        BL.Chunk ByteString
chunk ByteString
chunks -> Decoder Event -> ByteString -> [Either String Event]
go (ByteString -> Decoder Event
k ByteString
chunk) ByteString
chunks
      Done {} -> []
      Error ByteString
_ String
err -> [String -> Either String Event
forall a b. a -> Either a b
Left String
err]

-- | Read an entire eventlog from a lazy bytestring. It returns an error message if it
-- encounters an error while decoding.
--
-- Note that it doesn't fail if it consumes all input in the middle of decoding
-- of an event.
readEventLog :: BL.ByteString -> Either String (EventLog, Maybe String)
readEventLog :: ByteString -> Either String (EventLog, Maybe String)
readEventLog ByteString
bytes = do
  (Header
header, ByteString
bytes') <- ByteString -> Either String (Header, ByteString)
readHeader ByteString
bytes
  case Header -> ByteString -> ([Event], Maybe String)
readEvents Header
header ByteString
bytes' of
    ([Event]
events, Maybe String
err) -> (EventLog, Maybe String) -> Either String (EventLog, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> Data -> EventLog
EventLog Header
header ([Event] -> Data
Data [Event]
events), Maybe String
err)

-- | Makes a decoder with all the required parsers when given a Header
mkEventDecoder :: Header -> G.Decoder (Maybe Event)
mkEventDecoder :: Header -> Decoder (Maybe Event)
mkEventDecoder Header
header = Get (Maybe Event) -> Decoder (Maybe Event)
forall a. Get a -> Decoder a
G.runGetIncremental (Get (Maybe Event) -> Decoder (Maybe Event))
-> Get (Maybe Event) -> Decoder (Maybe Event)
forall a b. (a -> b) -> a -> b
$ EventParsers -> Get (Maybe Event)
getEvent EventParsers
parsers
  where
    imap :: IntMap EventType
imap = [(Int, EventType)] -> IntMap EventType
forall a. [(Int, a)] -> IntMap a
IM.fromList [(EventTypeNum -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EventType -> EventTypeNum
num EventType
t), EventType
t) | EventType
t <- Header -> [EventType]
eventTypes Header
header]
    -- This test is complete, no-one has extended this event yet and all future
    -- extensions will use newly allocated event IDs.
    is_ghc_6 :: Bool
is_ghc_6 = EventTypeNum -> Maybe EventTypeNum
forall a. a -> Maybe a
Just EventTypeNum
sz_old_tid Maybe EventTypeNum -> Maybe EventTypeNum -> Bool
forall a. Eq a => a -> a -> Bool
== do
      EventType
create_et <- Int -> IntMap EventType -> Maybe EventType
forall a. Int -> IntMap a -> Maybe a
IM.lookup EVENT_CREATE_THREAD imap
      EventType -> Maybe EventTypeNum
size EventType
create_et
    -- GHC6 writes an invalid header, we handle it here by using a
    -- different set of event parsers.  Note that the ghc7 event parsers
    -- are standard events, and can be used by other runtime systems that
    -- make use of threadscope.

    -- GHC-7.8.2 uses a different thread block status encoding,
    -- and therefore requires a different parser for the stop
    -- event. Later, in GHC-7.8.3, the old encoding was restored.
    -- GHC-7.8.2 can be recognised by presence and absence of
    -- events in the header:
    --   * User markers were added in GHC-7.8
    --   * an empty event HACK_BUG_T9003 was added in GHC-7.8.3
    -- This fix breaks software which uses ghc-events and combines
    -- user markers with the older stop status encoding. We don't
    -- know of any such software, though.
    is_pre77 :: Bool
is_pre77 = Int -> IntMap EventType -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember EVENT_USER_MARKER imap
    is_ghc782 :: Bool
is_ghc782 = Int -> IntMap EventType -> Bool
forall a. Int -> IntMap a -> Bool
IM.member EVENT_USER_MARKER imap
      Bool -> Bool -> Bool
&& Int -> IntMap EventType -> Bool
forall a. Int -> IntMap a -> Bool
IM.notMember EVENT_HACK_BUG_T9003 imap

    stopParsers :: [EventParser EventInfo]
stopParsers
      | Bool
is_pre77 = [EventParser EventInfo]
pre77StopParsers
      | Bool
is_ghc782 = [EventParser EventInfo
ghc782StopParser]
      | Bool
otherwise = [EventParser EventInfo
post782StopParser]

    event_parsers :: [EventParser EventInfo]
event_parsers
      | Bool
is_ghc_6 = [[EventParser EventInfo]] -> [EventParser EventInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [EventParser EventInfo]
standardParsers
        , [EventParser EventInfo]
ghc6Parsers
        , EventTypeNum -> [EventParser EventInfo]
parRTSParsers EventTypeNum
sz_old_tid
        ]
      | Bool
otherwise = [[EventParser EventInfo]] -> [EventParser EventInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [EventParser EventInfo]
standardParsers
        , [EventParser EventInfo]
ghc7Parsers
        , [EventParser EventInfo]
stopParsers
        , EventTypeNum -> [EventParser EventInfo]
parRTSParsers EventTypeNum
sz_tid
        , [EventParser EventInfo]
mercuryParsers
        , [EventParser EventInfo]
perfParsers
        , [EventParser EventInfo]
heapProfParsers
        , [EventParser EventInfo]
timeProfParsers
        , [EventParser EventInfo]
binaryEventParsers
        ]
    parsers :: EventParsers
parsers = Array Int (Get EventInfo) -> EventParsers
EventParsers (Array Int (Get EventInfo) -> EventParsers)
-> Array Int (Get EventInfo) -> EventParsers
forall a b. (a -> b) -> a -> b
$ IntMap EventType
-> [EventParser EventInfo] -> Array Int (Get EventInfo)
mkEventTypeParsers IntMap EventType
imap [EventParser EventInfo]
event_parsers