content: module Events.ReadEvents (
      registerEventsFromFile, registerEventsFromTrace
    ) where
  
  import Events.EventTree
  import Events.SparkTree
  import Events.HECs (HECs(..), histogram)
  import Events.TestEvents
  import Events.EventDuration
  import qualified GUI.ProgressView as ProgressView
  import GUI.ProgressView (ProgressView)
  
  import GHC.RTS.Events -- hiding (Event)
  
  import GHC.RTS.Events.Analysis
  import GHC.RTS.Events.Analysis.SparkThread
  import GHC.RTS.Events.Analysis.Capability
  
  import Data.Array
  import qualified Data.List as L
  import Data.Map (Map)
  import qualified Data.Map as M
  import qualified Data.IntMap as IM
  import Data.Set (Set)
  import Data.Maybe (catMaybes, fromMaybe)
  import Text.Printf
  import System.FilePath
  import Control.Monad
  import Control.Exception
  import qualified Control.DeepSeq as DeepSeq
  import Data.Function
  import Data.Either
  
  -------------------------------------------------------------------------------
  -- import qualified GHC.RTS.Events as GHCEvents
  --
  -- The GHC.RTS.Events library returns the profile information
  -- in a data-streucture which contains a list data structure
  -- representing the events i.e. [GHCEvents.Event]
  -- ThreadScope transforms this list into an alternative representation
  -- which (for each HEC) records event *durations* which are ordered in time.
  -- The durations represent the run-lengths for thread execution and
  -- run-lengths for garbage colleciton. This data-structure is called
  -- EventDuration.
  -- ThreadScope then transformations this data-structure into another
  -- data-structure which gives a binary-tree view of the event information
  -- by performing a binary split on the time domain i.e. the EventTree
  -- data structure.
  
  -- GHCEvents.Event => [EventDuration] => EventTree
  
  -------------------------------------------------------------------------------
  
  rawEventsToHECs :: [CapEvent] -> Timestamp
                  -> [(Double, (DurationTree, EventTree, SparkTree))]
  rawEventsToHECs evs endTime
    = map (\ cap -> toTree $ L.find ((Just cap ==) . ce_cap . head) heclists)
        [0 .. maximum (0 : map (fromMaybe 0 . ce_cap) evs)]
    where
      heclists =
        L.groupBy ((==) `on` ce_cap) $ L.sortBy (compare `on` ce_cap) evs
  
      toTree Nothing    = (0, (DurationTreeEmpty,
                               EventTree 0 0 (EventTreeLeaf []),
                               emptySparkTree))
      toTree (Just evs) =
        (maxSparkPool,
         (mkDurationTree (eventsToDurations nondiscrete) endTime,
          mkEventTree discrete endTime,
          mkSparkTree sparkD endTime))
         where es = map ce_event evs
               (discrete, nondiscrete) = L.partition isDiscreteEvent es
               (maxSparkPool, sparkD)  = eventsToSparkDurations nondiscrete
  
  -------------------------------------------------------------------------------
  
  registerEventsFromFile :: String -> ProgressView
                         -> IO (HECs, String, Int, Double)
  registerEventsFromFile filename = registerEvents (Left filename)
  
  registerEventsFromTrace :: String -> ProgressView
                          -> IO (HECs, String, Int, Double)
  registerEventsFromTrace traceName = registerEvents (Right traceName)
  
  registerEvents :: Either FilePath String
                 -> ProgressView
                 -> IO (HECs, String, Int, Double)
  
  registerEvents from progress = do
  
    let msg = case from of
                Left filename -> filename
                Right test    -> test
  
    ProgressView.setTitle progress ("Loading " ++ takeFileName msg)
  
    buildEventLog progress from
  
  -------------------------------------------------------------------------------
  -- Runs in a background thread
  --
  buildEventLog :: ProgressView -> Either FilePath String
                -> IO (HECs, String, Int, Double)
  buildEventLog progress from =
    case from of
      Right test     -> build test (testTrace test)
      Left filename  -> do
        stopPulse <- ProgressView.startPulse progress
        fmt <- readEventLogFromFile filename
        stopPulse
        case fmt of
          Left  err -> fail err --FIXME: report error properly
          Right evs -> build filename evs
  
   where
    -- | Integer division, rounding up.
    divUp :: Timestamp -> Timestamp -> Timestamp
    divUp n k = (n + k - 1) `div` k
    build name evs = do
      let
        specBy1000 e@EventBlock{} =
          e{end_time = end_time e `divUp` 1000,
            block_events = map eBy1000 (block_events e)}
        specBy1000 e = e
        eBy1000 ev = ev{time = time ev `divUp` 1000,
                        spec = specBy1000 (spec ev)}
        eventsBy = map eBy1000 (events (dat evs))
        eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t
        eventBlockEnd e = time e
  
        -- 1, to avoid graph scale 0 and division by 0 later on
        lastTx = maximum (1 : map eventBlockEnd eventsBy)
  
        -- Add caps to perf events, using the OS thread numbers
        -- obtained from task validation data.
        -- Only the perf events with a cap are displayed in the timeline.
        -- TODO: it may make sense to move this code to ghc-events
        -- and run after to-eventlog and ghc-events merge, but it requires
        -- one more step in the 'perf to TS' workflow and is a bit slower
        -- (yet another event sorting and loading eventlog chunks
        -- into the CPU cache).
        steps :: [CapEvent] -> [(Map KernelThreadId Int, CapEvent)]
        steps evs =
          zip (map fst $ rights $ validates capabilityTaskOSMachine evs) evs
        addC :: (Map KernelThreadId Int, CapEvent) -> CapEvent
        addC (state, ev@CapEvent{ce_event=Event{spec=PerfTracepoint{tid}}}) =
          case M.lookup tid state of
            Nothing -> ev  -- unknown task's OS thread
            ce_cap  -> ev {ce_cap}
        addC (state, ev@CapEvent{ce_event=Event{spec=PerfCounter{tid}}}) =
          case M.lookup tid state of
            Nothing -> ev  -- unknown task's OS thread
            ce_cap  -> ev {ce_cap}
        addC (_, ev) = ev
        addCaps evs = map addC (steps evs)
  
        -- sort the events by time, add extra caps and put them in an array
        sorted = addCaps $ sortEvents eventsBy
        maxTrees = rawEventsToHECs sorted lastTx
        maxSparkPool = maximum (0 : map fst maxTrees)
        trees = map snd maxTrees
  
        -- put events in an array
        n_events  = length sorted
        event_arr = listArray (0, n_events-1) sorted
        hec_count = length trees
  
        -- Pre-calculate the data for the sparks histogram.
        intDoub :: Integral a => a -> Double
        intDoub = fromIntegral
        -- Discretizes the data using log.
        -- Log base 2 seems to result in 7--15 bars, which is OK visually.
        -- Better would be 10--15 bars, but we want the base to be a small
        -- integer, for readable scales, and we can't go below 2.
        ilog :: Timestamp -> Int
        ilog 0 = 0
        ilog x = floor $ logBase 2 (intDoub x)
        times :: (Int, Timestamp, Timestamp)
              -> Maybe (Timestamp, Int, Timestamp)
        times (_, timeStarted, timeElapsed) =
          Just (timeStarted, ilog timeElapsed, timeElapsed)
  
        sparkProfile :: Process
                          ((Map ThreadId (Profile SparkThreadState),
                            (Map Int ThreadId, Set ThreadId)),
                           CapEvent)
                          (ThreadId, (SparkThreadState, Timestamp, Timestamp))
        sparkProfile  = profileRouted
                          (refineM (spec . ce_event) sparkThreadMachine)
                          capabilitySparkThreadMachine
                          capabilitySparkThreadIndexer
                          (time . ce_event)
                          sorted
  
        sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp)
                     -> [(ThreadId, (SparkThreadState, Timestamp, Timestamp))]
                     -> [Maybe (Timestamp, Int, Timestamp)]
        sparkSummary m [] = map times $ M.elems m
        sparkSummary m ((threadId, (state, timeStarted', timeElapsed')):xs) =
          case state of
            SparkThreadRunning sparkId' -> case M.lookup threadId m of
              Just el@(sparkId, timeStarted, timeElapsed) ->
                if sparkId == sparkId'
                then let value = (sparkId, timeStarted, timeElapsed + timeElapsed')
                     in sparkSummary (M.insert threadId value m) xs
                else times el : newSummary sparkId' xs
              Nothing -> newSummary sparkId' xs
            _ -> sparkSummary m xs
         where
          newSummary sparkId = let value = (sparkId, timeStarted', timeElapsed')
                               in sparkSummary (M.insert threadId value m)
  
        allHisto :: [(Timestamp, Int, Timestamp)]
        allHisto = catMaybes . sparkSummary M.empty . toList $ sparkProfile
  
        -- Sparks of zero lenght are already well visualized in other graphs:
        durHistogram = filter (\ (_, logdur, _) -> logdur > 0) allHisto
        -- Precompute some extremums of the maximal interval, needed for scales.
        durs = [(logdur, dur) | (_start, logdur, dur) <- durHistogram]
        (logDurs, sumDurs) = L.unzip (histogram durs)
        minXHistogram = minimum (maxBound : logDurs)
        maxXHistogram = maximum (minBound : logDurs)
        maxY          = maximum (minBound : sumDurs)
        -- round up to multiples of 10ms
        maxYHistogram = 10000 * ceiling (fromIntegral maxY / 10000)
  
        getPerfNames nmap ev =
          case spec ev of
            EventBlock{block_events} ->
              L.foldl' getPerfNames nmap block_events
            PerfName{perfNum, name} ->
              IM.insert (fromIntegral perfNum) name nmap
            _ -> nmap
        perfNames = L.foldl' getPerfNames IM.empty eventsBy
  
        hecs = HECs {
                 hecCount         = hec_count,
                 hecTrees         = trees,
                 hecEventArray    = event_arr,
                 hecLastEventTime = lastTx,
                 maxSparkPool,
                 minXHistogram,
                 maxXHistogram,
                 maxYHistogram,
                 durHistogram,
                 perfNames
              }
  
        treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO ()
        treeProgress hec (tree1, tree2, tree3) = do
           ProgressView.setText progress $
                    printf "Building HEC %d/%d" (hec+1) hec_count
           ProgressView.setProgress progress hec_count hec
           evaluate tree1
           evaluate (eventTreeMaxDepth tree2)
           evaluate (sparkTreeMaxDepth tree3)
           when (hec_count == 1 || hec == 1)  -- eval only with 2nd HEC
             (return $! DeepSeq.rnf durHistogram)
  
      zipWithM_ treeProgress [0..] trees
      ProgressView.setProgress progress hec_count hec_count
  
      -- TODO: fully evaluate HECs before returning because otherwise the last
      -- bit of work gets done after the progress window has been closed.
  
      return (hecs, name, n_events, fromIntegral lastTx / 1000000)
  