module/statprof.scm

   1 ;;;; (statprof) -- a statistical profiler for Guile
   2 ;;;; -*-scheme-*-
   3 ;;;;
   4 ;;;;    Copyright (C) 2009, 2010, 2011, 2013, 2014  Free Software Foundation, Inc.
   5 ;;;;    Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
   6 ;;;;    Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
   7 ;;;;
   8 ;;;; This library is free software; you can redistribute it and/or
   9 ;;;; modify it under the terms of the GNU Lesser General Public
  10 ;;;; License as published by the Free Software Foundation; either
  11 ;;;; version 3 of the License, or (at your option) any later version.
  12 ;;;;
  13 ;;;; This library is distributed in the hope that it will be useful,
  14 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 ;;;; Lesser General Public License for more details.
  17 ;;;;
  18 ;;;; You should have received a copy of the GNU Lesser General Public
  19 ;;;; License along with this library; if not, write to the Free Software
  20 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  21 ;;;;
  22 \f
  23
  24 ;;; Commentary:
  25 ;;;
  26 ;;; @code{(statprof)} is intended to be a fairly simple
  27 ;;; statistical profiler for guile. It is in the early stages yet, so
  28 ;;; consider its output still suspect, and please report any bugs to
  29 ;;; @email{guile-devel at gnu.org}, or to me directly at @email{rlb at
  30 ;;; defaultvalue.org}.
  31 ;;;
  32 ;;; A simple use of statprof would look like this:
  33 ;;;
  34 ;;; @example
  35 ;;;   (statprof-reset 0 50000 #t)
  36 ;;;   (statprof-start)
  37 ;;;   (do-something)
  38 ;;;   (statprof-stop)
  39 ;;;   (statprof-display)
  40 ;;; @end example
  41 ;;;
  42 ;;; This would reset statprof, clearing all accumulated statistics, then
  43 ;;; start profiling, run some code, stop profiling, and finally display a
  44 ;;; gprof flat-style table of statistics which will look something like
  45 ;;; this:
  46 ;;;
  47 ;;; @example
  48 ;;;   %   cumulative      self              self    total
  49 ;;;  time    seconds   seconds    calls  ms/call  ms/call  name
  50 ;;;  35.29      0.23      0.23     2002     0.11     0.11  -
  51 ;;;  23.53      0.15      0.15     2001     0.08     0.08  positive?
  52 ;;;  23.53      0.15      0.15     2000     0.08     0.08  +
  53 ;;;  11.76      0.23      0.08     2000     0.04     0.11  do-nothing
  54 ;;;   5.88      0.64      0.04     2001     0.02     0.32  loop
  55 ;;;   0.00      0.15      0.00        1     0.00   150.59  do-something
  56 ;;;  ...
  57 ;;; @end example
  58 ;;;
  59 ;;; All of the numerical data with the exception of the calls column is
  60 ;;; statistically approximate. In the following column descriptions, and
  61 ;;; in all of statprof, "time" refers to execution time (both user and
  62 ;;; system), not wall clock time.
  63 ;;;
  64 ;;; @table @asis
  65 ;;; @item % time
  66 ;;; The percent of the time spent inside the procedure itself
  67 ;;; (not counting children).
  68 ;;; @item cumulative seconds
  69 ;;; The total number of seconds spent in the procedure, including
  70 ;;; children.
  71 ;;; @item self seconds
  72 ;;; The total number of seconds spent in the procedure itself (not counting
  73 ;;; children).
  74 ;;; @item calls
  75 ;;; The total number of times the procedure was called.
  76 ;;; @item self ms/call
  77 ;;; The average time taken by the procedure itself on each call, in ms.
  78 ;;; @item total ms/call
  79 ;;; The average time taken by each call to the procedure, including time
  80 ;;; spent in child functions.
  81 ;;; @item name
  82 ;;; The name of the procedure.
  83 ;;; @end table
  84 ;;;
  85 ;;; The profiler uses @code{eq?} and the procedure object itself to
  86 ;;; identify the procedures, so it won't confuse different procedures with
  87 ;;; the same name. They will show up as two different rows in the output.
  88 ;;;
  89 ;;; Right now the profiler is quite simplistic.  I cannot provide
  90 ;;; call-graphs or other higher level information.  What you see in the
  91 ;;; table is pretty much all there is. Patches are welcome :-)
  92 ;;;
  93 ;;; @section Implementation notes
  94 ;;;
  95 ;;; The profiler works by setting the unix profiling signal
  96 ;;; @code{ITIMER_PROF} to go off after the interval you define in the call
  97 ;;; to @code{statprof-reset}. When the signal fires, a sampling routine is
  98 ;;; run which looks at the current procedure that's executing, and then
  99 ;;; crawls up the stack, and for each procedure encountered, increments
 100 ;;; that procedure's sample count. Note that if a procedure is encountered
 101 ;;; multiple times on a given stack, it is only counted once. After the
 102 ;;; sampling is complete, the profiler resets profiling timer to fire
 103 ;;; again after the appropriate interval.
 104 ;;;
 105 ;;; Meanwhile, the profiler keeps track, via @code{get-internal-run-time},
 106 ;;; how much CPU time (system and user -- which is also what
 107 ;;; @code{ITIMER_PROF} tracks), has elapsed while code has been executing
 108 ;;; within a statprof-start/stop block.
 109 ;;;
 110 ;;; The profiler also tries to avoid counting or timing its own code as
 111 ;;; much as possible.
 112 ;;;
 113 ;;; Code:
 114
 115 (define-module (statprof)
 116   #:use-module (srfi srfi-1)
 117   #:autoload   (ice-9 format) (format)
 118   #:use-module (system vm vm)
 119   #:use-module (system vm frame)
 120   #:use-module (system vm program)
 121   #:export (statprof-active?
 122             statprof-start
 123             statprof-stop
 124             statprof-reset
 125
 126             statprof-accumulated-time
 127             statprof-sample-count
 128             statprof-fold-call-data
 129             statprof-proc-call-data
 130             statprof-call-data-name
 131             statprof-call-data-calls
 132             statprof-call-data-cum-samples
 133             statprof-call-data-self-samples
 134             statprof-call-data->stats
 135
 136             statprof-stats-proc-name
 137             statprof-stats-%-time-in-proc
 138             statprof-stats-cum-secs-in-proc
 139             statprof-stats-self-secs-in-proc
 140             statprof-stats-calls
 141             statprof-stats-self-secs-per-call
 142             statprof-stats-cum-secs-per-call
 143
 144             statprof-display
 145             statprof-display-anomolies
 146
 147             statprof-fetch-stacks
 148             statprof-fetch-call-tree
 149
 150             statprof
 151             with-statprof
 152
 153             gcprof))
 154
 155
 156 ;; This profiler tracks two numbers for every function called while
 157 ;; it's active.  It tracks the total number of calls, and the number
 158 ;; of times the function was active when the sampler fired.
 159 ;;
 160 ;; Globally the profiler tracks the total time elapsed and the number
 161 ;; of times the sampler was fired.
 162 ;;
 163 ;; Right now, this profiler is not per-thread and is not thread safe.
 164
 165 (define accumulated-time #f)            ; total so far.
 166 (define last-start-time #f)             ; start-time when timer is active.
 167 (define sample-count #f)                ; total count of sampler calls.
 168 (define sampling-frequency #f)          ; in (seconds . microseconds)
 169 (define remaining-prof-time #f)         ; time remaining when prof suspended.
 170 (define profile-level 0)                ; for user start/stop nesting.
 171 (define %count-calls? #t)               ; whether to catch apply-frame.
 172 (define gc-time-taken 0)                ; gc time between statprof-start and
 173                                         ; statprof-stop.
 174 (define record-full-stacks? #f)         ; if #t, stash away the stacks
 175                                         ; for later analysis.
 176 (define stacks '())
 177
 178 ;; procedure-data will be a hash where the key is the function object
 179 ;; itself and the value is the data. The data will be a vector like
 180 ;; this: #(name call-count cum-sample-count self-sample-count)
 181 (define procedure-data #f)
 182
 183 ;; If you change the call-data data structure, you need to also change
 184 ;; sample-uncount-frame.
 185 (define (make-call-data proc call-count cum-sample-count self-sample-count)
 186   (vector proc call-count cum-sample-count self-sample-count))
 187 (define (call-data-proc cd) (vector-ref cd 0))
 188 (define (call-data-name cd) (procedure-name (call-data-proc cd)))
 189 (define (call-data-printable cd)
 190   (or (call-data-name cd)
 191       (with-output-to-string (lambda () (write (call-data-proc cd))))))
 192 (define (call-data-call-count cd) (vector-ref cd 1))
 193 (define (call-data-cum-sample-count cd) (vector-ref cd 2))
 194 (define (call-data-self-sample-count cd) (vector-ref cd 3))
 195
 196 (define (inc-call-data-call-count! cd)
 197   (vector-set! cd 1 (1+ (vector-ref cd 1))))
 198 (define (inc-call-data-cum-sample-count! cd)
 199   (vector-set! cd 2 (1+ (vector-ref cd 2))))
 200 (define (inc-call-data-self-sample-count! cd)
 201   (vector-set! cd 3 (1+ (vector-ref cd 3))))
 202
 203 (define-macro (accumulate-time stop-time)
 204   `(set! accumulated-time
 205          (+ accumulated-time 0.0 (- ,stop-time last-start-time))))
 206
 207 (define (get-call-data proc)
 208   (let ((k (cond
 209             ((program? proc) (program-code proc))
 210             (else proc))))
 211     (or (hashv-ref procedure-data k)
 212         (let ((call-data (make-call-data proc 0 0 0)))
 213           (hashv-set! procedure-data k call-data)
 214           call-data))))
 215
 216 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 217 ;; SIGPROF handler
 218
 219 (define (sample-stack-procs stack)
 220   (let ((stacklen (stack-length stack))
 221         (hit-count-call? #f))
 222
 223     (if record-full-stacks?
 224         (set! stacks (cons stack stacks)))
 225
 226     (set! sample-count (+ sample-count 1))
 227     ;; Now accumulate stats for the whole stack.
 228     (let loop ((frame (stack-ref stack 0))
 229                (procs-seen (make-hash-table 13))
 230                (self #f))
 231       (cond
 232        ((not frame)
 233         (hash-fold
 234          (lambda (proc val accum)
 235            (inc-call-data-cum-sample-count!
 236             (get-call-data proc)))
 237          #f
 238          procs-seen)
 239         (and=> (and=> self get-call-data)
 240                inc-call-data-self-sample-count!))
 241        ((frame-procedure frame)
 242         => (lambda (proc)
 243              (cond
 244               ((eq? proc count-call)
 245                ;; We're not supposed to be sampling count-call and
 246                ;; its sub-functions, so loop again with a clean
 247                ;; slate.
 248                (set! hit-count-call? #t)
 249                (loop (frame-previous frame) (make-hash-table 13) #f))
 250               (else
 251                (hashq-set! procs-seen proc #t)
 252                (loop (frame-previous frame)
 253                      procs-seen
 254                      (or self proc))))))
 255        (else
 256         (loop (frame-previous frame) procs-seen self))))
 257     hit-count-call?))
 258
 259 (define inside-profiler? #f)
 260
 261 (define (profile-signal-handler sig)
 262   (set! inside-profiler? #t)
 263
 264   ;; FIXME: with-statprof should be able to set an outer frame for the
 265   ;; stack cut
 266   (if (positive? profile-level)
 267       (let* ((stop-time (get-internal-run-time))
 268              ;; cut down to the signal handler. note that this will only
 269              ;; work if statprof.scm is compiled; otherwise we get
 270              ;; `eval' on the stack instead, because if it's not
 271              ;; compiled, profile-signal-handler is a thunk that
 272              ;; tail-calls eval. perhaps we should always compile the
 273              ;; signal handler instead...
 274              (stack (or (make-stack #t profile-signal-handler)
 275                         (pk 'what! (make-stack #t))))
 276              (inside-apply-trap? (sample-stack-procs stack)))
 277
 278         (if (not inside-apply-trap?)
 279             (begin
 280               ;; disabling here is just a little more efficient, but
 281               ;; not necessary given inside-profiler?.  We can't just
 282               ;; disable unconditionally at the top of this function
 283               ;; and eliminate inside-profiler? because it seems to
 284               ;; confuse guile wrt re-enabling the trap when
 285               ;; count-call finishes.
 286               (if %count-calls?
 287                   (set-vm-trace-level! (1- (vm-trace-level))))
 288               (accumulate-time stop-time)))
 289
 290         (setitimer ITIMER_PROF
 291                    0 0
 292                    (car sampling-frequency)
 293                    (cdr sampling-frequency))
 294
 295         (if (not inside-apply-trap?)
 296             (begin
 297               (set! last-start-time (get-internal-run-time))
 298               (if %count-calls?
 299                   (set-vm-trace-level! (1+ (vm-trace-level))))))))
 300
 301   (set! inside-profiler? #f))
 302
 303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 304 ;; Count total calls.
 305
 306 (define (count-call frame)
 307   (if (not inside-profiler?)
 308       (begin
 309         (accumulate-time (get-internal-run-time))
 310
 311         (and=> (frame-procedure frame)
 312                (lambda (proc)
 313                  (inc-call-data-call-count!
 314                   (get-call-data proc))))
 315
 316         (set! last-start-time (get-internal-run-time)))))
 317
 318 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 319
 320 (define (statprof-active?)
 321   "Returns @code{#t} if @code{statprof-start} has been called more times
 322 than @code{statprof-stop}, @code{#f} otherwise."
 323   (positive? profile-level))
 324
 325 ;; Do not call this from statprof internal functions -- user only.
 326 (define (statprof-start)
 327   "Start the profiler.@code{}"
 328   ;; After some head-scratching, I don't *think* I need to mask/unmask
 329   ;; signals here, but if I'm wrong, please let me know.
 330   (set! profile-level (+ profile-level 1))
 331   (if (= profile-level 1)
 332       (let* ((rpt remaining-prof-time)
 333              (use-rpt? (and rpt
 334                             (or (positive? (car rpt))
 335                                 (positive? (cdr rpt))))))
 336         (set! remaining-prof-time #f)
 337         (set! last-start-time (get-internal-run-time))
 338         (set! gc-time-taken
 339               (cdr (assq 'gc-time-taken (gc-stats))))
 340         (if use-rpt?
 341             (setitimer ITIMER_PROF 0 0 (car rpt) (cdr rpt))
 342             (setitimer ITIMER_PROF
 343                        0 0
 344                        (car sampling-frequency)
 345                        (cdr sampling-frequency)))
 346         (if %count-calls?
 347             (add-hook! (vm-apply-hook) count-call))
 348         (set-vm-trace-level! (1+ (vm-trace-level)))
 349         #t)))
 350
 351 ;; Do not call this from statprof internal functions -- user only.
 352 (define (statprof-stop)
 353   "Stop the profiler.@code{}"
 354   ;; After some head-scratching, I don't *think* I need to mask/unmask
 355   ;; signals here, but if I'm wrong, please let me know.
 356   (set! profile-level (- profile-level 1))
 357   (if (zero? profile-level)
 358       (begin
 359         (set! gc-time-taken
 360               (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
 361         (set-vm-trace-level! (1- (vm-trace-level)))
 362         (if %count-calls?
 363             (remove-hook! (vm-apply-hook) count-call))
 364         ;; I believe that we need to do this before getting the time
 365         ;; (unless we want to make things even more complicated).
 366         (set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
 367         (accumulate-time (get-internal-run-time))
 368         (set! last-start-time #f))))
 369
 370 (define* (statprof-reset sample-seconds sample-microseconds count-calls?
 371                          #:optional full-stacks?)
 372   "Reset the statprof sampler interval to @var{sample-seconds} and
 373 @var{sample-microseconds}. If @var{count-calls?} is true, arrange to
 374 instrument procedure calls as well as collecting statistical profiling
 375 data. If @var{full-stacks?} is true, collect all sampled stacks into a
 376 list for later analysis.
 377
 378 Enables traps and debugging as necessary."
 379   (if (positive? profile-level)
 380       (error "Can't reset profiler while profiler is running."))
 381   (set! %count-calls? count-calls?)
 382   (set! accumulated-time 0)
 383   (set! last-start-time #f)
 384   (set! sample-count 0)
 385   (set! sampling-frequency (cons sample-seconds sample-microseconds))
 386   (set! remaining-prof-time #f)
 387   (set! procedure-data (make-hash-table 131))
 388   (set! record-full-stacks? full-stacks?)
 389   (set! stacks '())
 390   (sigaction SIGPROF profile-signal-handler)
 391   #t)
 392
 393 (define (statprof-fold-call-data proc init)
 394   "Fold @var{proc} over the call-data accumulated by statprof. Cannot be
 395 called while statprof is active. @var{proc} should take two arguments,
 396 @code{(@var{call-data} @var{prior-result})}.
 397
 398 Note that a given proc-name may appear multiple times, but if it does,
 399 it represents different functions with the same name."
 400   (if (positive? profile-level)
 401       (error "Can't call statprof-fold-called while profiler is running."))
 402
 403   (hash-fold
 404    (lambda (key value prior-result)
 405      (proc value prior-result))
 406    init
 407    procedure-data))
 408
 409 (define (statprof-proc-call-data proc)
 410   "Returns the call-data associated with @var{proc}, or @code{#f} if
 411 none is available."
 412   (if (positive? profile-level)
 413       (error "Can't call statprof-fold-called while profiler is running."))
 414
 415   (get-call-data proc))
 416
 417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 418 ;; Stats
 419
 420 (define (statprof-call-data->stats call-data)
 421   "Returns an object of type @code{statprof-stats}."
 422   ;; returns (vector proc-name
 423   ;;                 %-time-in-proc
 424   ;;                 cum-seconds-in-proc
 425   ;;                 self-seconds-in-proc
 426   ;;                 num-calls
 427   ;;                 self-secs-per-call
 428   ;;                 total-secs-per-call)
 429
 430   (let* ((proc-name (call-data-printable call-data))
 431          (self-samples (call-data-self-sample-count call-data))
 432          (cum-samples (call-data-cum-sample-count call-data))
 433          (all-samples (statprof-sample-count))
 434          (secs-per-sample (/ (statprof-accumulated-time)
 435                              (statprof-sample-count)))
 436          (num-calls (and %count-calls? (statprof-call-data-calls call-data))))
 437
 438     (vector proc-name
 439             (* (/ self-samples all-samples) 100.0)
 440             (* cum-samples secs-per-sample 1.0)
 441             (* self-samples secs-per-sample 1.0)
 442             num-calls
 443             (and num-calls ;; maybe we only sampled in children
 444                  (if (zero? self-samples) 0.0
 445                      (/ (* self-samples secs-per-sample) 1.0 num-calls)))
 446             (and num-calls ;; cum-samples must be positive
 447                  (/ (* cum-samples secs-per-sample)
 448                     1.0
 449                     ;; num-calls might be 0 if we entered statprof during the
 450                     ;; dynamic extent of the call
 451                     (max num-calls 1))))))
 452
 453 (define (statprof-stats-proc-name stats) (vector-ref stats 0))
 454 (define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1))
 455 (define (statprof-stats-cum-secs-in-proc stats) (vector-ref stats 2))
 456 (define (statprof-stats-self-secs-in-proc stats) (vector-ref stats 3))
 457 (define (statprof-stats-calls stats) (vector-ref stats 4))
 458 (define (statprof-stats-self-secs-per-call stats) (vector-ref stats 5))
 459 (define (statprof-stats-cum-secs-per-call stats) (vector-ref stats 6))
 460
 461 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 462
 463 (define (stats-sorter x y)
 464   (let ((diff (- (statprof-stats-self-secs-in-proc x)
 465                  (statprof-stats-self-secs-in-proc y))))
 466     (positive?
 467      (if (= diff 0)
 468          (- (statprof-stats-cum-secs-in-proc x)
 469             (statprof-stats-cum-secs-in-proc y))
 470          diff))))
 471
 472 (define (statprof-display . port)
 473   "Displays a gprof-like summary of the statistics collected. Unless an
 474 optional @var{port} argument is passed, uses the current output port."
 475   (if (null? port) (set! port (current-output-port)))
 476
 477   (cond
 478    ((zero? (statprof-sample-count))
 479     (format port "No samples recorded.\n"))
 480    (else
 481     (let* ((stats-list (statprof-fold-call-data
 482                         (lambda (data prior-value)
 483                           (cons (statprof-call-data->stats data)
 484                                 prior-value))
 485                         '()))
 486            (sorted-stats (sort stats-list stats-sorter)))
 487
 488       (define (display-stats-line stats)
 489         (if %count-calls?
 490             (format  port "~6,2f ~9,2f ~9,2f ~7d ~8,2f ~8,2f  "
 491                      (statprof-stats-%-time-in-proc stats)
 492                      (statprof-stats-cum-secs-in-proc stats)
 493                      (statprof-stats-self-secs-in-proc stats)
 494                      (statprof-stats-calls stats)
 495                      (* 1000 (statprof-stats-self-secs-per-call stats))
 496                      (* 1000 (statprof-stats-cum-secs-per-call stats)))
 497             (format  port "~6,2f ~9,2f ~9,2f  "
 498                      (statprof-stats-%-time-in-proc stats)
 499                      (statprof-stats-cum-secs-in-proc stats)
 500                      (statprof-stats-self-secs-in-proc stats)))
 501         (display (statprof-stats-proc-name stats) port)
 502         (newline port))
 503
 504       (if %count-calls?
 505           (begin
 506             (format  port "~5a ~10a   ~7a ~8a ~8a ~8a  ~8@a\n"
 507                      "%  " "cumulative" "self" "" "self" "total" "")
 508             (format  port "~5a  ~9a  ~8a ~8a ~8a ~8a  ~8@a\n"
 509                      "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name"))
 510           (begin
 511             (format  port "~5a ~10a   ~7a  ~8@a\n"
 512                      "%" "cumulative" "self" "")
 513             (format  port "~5a  ~10a  ~7a  ~8@a\n"
 514                      "time" "seconds" "seconds" "name")))
 515
 516       (for-each display-stats-line sorted-stats)
 517
 518       (display "---\n" port)
 519       (simple-format #t "Sample count: ~A\n" (statprof-sample-count))
 520       (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
 521                      (statprof-accumulated-time)
 522                      (/ gc-time-taken 1.0 internal-time-units-per-second))))))
 523
 524 (define (statprof-display-anomolies)
 525   "A sanity check that attempts to detect anomolies in statprof's
 526 statistics.@code{}"
 527   (statprof-fold-call-data
 528    (lambda (data prior-value)
 529      (if (and %count-calls?
 530               (zero? (call-data-call-count data))
 531               (positive? (call-data-cum-sample-count data)))
 532          (simple-format #t
 533                         "==[~A ~A ~A]\n"
 534                         (call-data-name data)
 535                         (call-data-call-count data)
 536                         (call-data-cum-sample-count data))))
 537    #f)
 538   (simple-format #t "Total time: ~A\n" (statprof-accumulated-time))
 539   (simple-format #t "Sample count: ~A\n" (statprof-sample-count)))
 540
 541 (define (statprof-accumulated-time)
 542   "Returns the time accumulated during the last statprof run.@code{}"
 543   (if (positive? profile-level)
 544       (error "Can't get accumulated time while profiler is running."))
 545   (/ accumulated-time internal-time-units-per-second))
 546
 547 (define (statprof-sample-count)
 548   "Returns the number of samples taken during the last statprof run.@code{}"
 549   (if (positive? profile-level)
 550       (error "Can't get accumulated time while profiler is running."))
 551   sample-count)
 552
 553 (define statprof-call-data-name call-data-name)
 554 (define statprof-call-data-calls call-data-call-count)
 555 (define statprof-call-data-cum-samples call-data-cum-sample-count)
 556 (define statprof-call-data-self-samples call-data-self-sample-count)
 557
 558 (define (statprof-fetch-stacks)
 559   "Returns a list of stacks, as they were captured since the last call
 560 to @code{statprof-reset}.
 561
 562 Note that stacks are only collected if the @var{full-stacks?} argument
 563 to @code{statprof-reset} is true."
 564   stacks)
 565
 566 (define procedure=?
 567   (lambda (a b)
 568     (cond
 569      ((eq? a b))
 570      ((and (program? a) (program? b))
 571       (eq? (program-code a) (program-code b)))
 572      (else
 573       #f))))
 574
 575 ;; tree ::= (car n . tree*)
 576
 577 (define (lists->trees lists equal?)
 578   (let lp ((in lists) (n-terminal 0) (tails '()))
 579     (cond
 580      ((null? in)
 581       (let ((trees (map (lambda (tail)
 582                           (cons (car tail)
 583                                 (lists->trees (cdr tail) equal?)))
 584                         tails)))
 585         (cons (apply + n-terminal (map cadr trees))
 586               (sort trees
 587                     (lambda (a b) (> (cadr a) (cadr b)))))))
 588      ((null? (car in))
 589       (lp (cdr in) (1+ n-terminal) tails))
 590      ((find (lambda (x) (equal? (car x) (caar in)))
 591             tails)
 592       => (lambda (tail)
 593            (lp (cdr in)
 594                n-terminal
 595                (assq-set! tails
 596                           (car tail)
 597                           (cons (cdar in) (cdr tail))))))
 598      (else
 599       (lp (cdr in)
 600           n-terminal
 601           (acons (caar in) (list (cdar in)) tails))))))
 602
 603 (define (stack->procedures stack)
 604   (filter identity
 605           (unfold-right (lambda (x) (not x))
 606                         frame-procedure
 607                         frame-previous
 608                         (stack-ref stack 0))))
 609
 610 (define (statprof-fetch-call-tree)
 611   "Return a call tree for the previous statprof run.
 612
 613 The return value is a list of nodes, each of which is of the type:
 614 @code
 615  node ::= (@var{proc} @var{count} . @var{nodes})
 616 @end code"
 617   (cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
 618
 619 (define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
 620                    (full-stacks? #f))
 621   "Profiles the execution of @var{thunk}.
 622
 623 The stack will be sampled @var{hz} times per second, and the thunk itself will
 624 be called @var{loop} times.
 625
 626 If @var{count-calls?} is true, all procedure calls will be recorded. This
 627 operation is somewhat expensive.
 628
 629 If @var{full-stacks?} is true, at each sample, statprof will store away the
 630 whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
 631 @code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
 632
 633   (dynamic-wind
 634     (lambda ()
 635       (statprof-reset (inexact->exact (floor (/ 1 hz)))
 636                       (inexact->exact (* 1e6 (- (/ 1 hz)
 637                                                 (floor (/ 1 hz)))))
 638                       count-calls?
 639                       full-stacks?)
 640       (statprof-start))
 641     (lambda ()
 642       (let lp ((i loop))
 643         (if (not (zero? i))
 644             (begin
 645               (thunk)
 646               (lp (1- i))))))
 647     (lambda ()
 648       (statprof-stop)
 649       (statprof-display)
 650       (set! procedure-data #f))))
 651
 652 (define-macro (with-statprof . args)
 653   "Profiles the expressions in its body.
 654
 655 Keyword arguments:
 656
 657 @table @code
 658 @item #:loop
 659 Execute the body @var{loop} number of times, or @code{#f} for no looping
 660
 661 default: @code{#f}
 662 @item #:hz
 663 Sampling rate
 664
 665 default: @code{20}
 666 @item #:count-calls?
 667 Whether to instrument each function call (expensive)
 668
 669 default: @code{#f}
 670 @item #:full-stacks?
 671 Whether to collect away all sampled stacks into a list
 672
 673 default: @code{#f}
 674 @end table"
 675   (define (kw-arg-ref kw args def)
 676     (cond
 677      ((null? args) (error "Invalid macro body"))
 678      ((keyword? (car args))
 679       (if (eq? (car args) kw)
 680           (cadr args)
 681           (kw-arg-ref kw (cddr args) def)))
 682      ((eq? kw #f def) ;; asking for the body
 683       args)
 684      (else def))) ;; kw not found
 685   `((@ (statprof) statprof)
 686     (lambda () ,@(kw-arg-ref #f args #f))
 687     #:loop ,(kw-arg-ref #:loop args 1)
 688     #:hz ,(kw-arg-ref #:hz args 100)
 689     #:count-calls? ,(kw-arg-ref #:count-calls? args #f)
 690     #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
 691
 692 (define* (gcprof thunk #:key (loop 1) (full-stacks? #f))
 693   "Do an allocation profile of the execution of @var{thunk}.
 694
 695 The stack will be sampled soon after every garbage collection, yielding
 696 an approximate idea of what is causing allocation in your program.
 697
 698 Since GC does not occur very frequently, you may need to use the
 699 @var{loop} parameter, to cause @var{thunk} to be called @var{loop}
 700 times.
 701
 702 If @var{full-stacks?} is true, at each sample, statprof will store away the
 703 whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
 704 @code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
 705
 706   (define (reset)
 707     (if (positive? profile-level)
 708         (error "Can't reset profiler while profiler is running."))
 709     (set! accumulated-time 0)
 710     (set! last-start-time #f)
 711     (set! sample-count 0)
 712     (set! %count-calls? #f)
 713     (set! procedure-data (make-hash-table 131))
 714     (set! record-full-stacks? full-stacks?)
 715     (set! stacks '()))
 716
 717   (define (gc-callback)
 718     (cond
 719      (inside-profiler?)
 720      (else
 721       (set! inside-profiler? #t)
 722
 723       ;; FIXME: should be able to set an outer frame for the stack cut
 724       (let ((stop-time (get-internal-run-time))
 725             ;; Cut down to gc-callback, and then one before (the
 726             ;; after-gc async).  See the note in profile-signal-handler
 727             ;; also.
 728             (stack (or (make-stack #t gc-callback 0 1)
 729                        (pk 'what! (make-stack #t)))))
 730         (sample-stack-procs stack)
 731         (accumulate-time stop-time)
 732         (set! last-start-time (get-internal-run-time)))
 733
 734       (set! inside-profiler? #f))))
 735
 736   (define (start)
 737     (set! profile-level (+ profile-level 1))
 738     (if (= profile-level 1)
 739         (begin
 740           (set! remaining-prof-time #f)
 741           (set! last-start-time (get-internal-run-time))
 742           (set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
 743           (add-hook! after-gc-hook gc-callback)
 744           (set-vm-trace-level! (1+ (vm-trace-level)))
 745           #t)))
 746
 747   (define (stop)
 748     (set! profile-level (- profile-level 1))
 749     (if (zero? profile-level)
 750         (begin
 751           (set! gc-time-taken
 752                 (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
 753           (remove-hook! after-gc-hook gc-callback)
 754           (accumulate-time (get-internal-run-time))
 755           (set! last-start-time #f))))
 756
 757   (dynamic-wind
 758     (lambda ()
 759       (reset)
 760       (start))
 761     (lambda ()
 762       (let lp ((i loop))
 763         (if (not (zero? i))
 764             (begin
 765               (thunk)
 766               (lp (1- i))))))
 767     (lambda ()
 768       (stop)
 769       (statprof-display)
 770       (set! procedure-data #f))))