module Profiling.Linux.Perf
(
TypeMap
, TypeInfo (..)
, OutputStyle (..)
, readAndDisplay
, readPerfData
, display
, makeTypeMap
, sortEventsOnTime
) where
import Profiling.Linux.Perf.Parse
( readHeader, readAttributes, readAttributeIDs, readEventTypes, readEvent )
import Profiling.Linux.Perf.Types
( FileHeader (..), FileAttr (..), TraceEventType (..), Event (..)
, EventPayload (..), EventHeader (..) , EventAttr (..), EventAttrFlag (..)
, testEventAttrFlag, PID (..), TID (..), EventTypeID (..), EventSource (..)
, EventID (..), TimeStamp (..), SampleTypeBitMap (..), ByteCount64 (..)
, PerfData (..) )
import Profiling.Linux.Perf.Pretty ( pretty )
import Text.PrettyPrint as Pretty
( render, Doc, empty, text, (<+>), (<>), vcat, ($$), int, hsep, hcat )
import Data.List as List (intersperse, sortBy, foldl')
import Data.Map as Map hiding (mapMaybe, map, filter, null)
import System.IO (openFile, IOMode(ReadMode), Handle)
import Data.Maybe (mapMaybe)
import Data.ByteString.Lazy.Char8 (unpack)
type TypeMap = Map EventID TypeInfo
data TypeInfo =
TypeInfo
{ typeInfo_name :: String
, typeInfo_source :: EventSource
, typeInfo_id :: EventTypeID
}
sortEventsOnTime :: [Event] -> [Event]
sortEventsOnTime =
sortBy compareEventTime
where
compareEventTime :: Event -> Event -> Ordering
compareEventTime e1 e2 =
compare (getEventTime $ ev_payload e1) (getEventTime $ ev_payload e2)
getEventTime :: EventPayload -> TimeStamp
getEventTime e@(SampleEvent {}) = maybe (TimeStamp 0) id $ eventPayload_SampleTime e
getEventTime e@(ForkEvent {}) = eventPayload_time e
getEventTime e@(ExitEvent {}) = eventPayload_time e
getEventTime e@(ThrottleEvent {}) = eventPayload_time e
getEventTime e@(UnThrottleEvent {}) = eventPayload_time e
getEventTime other = TimeStamp 0
makeTypeMap :: PerfData -> TypeMap
makeTypeMap perfData =
List.foldl' idsToInfo Map.empty attrsIDs
where
idss :: [[EventID]]
idss = perfData_idss perfData
types :: [TraceEventType]
types = perfData_types perfData
attrs :: [EventAttr]
attrs = map fa_attr $ perfData_attrs perfData
attrsIDs :: [(EventAttr, EventID)]
attrsIDs = [(attribute, id) | (attribute, idents) <- zip attrs idss, id <- idents]
eventTypeToName :: Map EventTypeID String
eventTypeToName = Map.fromList $ map (\t -> (te_event_id t, unpack $ te_name t)) types
idsToInfo :: TypeMap -> (EventAttr, EventID) -> TypeMap
idsToInfo acc (attr, eventID) =
case Map.lookup typeID eventTypeToName of
Nothing -> acc
Just typeName ->
Map.insert eventID (TypeInfo typeName typeSource typeID) acc
where
typeSource = ea_type attr
typeID = ea_config attr
data OutputStyle
= Dump
| Trace
readAndDisplay :: OutputStyle -> FilePath -> IO ()
readAndDisplay style file = display style =<< readPerfData file
readPerfData :: FilePath -> IO PerfData
readPerfData file = do
h <- openFile file ReadMode
header <- readHeader h
attrs <- readAttributes h header
idss <- mapM (readAttributeIDs h) attrs
types <- readEventTypes h header
let attrTypeInfo = getAttrInfo attrs
(sampleType, sampleIdAll) =
case attrTypeInfo of
[] -> (SampleTypeBitMap 0, False)
x:_ -> x
dataOffset = fh_data_offset header
maxOffset = fh_data_size header + dataOffset
events <- readEvents h maxOffset dataOffset sampleType
return $ PerfData header attrs idss types events
display :: OutputStyle -> PerfData -> IO ()
display style contents =
let docs = case style of
Dump -> dumper contents
Trace -> tracer contents
in mapM_ (putStrLn . render) docs
getAttrInfo :: [FileAttr] -> [(SampleTypeBitMap, Bool)]
getAttrInfo = map getSampleTypeAndIdAll
where
getSampleTypeAndIdAll :: FileAttr -> (SampleTypeBitMap, Bool)
getSampleTypeAndIdAll fattr
= (ea_sample_type attr, testEventAttrFlag (ea_flags attr) SampleIdAll)
where
attr = fa_attr $ fattr
readEvents :: Handle -> ByteCount64 -> ByteCount64 -> SampleTypeBitMap -> IO [Event]
readEvents h maxOffset offset sampleType =
readWorker offset []
where
readWorker :: ByteCount64 -> [Event] -> IO [Event]
readWorker offset acc
| offset >= maxOffset = return $ reverse acc
| otherwise = do
event <- readEvent h offset sampleType
let size = eh_size $ ev_header event
nextOffset = offset + fromIntegral size
readWorker nextOffset (event:acc)
dumper :: PerfData -> [Doc]
dumper (PerfData header attrs idss types events) =
intersperse separator $
[ text "Perf File Header:"
, pretty header
, text "Perf File Attributes:"
, vcat $ intersperse separator $
map prettyAttrAndIds $ zip attrs idss
, text "Trace Event Types:"
, vcat $ map pretty types
, text "Events:"
] ++ map pretty events
where
prettyAttrAndIds (attr, ids) =
pretty attr $$ (text "ids:" <+> (hsep $ map pretty ids))
separator :: Doc
separator = text $ replicate 40 '-'
tracer :: PerfData -> [Doc]
tracer perfData@(PerfData header attrs idss types events) =
concatMap (prettyPayload typeMap . ev_payload) sortedEvents
where
csv :: [Doc] -> [Doc]
csv docs = [hcat $ intersperse (text ", ") docs]
sortedEvents = sortEventsOnTime events
typeMap = makeTypeMap perfData
prettyPayload :: TypeMap -> EventPayload -> [Doc]
prettyPayload _typeMap ev@(CommEvent {}) =
csv [ text "PID" <+> (pretty . eventPayload_pid) ev
, text "TID" <+> (pretty . eventPayload_tid) ev
, text "command" <+> (pretty . eventPayload_CommName) ev ]
prettyPayload typeMap ev@(SampleEvent {}) =
csv [ text "PID" <+> (pretty . eventPayload_SamplePID) ev
, text "TID" <+> (pretty . eventPayload_SampleTID) ev
, sampleDoc
, text "time" <+> (pretty . eventPayload_SampleTime) ev
, text "CPU" <+> (pretty . eventPayload_SampleCPU) ev
, text "IP" <+> (pretty . eventPayload_SampleIP) ev
, text "Addr" <+> (pretty . eventPayload_SampleAddr) ev
, text "Stream" <+> (pretty . eventPayload_SampleStreamID) ev
, text "Period" <+> (pretty . eventPayload_SamplePeriod) ev ]
where
sampleDoc
| Just id <- eventPayload_SampleID ev,
Just typeInfo <- Map.lookup id typeMap =
text "sample" <+> (text . typeInfo_name) typeInfo
| otherwise = text "sample <unknown source>"
prettyPayload _typeMap other = []