Skip to content

Instantly share code, notes, and snippets.

@alienzhou

alienzhou/FlameGraphDiff.hs

Forked from gelisam/FlameGraphDiff.hs
Created April 3, 2021 14:43
Show Gist options
  • Save alienzhou/ca271557c01559a7f96b35156f293a1d to your computer and use it in GitHub Desktop.
Save alienzhou/ca271557c01559a7f96b35156f293a1d to your computer and use it in GitHub Desktop.
Download ZIP
a simple algorithm to diff two flame graphs
Raw
FlameGraphDiff.hs
-- in response to https://twitter.com/jfischoff/status/1228861734271647745
--
-- The challenge is to visualize the diff of two flame graphs. My idea is: we
-- need to draw both Trees in the same image, so we draw each node as the _sum_
-- of the two durations. The color of the node indicates whether the nodes above
-- it are slower or faster. Grey is "same speed", orange is "slower" (burns more
-- resources), and blue is "faster" (dousing the flames).
--
-- Note that I'm using a simple 'Tree' from the containers library, not whatever
-- is the real output from 'perf', so more work would be needed to make this
-- useful in practice.
--
-- Looking at "diff.png", you'll notice that:
--
-- 1. The bottom layer is barely orange, meaning that the two traces are about
-- the same duration.
-- 2. On the layer above, the left third is a bit more orange, meaning that this
-- is the part which got slowed down the most.
-- 3. That third ends with a bright orange blob, the source of our slowdown.
-- 4. That third is followed by a grey section with some blue and orange spikes
-- on top, meaning that there were some changes, but that they did not affect
-- the performance. There is an identical grey-with-spikes-on-top section at
-- the end.
-- 5. In between the two grey-with-spikes-on-top sections, there is a
-- barely-orange section with three components: a grey rectangle which didn't
-- change, a blue triangle which got faster, and an orange rectangle which
-- got slower, clearly because of the orange blob in its top-right.
--
-- Those features all correspond to intentional changes I made in the two
-- artificial traces I constructed before I wrote my visualization algorithm:
--
-- 1. I added both some slowdowns and some speedups, so it makes sense that they
-- about cancel out.
-- 2. That first third is the initialization phase, which indeed only contains
-- intentional slowdowns.
-- 3. That orange blob reveals the expensive new "reticulating splines" step I
-- added to make the initialization phase slower.
-- 4. Those sections correspond to the read and write portions of the program,
-- which I changed into a more detailed form but did not change their overall
-- performance, hence the grey.
-- 5. That second orange blob reveals that I have made the "postprocessing" step
-- a lot slower.
--
-- And more importantly, the diff does _not_ show a lot of noise everywhere else
-- despite the fact that I made small, non-significant tweaks to most of the
-- durations.
-- Built with the following stack.yaml configuration:
--
-- > resolver: lts-13.19
-- > packages:
-- > - .
-- > extra-deps:
-- > - git: git@gitlab.com:timo-a/gloss-export.git
-- > commit: 61f8413d43ee917a2c8ccf8cd601f3d1edc3c5f2
{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
module Main where
import Control.Monad.Trans.Writer
import Data.Function
import Data.List
import Data.Tree
import qualified Data.Algorithm.Diff as Diff
import qualified Graphics.Gloss as Gloss
import qualified Graphics.Gloss.Export.PNG as Gloss
-- A "flame graph" is a visualization for a tree whose nodes are labelled by a
-- function name and by the function's start and end time. For simplicity, I
-- only store the function name, and I compute the duration from the shape of
-- the tree, by assuming that each leaf lasts 1 unit of time.
type DurationTree = Tree String
duration :: DurationTree -> Int
duration (Node _ []) = 1
duration (Node _ ns) = sum . fmap duration $ ns
-- See "old.png" and "new.png" for example outputs. For simplicify, I don't draw
-- the function names.
flameGraph :: DurationTree -> ImageBlock
flameGraph (Node _ []) = rect 1 1
flameGraph (Node _ ns) = vappend bottom top
where
top = hcat . fmap flameGraph $ ns
bottom = rect (width top) 1
coloredFlameGraph :: Gloss.Color -> DurationTree -> ImageBlock
coloredFlameGraph c = color c . flameGraph
-- Similarly, our "flame graph diff" visualizes a tree diff, which is similar to
-- a list diff (e.g. the output of the "diff" CLI tool on two files), except
-- it's recursive. The diff relies on the function names, which is why I label
-- my internal nodes with 'String's even though I don't draw them.
type DurationDiff = TreeDiff String
-- See "diff.png" for an example output
flameGraphDiff :: [DurationDiff] -> ImageBlock
flameGraphDiff ns0 = hcat imgs0
where
(imgs0, _, _) = unzip3 . fmap go $ ns0
-- I include the old and new durations in the output in order to avoid
-- the quadratic behaviour of traversing each sub-tree at each node.
go :: DurationDiff
-> ( ImageBlock
, Int -- ^ old duration
, Int -- ^ new duration
)
go (First old) = (coloredFlameGraph fastColor old, duration old, 0)
go (Second new) = (coloredFlameGraph slowColor new, 0, duration new)
go (Both _ []) = (coloredRect neutralColor 2 1, 1, 1) -- double-width, to be
-- as wide as old + new
go (Both _ ns) = (vappend bottom top, old, new)
where
(imgs, olds, news) = unzip3 . fmap go $ ns
top = hcat imgs
old = sum olds
new = sum news
bottom = coloredRect (diffColor old new) (old + new) 1
-- diffColor 0 30 = slowColor
-- diffColor 45 0 = fastColor
-- diffColor 12 12 = neutralColor
diffColor :: Int -> Int -> Gloss.Color
diffColor old new | old < new = Gloss.mixColors oldF (newF - oldF) neutralColor slowColor
| old > new = Gloss.mixColors (oldF - newF) newF fastColor neutralColor
| otherwise = neutralColor
where
oldF = fromIntegral old
newF = fromIntegral new
fastColor :: Gloss.Color
fastColor = Gloss.light Gloss.blue
neutralColor :: Gloss.Color
neutralColor = Gloss.greyN 0.8
slowColor :: Gloss.Color
slowColor = Gloss.orange
------------------
-- Tree diffing --
------------------
-- I'll be using the 'Diff' package (intended for lists) rather than the
-- 'tree-diff' package (which supports both lists, trees and more) because
-- tree-diff sometimes deletes and re-inserts a sub-tree instead of keeping the
-- internal node and diffing the children (its diff representation is also
-- rather imprecise, e.g. the 'Ins', 'Del', and 'Swp' constructors always
-- contain a tree of 'Cpy' nodes, but that fact is not apparent in the type).
data TreeDiff a
= First (Tree a)
| Second (Tree a)
| Both a [TreeDiff a]
deriving Show
diffTrees :: Eq a
=> Tree a -> Tree a -> [TreeDiff a]
diffTrees n1@(Node a1 ns1) n2@(Node a2 ns2)
| a1 == a2 = [Both a1 $ diffTreeLists ns1 ns2]
| otherwise = [First n1, Second n2]
diffTreeLists :: forall a. Eq a
=> [Tree a] -> [Tree a] -> [TreeDiff a]
diffTreeLists ns1 ns2 = foldMap recur
$ Diff.getDiffBy ((==) `on` rootLabel) ns1 ns2
where
recur :: Diff.Diff (Tree a) -> [TreeDiff a]
recur (Diff.First t) = [First t]
recur (Diff.Second t) = [Second t]
recur (Diff.Both t1 t2) = diffTrees t1 t2
-------------------------------------------------
-- A tiny DSL for constructing 'DurationTree's --
-------------------------------------------------
type MkTree = Writer [DurationTree] ()
runMkTree :: MkTree -> DurationTree
runMkTree = Node "main" . execWriter
leaf :: String -> MkTree
leaf s = tell [Node s []]
time :: Int -> MkTree
time n = mapM_ (leaf . const "*") [1..n]
block :: String -> MkTree -> MkTree
block s body = tell [Node s (execWriter body)]
entry :: String -> Int -> MkTree
entry s n = block s (time n)
------------------------------------------------
-- The two 'DurationTree's we will be diffing --
------------------------------------------------
tree1 :: DurationTree
tree1 = runMkTree $ do
time 10
block "init" $ do
time 13
entry "migration" 100
time 12
entry "waiting for deps" 200
time 10
block "input" $ do
time 10
entry "read line" 22
time 11
entry "read line" 43
time 12
entry "read line" 35
time 13
block "transform" $ do
time 12
block "outer" $ do
block "intermediate" $ do
entry "inner" 101
time 11
block "bulk" $ do
time 14
block "nested" $ do
time 12
block "nested" $ do
time 12
block "nested" $ do
time 12
block "nested" $ do
time 12
block "nested" $ do
time 12
block "nested" $ do
time 12
block "nested" $ do
entry "base case" 11
time 13
block "final" $ do
time 15
entry "postprocessing" 102
time 12
block "output" $ do
time 11
entry "write line" 22
time 11
entry "write line" 23
time 12
entry "write line" 55
time 13
tree2 :: DurationTree
tree2 = runMkTree $ do
time 12
block "init" $ do
time 13
entry "migration" 102
time 11
entry "waiting for deps" 208
time 11
entry "reticulating splines" 120
time 13
block "input" $ do
time 11
block "read line" $ do
entry "read char" 10
entry "read char" 8
time 13
block "read line" $ do
entry "read char" 10
entry "read char" 10
entry "read char" 11
entry "read char" 10
time 11
block "read line" $ do
entry "read char" 9
entry "read char" 10
entry "read char" 10
time 11
block "transform" $ do
time 13
block "outer" $ do
block "intermediate" $ do
entry "inner" 102
time 11
block "bulk" $ do
time 14
block "nested" $ do
time 12
block "nested" $ do
time 12
block "nested" $ do
time 12
entry "base case" 1
time 12
block "final" $ do
time 13
entry "postprocessing" 211
time 11
block "output" $ do
time 12
block "write line" $ do
entry "write char" 11
entry "write char" 9
time 13
block "write line" $ do
entry "write char" 11
entry "write char" 10
time 11
block "write line" $ do
entry "write char" 10
entry "write char" 10
entry "write char" 9
entry "write char" 9
entry "write char" 11
time 11
----------------------------------------------------------
-- A less tiny DSL for 'Picture's which know their size --
----------------------------------------------------------
data ImageBlock = ImageBlock
{ picture :: !Gloss.Picture -- ^ extends from (0,0) to (width, height)
, width :: !Int
, height :: !Int
}
widthF :: ImageBlock -> Float
widthF = fromIntegral . width
heightF :: ImageBlock -> Float
heightF = fromIntegral . height
scaledTo :: (Int, Int) -> ImageBlock -> Gloss.Picture
scaledTo (targetW, targetH) img = pic
where
targetW' = fromIntegral targetW
targetH' = fromIntegral targetH
pic = Gloss.translate (-targetW' / 2) (-targetH' / 2)
. Gloss.scale (targetW' / widthF img) (targetH' / heightF img)
$ picture img
instance Semigroup ImageBlock where
ImageBlock pic1 w1 h1 <> ImageBlock pic2 w2 h2
= ImageBlock pic w h
where
pic = pic1 <> pic2
w = max w1 w2
h = max h1 h2
instance Monoid ImageBlock where
mempty = ImageBlock mempty 0 0
shiftRight :: Int -> ImageBlock -> ImageBlock
shiftRight dx img = ImageBlock pic w h
where
pic = Gloss.translate (fromIntegral dx) 0
$ picture img
w = dx + width img
h = height img
shiftUp :: Int -> ImageBlock -> ImageBlock
shiftUp dy img = ImageBlock pic w h
where
pic = Gloss.translate 0 (fromIntegral dy)
$ picture img
w = width img
h = dy + height img
color :: Gloss.Color -> ImageBlock -> ImageBlock
color c img = img { picture = Gloss.color c (picture img) }
rect :: Int -> Int -> ImageBlock
rect w h = ImageBlock pic w h
where
w' = fromIntegral w
h' = fromIntegral h
pic = Gloss.translate (w' / 2) (h' / 2)
$ Gloss.rectangleSolid w' h'
coloredRect :: Gloss.Color -> Int -> Int -> ImageBlock
coloredRect c w h = color c $ rect w h
happend :: ImageBlock -> ImageBlock -> ImageBlock
happend img1 img2 = img1 <> shiftRight (width img1) img2
vappend :: ImageBlock -> ImageBlock -> ImageBlock
vappend img1 img2 = img1 <> shiftUp (height img1) img2
-- With @foldr happend mempty@, Gloss runs out of transformation matrix stack,
-- because of the nested 'Gloss.translate' calls.
hcat :: [ImageBlock] -> ImageBlock
hcat = foldl' happend mempty
-------------------------
-- Generate the images --
-------------------------
size :: (Int, Int)
size = (300, 300)
exportImageBlock :: FilePath -> ImageBlock -> IO ()
exportImageBlock filePath img = do
putStrLn $ "Generating " <> filePath <> "..."
Gloss.exportPictureToPNG size Gloss.white filePath (scaledTo size img)
main :: IO ()
main = do
exportImageBlock "old.png" $ coloredFlameGraph neutralColor tree1
exportImageBlock "new.png" $ coloredFlameGraph neutralColor tree2
exportImageBlock "diff.png" $ flameGraphDiff $ diffTrees tree1 tree2
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment