Coverage report: /home/ellis/comp/core/lib/rt/flamegraph.lisp

KindCoveredAll%
expression131158 82.9
branch46 66.7
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; flamegraph.lisp --- Flamegraph utils
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :rt/flamegraph)
7
 (defparameter *frame-where-profiling-was-started* nil)
8
 
9
 (defmacro with-open-file* ((stream filespec &key direction element-type
10
                                    if-exists if-does-not-exist external-format)
11
                            &body body)
12
   "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments
13
 mean to use the default value specified for OPEN."
14
   (once-only (direction element-type if-exists if-does-not-exist external-format)
15
     `(with-open-stream
16
          (,stream (apply #'open ,filespec
17
                          (append
18
                           (when ,direction
19
                             (list :direction ,direction))
20
                           (list :element-type ,(or element-type '(unsigned-byte 8)))
21
                           (when ,if-exists
22
                             (list :if-exists ,if-exists))
23
                           (when ,if-does-not-exist
24
                             (list :if-does-not-exist ,if-does-not-exist))
25
                           (when ,external-format
26
                             (list :external-format ,external-format)))))
27
        ,@body)))
28
 
29
 (defmacro with-output-to-file ((stream-name file-name &rest args
30
                                             &key (direction nil direction-p)
31
                                             &allow-other-keys)
32
                                &body body)
33
   "Evaluate BODY with STREAM-NAME to an output stream on the file
34
 FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
35
 which is only sent to WITH-OPEN-FILE when it's not NIL."
36
   (declare (ignore direction))
37
   (when direction-p
38
     (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
39
   `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
40
      ,@body))
41
 
42
 (defclass flamegraph-node ()
43
   ((func :initarg :func
44
          :initform nil
45
          :type (or string
46
                    sb-di::compiled-debug-fun
47
                    null)
48
          :accessor get-func)
49
    (counter :initform 0
50
             :type fixnum
51
             :initarg :counter
52
             :accessor get-counter)
53
    (calls :initform nil
54
           :type list
55
           :initarg :calls
56
           :documentation "A list of other nodes, called by current one"
57
           :accessor get-calls)))
58
 
59
 (defmethod print-object ((node flamegraph-node) stream)
60
   (print-unreadable-object (node stream :type t)
61
     (format stream "~A :calls ~A"
62
             (or (get-func node)
63
                 "<root>")
64
             (get-counter node))))
65
 
66
 (defun search-or-add-child (node func)
67
   ;; Not all frames contain an info for some reason.
68
   ;; We only want to show  meaningfull nodes
69
   (when func
70
     (let* ((children (get-calls node))
71
            (child (find func children
72
                         :test #'equal
73
                         :key #'get-func)))
74
       (unless child
75
         (setf child (make-instance 'flamegraph-node :func func))
76
         (push child (get-calls node)))
77
       child)))
78
 
79
 (defmethod name ((obj flamegraph-node))
80
   (name (get-func obj)))
81
 
82
 (defmethod name ((obj string))
83
   obj)
84
 
85
 (defmethod name ((obj sb-di::compiled-debug-fun))
86
   (name (slot-value obj 'SB-DI::COMPILER-DEBUG-FUN)))
87
 
88
 (defmethod name ((obj SB-C::COMPILED-DEBUG-FUN))
89
   (name (slot-value obj 'SB-C::NAME)))
90
 
91
 (defmethod name ((obj cons))
92
   (let ((*print-pretty* nil))
93
     (format nil "~S" obj)))
94
 
95
 (defmethod name ((obj symbol))
96
   (symbol-name obj))
97
 
98
 (defmethod name ((obj sb-kernel:code-component))
99
   "Some binary code")
100
 
101
 (defun aggregate-raw-data ()
102
   ;; We need to actually run a report once to make the call graph
103
   ;; available to map.
104
   (sb-sprof:report :stream (make-broadcast-stream)))
105
 
106
 (defun make-graph ()
107
   (aggregate-raw-data)
108
   (let ((root (make-instance 'flamegraph-node)))
109
     (sb-sprof:map-traces
110
      (lambda (thread trace)
111
        (declare (ignorable thread))
112
        (let ((current-node root))
113
          (sb-sprof::map-trace-pc-locs
114
           (lambda (info pc-or-offset)
115
             (declare (ignorable pc-or-offset))
116
             (let ((node (search-or-add-child current-node
117
                                              info)))
118
               (when node
119
                 (incf (get-counter node))
120
                 (setf current-node
121
                       node))))
122
           trace)))
123
      sb-sprof::*samples*)
124
     root))
125
 
126
 (defun remove-nodes-up-to-frame (nodes frame)
127
   (let ((func (slot-value frame 'sb-di::debug-fun)))
128
     (loop for rest on nodes
129
           for node = (car rest)
130
           when (eql (get-func node)
131
                     func)
132
             do (return (cdr rest)))))
133
 
134
 (defun print-graph (root &key (stream t) (max-depth most-positive-fixnum))
135
   (let* ((roots (get-calls root)))
136
     (labels ((print-path (path count)
137
                (let* ((nodes (reverse path))
138
                       (rest-nodes (remove-nodes-up-to-frame nodes
139
                                                             *frame-where-profiling-was-started*))
140
                       (names (mapcar #'name rest-nodes)))
141
                  (when names
142
                    (format stream "~{~A~^;~} ~A~%"
143
                            names
144
                            count))))
145
              (print-node (node &optional path (depth 0))
146
                (when (< depth max-depth)
147
                  (let* ((count (get-counter node))
148
                         (path (list* node path))
149
                         (children (get-calls node)))
150
                    (when (> count 0)
151
                      (print-path path count))
152
                    (loop for child in children
153
                          do (print-node child path (1+ depth)))))))
154
       (mapcar #'print-node
155
               roots)
156
       (values))))
157
 
158
 (defmacro with-flamegraph ((filename &rest sb-sprof-opts) &body body)
159
   (with-gensyms (result-var)
160
     `(let ((*frame-where-profiling-was-started*
161
              (sb-di:top-frame))
162
            (,result-var nil))
163
        (with-simple-restart (abort "Stop profiling and save graph")
164
          (sb-sprof:with-profiling (,@sb-sprof-opts)
165
            (setf ,result-var
166
                  (multiple-value-list
167
                   (progn ,@body)))))
168
        (with-output-to-file (s ,filename :if-exists :supersede)
169
          (print-graph (make-graph)
170
                       :stream s))
171
        (values-list ,result-var))))