~kvakil/v8profile-to-pprof

ref: 2573c1d9 v8profile-to-pprof/src/Main.hs -rw-r--r-- 8.1 KiB
2573c1d9 — Keyhan Vakil Add link to binary artifact a month ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
{- v8profile-to-pprof: converts V8 CPU profiles to pprof.
 - Copyright (C) 2022 Keyhan Vakil
 -
 - This program is free software: you can redistribute it and/or modify
 - it under the terms of the GNU General Public License as published by
 - the Free Software Foundation, either version 3 of the License, or
 - (at your option) any later version.
 -
 - This program is distributed in the hope that it will be useful,
 - but WITHOUT ANY WARRANTY; without even the implied warranty of
 - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 - GNU General Public License for more details.
 -
 - You should have received a copy of the GNU General Public License
 - along with this program.  If not, see <https://www.gnu.org/licenses/>.
 -}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module Main where

import Control.Arrow ((&&&), (>>>))
import Control.Lens
import Control.Monad.State.Strict
import Data.Aeson (FromJSON, eitherDecode)
import Data.Bifunctor (first)
import Data.ByteString (putStr)
import Data.ByteString.Lazy (getContents)
import Data.Int (Int64)
import Data.List (sortBy)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.ProtoLens (defMessage, encodeMessage)
import Data.Text (Text)
import qualified Data.Vector as V
import GHC.Generics
import Proto.Profile as P
import Proto.Profile_Fields as P
import System.IO (hPutStrLn, stderr)

type StringTable = M.Map Text Int64

data CallFrame = CallFrame
  { functionName :: Text,
    scriptId :: Text,
    url :: Text,
    lineNumber :: Int,
    columnNumber :: Int
  }
  deriving (Show, Generic, Eq, Ord)

type FunctionTable = M.Map CallFrame Int64

type ParentNodeMap = M.Map Int64 Int64

data V8Profile = V8Profile
  { nodes :: V.Vector ProfileNode,
    startTime :: Int,
    endTime :: Int,
    samples :: V.Vector Int64,
    timeDeltas :: V.Vector Int64
  }
  deriving (Generic)

data PositionTick = PositionTick
  { line :: Int,
    ticks :: Int
  }
  deriving (Show, Generic)

data ProfileNode = ProfileNode
  { id :: Int64,
    callFrame :: CallFrame,
    hitCount :: Int,
    children :: Maybe (V.Vector Int64),
    positionTicks :: Maybe (V.Vector PositionTick)
  }
  deriving (Generic)

data PprofState = PprofState
  { _internStringTable :: StringTable,
    _internFunctionTable :: FunctionTable,
    _parentNodes :: ParentNodeMap,
    _nodesById :: M.Map Int64 ProfileNode,
    _previousStack :: V.Vector Int64
  }

makeLenses ''PprofState

instance FromJSON V8Profile

instance FromJSON PositionTick

instance FromJSON ProfileNode

instance FromJSON CallFrame

intern :: Ord a => a -> State (M.Map a Int64) Int64
intern k = do
  m <- get
  case k `M.lookup` m of
    Just id -> return id
    Nothing -> do
      let nextId = fromIntegral $ M.size m
      modify $ M.insert k nextId
      return nextId

populateParentMap :: ProfileNode -> State ParentNodeMap ()
populateParentMap ProfileNode {id = nid, children} =
  forM_ (fromMaybe [] children) $ modify . (`M.insert` nid)

processNode :: ProfileNode -> State PprofState ()
processNode node@ProfileNode {id = nid, callFrame} =
  zoom internFunctionTable (intern callFrame) >> (nodesById %= M.insert nid node)

aggregateGroups :: Eq b => (a -> b) -> (V.Vector a -> c) -> V.Vector a -> V.Vector c
aggregateGroups key agg =
  V.unfoldr $ \xs -> (xs V.!? 0) <&> (\x -> first agg $ V.span (equalKeys x) xs)
  where
    equalKeys a b = key a == key b

weightSamples :: V.Vector (Int64, Int64) -> V.Vector (Int, Int64, Int64)
weightSamples =
  aggregateGroups fst $ liftM3 (,,) V.length (fst . V.head) (V.sum . V.map snd)

iterateMaybe :: (a -> Maybe a) -> a -> V.Vector a
iterateMaybe = V.unfoldr . (fmap (join (,)) .)

getCallStack :: Int64 -> ParentNodeMap -> V.Vector Int64
getCallStack nid parentNodes =
  V.cons nid $ iterateMaybe ((`M.lookup` parentNodes) . fromIntegral) nid

shouldPlaceOnPreviousStack :: ProfileNode -> Bool
shouldPlaceOnPreviousStack ProfileNode {callFrame = CallFrame {functionName}} =
  functionName == "(garbage collector)" || functionName == "(program)"

addSamples :: V.Vector (Int64, Int64) -> P.Profile -> State PprofState P.Profile
addSamples nodeIdsAndWeights p = do
  nodesById <- use nodesById
  parentNodes <- use parentNodes
  let weightedSamples = weightSamples nodeIdsAndWeights
  samples :: V.Vector P.Sample <-
    forM weightedSamples $ \(nsamples, nid, totalDuration) -> do
      previousStack' <- use previousStack
      let node = nodesById M.! nid
          placeOnPrevious = shouldPlaceOnPreviousStack node
          locations = getCallStack nid parentNodes
          locations' = if placeOnPrevious then V.cons nid previousStack' else locations

      previousStack .= locations

      return $
        defMessage
          & P.locationId .~ V.toList (V.map fromIntegral locations')
          & P.value .~ [fromIntegral nsamples, totalDuration]
  return $ p & P.vec'sample .~ samples

toOneIndexed :: (Integral a, Num b) => a -> b
toOneIndexed = fromIntegral . succ

addLocationTable :: P.Profile -> State PprofState P.Profile
addLocationTable p = do
  nodesById <- gets $ view nodesById >>> M.toList
  locationTable <- forM nodesById $ \(_, ProfileNode {id = nid, callFrame}) -> do
    let CallFrame {lineNumber} = callFrame
    functionIndex <- zoom internFunctionTable $ intern callFrame
    return $
      defMessage
        & P.id .~ fromIntegral nid
        & P.line
          .~ [ defMessage
                 & P.functionId .~ toOneIndexed functionIndex
                 & P.line .~ toOneIndexed lineNumber
             ]
  return $ p & P.location .~ locationTable

addFunctionTable :: P.Profile -> State PprofState P.Profile
addFunctionTable p = do
  callFramesWithIds <- gets $ view internFunctionTable >>> M.toList >>> sortBy (comparing snd)
  functionTable <- forM callFramesWithIds
    $ \(CallFrame {functionName, url, lineNumber}, functionIndex) -> do
      functionName <- zoom internStringTable $ intern functionName
      url <- zoom internStringTable $ intern url
      return $
        defMessage
          & P.id .~ toOneIndexed functionIndex
          & P.name .~ functionName
          & P.systemName .~ functionName
          & P.filename .~ url
          & P.startLine .~ toOneIndexed lineNumber
  return $ p & P.function .~ functionTable

addStringTable :: P.Profile -> State PprofState P.Profile
addStringTable p = do
  table <- gets $ view internStringTable >>> M.toList >>> sortBy (comparing snd) >>> map fst
  return $ p & P.stringTable .~ table

addSampleTypes :: P.Profile -> State PprofState P.Profile
addSampleTypes p = do
  s0 <- createSampleType "sample" "count"
  s1 <- createSampleType "wall" "microseconds"
  return $ p & P.sampleType .~ [s0, s1]
  where
    createSampleType :: Text -> Text -> State PprofState P.ValueType
    createSampleType type' unit = do
      type' <- zoom internStringTable $ intern type'
      unit <- zoom internStringTable $ intern unit
      return $ defMessage & P.type' .~ type' & P.unit .~ unit

convertProfile :: V8Profile -> State PprofState P.Profile
convertProfile v8profile = do
  forM_ (nodes v8profile) $
    liftM2 (>>) (zoom parentNodes . populateParentMap) processNode
  pure defMessage
    >>= addSamples (uncurry V.zip $ (samples &&& timeDeltas) v8profile)
    >>= addSampleTypes
    >>= addLocationTable
    >>= addFunctionTable
    >>= addStringTable

initialStringTable :: StringTable
initialStringTable = M.fromList [("", 0)]

main :: IO ()
main = do
  let pprofState =
        PprofState
          { _internStringTable = initialStringTable,
            _internFunctionTable = M.empty,
            _parentNodes = [],
            _nodesById = [],
            _previousStack = []
          }
  contents <- Data.ByteString.Lazy.getContents
  case eitherDecode contents of
    Right profile ->
      Data.ByteString.putStr . encodeMessage $ evalState (convertProfile profile) pprofState
    Left error ->
      hPutStrLn stderr error