ghc-build-stats-0.1.0.0: src/Simulate.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
module Simulate where

import Data.OrdPSQ (OrdPSQ)
import Data.Map.Strict (Map)
import Data.Maybe
import Data.List (maximumBy)
import Data.Function (on)

import WeighedNode

import qualified Data.OrdPSQ as OrdPSQ
import qualified Data.Map.Strict as M
import qualified Data.Set as S


-- | Module info used in our simulation
data SimModInfo =
  SimModInfo
    { simModRevDeps :: [ModName]
    , simNumDeps :: !Int
    , simModTime :: !Double
    }
  deriving (Show)

createSimModInfo :: WeighedGraph -> Map ModName SimModInfo
createSimModInfo wg = foldl' recordRevDeps initialGraph (M.toList wg)
  where
    numDeps = length . filter (`M.member` wg) . nodeDeps
    initialGraph = M.map (\x -> SimModInfo [] (numDeps x) (nodeEopTime x)) wg
    recordRevDeps :: Map ModName SimModInfo -> (ModName, WeighedNode) -> Map ModName SimModInfo
    recordRevDeps !old (modName, WeighedNode {nodeDeps = nodeDeps }) =
      foldl' addRevDep old nodeDeps
      where
        addRevDep !o depName =
          M.adjust (\x -> x { simModRevDeps = modName : simModRevDeps x }) depName o

data State =
  State
   { stateQueue :: !(OrdPSQ ModName Int SimModInfo)
   , stateActive :: !(OrdPSQ ModName Double (Double, Int, SimModInfo))
   , stateTime :: !Double
   , stateGaps :: !(S.Set Int)
   , stateOut :: ![ModEvent]
   }
 deriving (Show)

data ModEvent = ModEvent
  { eventStart :: !Double
  , eventEnd :: !Double
  , eventModName :: !ModName
  , eventThreadId :: !Int
  }
  deriving (Show)

goSimulate :: State -> Maybe State
goSimulate st@State{..} = case OrdPSQ.minView stateQueue of
  Just (k, 0, minfo@SimModInfo{..}, stateQueue') 
   | Just (threadId, stateGaps') <- S.minView stateGaps ->
    let
      stateActive' = OrdPSQ.insert k (stateTime + simModTime) (stateTime, threadId, minfo) stateActive
    in Just $ st
      { stateQueue = stateQueue'
      , stateActive = stateActive'
      , stateGaps = stateGaps'
      }
  _ -> -- not ready to pop as we are waiting for dependencies
    case OrdPSQ.findMin stateActive of
      Nothing -> Nothing
      Just (_, endTime , _) -> Just $ dropDone (st { stateTime = endTime })

dropDone
  :: State
  -> State
dropDone st@State{..} =
  case OrdPSQ.minView stateActive of
    Nothing -> st -- empty
    Just (k, end, (startTime, threadId, modSum), active') ->
      if end <= stateTime then
        dropDone $ updateRevDeps (simModRevDeps  modSum) $ st { stateActive = active', stateOut = ModEvent startTime end k threadId :stateOut, stateGaps = S.insert threadId stateGaps }
      else
        st

updateRevDeps :: [ModName] -> State -> State
updateRevDeps modNms st = st {stateQueue = foldl' (\o k -> snd $ OrdPSQ.alter f k o) (stateQueue st) modNms}
  where
    f Nothing = ((), Nothing)
    f (Just (p, v)) = ((), Just (p-1,v))

initialState :: Int -> WeighedGraph -> State
initialState size wg =
  State
    { stateQueue = initialQueue
    , stateActive = OrdPSQ.empty
    , stateTime = 0
    , stateGaps = S.fromList [0..size-1]
    , stateOut = []
    }
  where
    initialQueue =
      OrdPSQ.fromList
      . map (\(k, simModInfo) -> (k, simNumDeps simModInfo, simModInfo))
      . M.toList
      $ createSimModInfo wg

simulate :: Int -> WeighedGraph -> [ModEvent]
simulate size wg = go (initialState size wg)
  where
    go st = case goSimulate st of
      Nothing -> stateOut st
      Just st' -> go st'


critPath :: WeighedGraph -> (WeighedNode -> Double) -> (Double, [(Double, ModName)])
critPath wg measure = maxFst . M.elems $ critPathGraph
  where
    maxFst [] = (0, [])
    maxFst xs = maximumBy (compare `on` fst) xs
    critPathGraph = M.mapWithKey critPathFrom wg
    lookupCrit key = M.lookup key critPathGraph
    critPathFrom nodeName node = (measure node + restMeasure, (measure node, nodeName):restPath)
      where
       (restMeasure, restPath) = maxFst . mapMaybe lookupCrit $ nodeDeps node