Advertisement
Guest User

Untitled

a guest
Aug 17th, 2017
60
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 5.13 KB | None | 0 0
  1. diff --git a/ghc-events.cabal b/ghc-events.cabal
  2. index 7fc2c1c..ece7861 100644
  3. --- a/ghc-events.cabal
  4. +++ b/ghc-events.cabal
  5. @@ -63,6 +63,8 @@ library
  6. binary >= 0.7 && < 0.10,
  7. bytestring >= 0.10.4,
  8. array >= 0.2 && < 0.6,
  9. + filepath >= 1.4.1.1,
  10. + temporary >= 1.2.0.4,
  11. text >= 0.11.2.3 && < 1.3,
  12. vector >= 0.7 && < 0.13
  13. exposed-modules: GHC.RTS.Events,
  14. diff --git a/src/GHC/RTS/Events.hs b/src/GHC/RTS/Events.hs
  15. index e5c3736..9495d06 100644
  16. --- a/src/GHC/RTS/Events.hs
  17. +++ b/src/GHC/RTS/Events.hs
  18. @@ -44,7 +44,7 @@ module GHC.RTS.Events (
  19. serialiseEventLog,
  20.  
  21. -- * Utilities
  22. - CapEvent(..), sortEvents,
  23. + CapEvent(..), sortEvents, sortEventLog,
  24. buildEventTypeMap,
  25.  
  26. -- * Printing
  27. @@ -67,8 +67,10 @@ module GHC.RTS.Events (
  28. {- Libraries. -}
  29. import Control.Applicative
  30. import Control.Concurrent hiding (ThreadId)
  31. +import Control.Monad (forM, forM_)
  32. import qualified Data.Binary.Put as P
  33. import qualified Data.ByteString as B
  34. +import qualified Data.ByteString.Builder as Builder
  35. import qualified Data.ByteString.Lazy as BL
  36. import Data.IntMap (IntMap)
  37. import qualified Data.IntMap as IM
  38. @@ -84,7 +86,9 @@ import qualified Data.Text.Lazy.Builder.Int as TB
  39. import qualified Data.Text.Lazy.IO as TL
  40. import qualified Data.Vector.Unboxed as VU
  41. import Data.Word
  42. +import System.FilePath ((</>))
  43. import System.IO
  44. +import System.IO.Temp (withSystemTempDirectory)
  45. import Prelude hiding (gcd, rem, id)
  46.  
  47. import GHC.RTS.EventTypes
  48. @@ -179,6 +183,64 @@ addBlockMarker cap evts =
  49.  
  50. -- -----------------------------------------------------------------------------
  51. -- Utilities
  52. +
  53. +-- | @sortEventLog eventLog f@ sorts the events in @eventLog@
  54. +-- and passes them to @f@. This function runs in bounded memory.
  55. +--
  56. +-- The events are sent to different temporary files, each file has the events
  57. +-- corresponding to a given capability. Then @f@ is given the result of
  58. +-- merging the files.
  59. +--
  60. +-- @f@ must not use the sorted events after it completes as the temporary
  61. +-- files are removed and the list of events is produced lazily.
  62. +sortEventLog :: EventLog -> ([Event] -> IO a) -> IO a
  63. +sortEventLog eLog f =
  64. + withSystemTempDirectory "ghc-events" $ \dir -> do
  65. + m <- splitEvents dir IM.empty (events $ dat eLog)
  66. + forM_ m $ \h ->
  67. + BL.hPut h (P.runPut putEVENT_DATA_END) >> hClose h
  68. + mergeEvents dir (IM.size m) >>= f
  69. + where
  70. + capFile :: FilePath -> Int -> FilePath
  71. + capFile dir capId = dir </> (show capId ++ ".eventlog")
  72. +
  73. + splitEvents :: FilePath -> IM.IntMap Handle -> [Event]
  74. + -> IO (IM.IntMap Handle)
  75. + splitEvents dir m [] = return m
  76. + splitEvents dir m evs@(e : _) =
  77. + let evCapId = maybe 0 (+1) . evCap
  78. + capId = evCapId e
  79. + in case IM.lookup capId m of
  80. + -- Create the temporary capability file.
  81. + Nothing -> do
  82. + h <- openBinaryFile (capFile dir capId) WriteMode
  83. + hSetBuffering h (BlockBuffering Nothing)
  84. + BL.hPut h $ P.runPut $
  85. + putHeader (header eLog) >> putEVENT_DATA_BEGIN
  86. + splitEvents dir (IM.insert capId h m) evs
  87. + -- Send the events to the capability file.
  88. + Just h ->
  89. + let (capEvents, rest) = span ((capId ==) . evCapId) evs
  90. + in do BL.hPut h $ mconcat $
  91. + map (P.runPut . putEvent) capEvents
  92. + splitEvents dir m rest
  93. +
  94. + mergeEvents :: FilePath -> Int -> IO [Event]
  95. + mergeEvents dir n = do
  96. + ees <- forM [0..n - 1] $ readEventLogFromFile . capFile dir
  97. + evss <- mapM (either error (return . events . dat)) ees
  98. + let mergeAll [] = []
  99. + mergeAll [xs] = xs
  100. + mergeAll xs = mergeAll (mergePairs xs)
  101. + mergePairs (x : y : xss) = merge x y : mergePairs xss
  102. + mergePairs xs = xs
  103. + merge (x : xs) (y : ys) =
  104. + if evTime x <= evTime y then x : y : merge xs ys
  105. + else y : x : merge xs ys
  106. + merge [] ys = ys
  107. + merge xs [] = xs
  108. + return (mergeAll evss)
  109. +
  110. sortEvents :: [Event] -> [Event]
  111. sortEvents = sortBy (compare `on` evTime)
  112.  
  113. diff --git a/src/GHC/RTS/Events/Binary.hs b/src/GHC/RTS/Events/Binary.hs
  114. index 39f707a..7ce8b07 100644
  115. --- a/src/GHC/RTS/Events/Binary.hs
  116. +++ b/src/GHC/RTS/Events/Binary.hs
  117. @@ -18,6 +18,8 @@ module GHC.RTS.Events.Binary
  118. , putEventLog
  119. , putHeader
  120. , putEvent
  121. + , putEVENT_DATA_BEGIN
  122. + , putEVENT_DATA_END
  123.  
  124. -- * Perf events
  125. , nEVENT_PERF_NAME
  126. @@ -850,11 +852,19 @@ putHeader (Header ets) = do
  127. putE (0 :: Word32)
  128. putMarker EVENT_ET_END
  129.  
  130. +putEVENT_DATA_BEGIN :: PutM ()
  131. +putEVENT_DATA_BEGIN =
  132. + putMarker EVENT_DATA_BEGIN -- Word32
  133. +
  134. +putEVENT_DATA_END :: PutM ()
  135. +putEVENT_DATA_END =
  136. + putMarker EVENT_DATA_END -- Word16
  137. +
  138. putData :: Data -> PutM ()
  139. putData (Data es) = do
  140. - putMarker EVENT_DATA_BEGIN -- Word32
  141. + putEVENT_DATA_BEGIN -- Word32
  142. mapM_ putEvent es
  143. - putType EVENT_DATA_END -- Word16
  144. + putEVENT_DATA_END -- Word16
  145.  
  146. eventTypeNum :: EventInfo -> EventTypeNum
  147. eventTypeNum e = case e of
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement