guile-charting/charting/prof.scm

;; chartprof -- a graphical tree frontend to statprof
;; Copyright (C) 2009  Andy Wingo <wingo@pobox.com>

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Lesser 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 Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this program.  If not, see
;; <http://www.gnu.org/licenses/>.

(define-module (charting prof)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 format)
  #:use-module (ice-9 receive)
  #:use-module (statprof)
  #:use-module (cairo)
  #:use-module (charting util)
  #:use-module (charting draw)
  #:export (chartprof))

(define *width* 8)
(define *right-text-width* 100)
(define *unit-height* 8)
(define *spacing* 4)
(define *unit-height-with-spacing* (+ *unit-height* *spacing*))
(define *margin* 16)

(define (show-object cr object x y justification)
  (let* ((text (with-output-to-string (lambda () (display object))))
         (width (cairo-text-extents:width (cairo-text-extents cr text))))
    (cairo-move-to
     cr
     (+ (case justification
          ((left) 0)
          ((right) (- width))
          ((center) (- (/ width 2)))
          (else
           (error "unknown justification" justification)))
        x)
     y)
    (cairo-show-text cr text)))

(define (annotate-node cr tree)
  (define (fmt val)
    (format #f "~,2f" (* 100.0 (/ val (cadr tree)))))
  (define (node-pre tree x-y)
    (let ((imgwidth (cairo-image-surface-get-width (cairo-get-target cr)))
          (terminal (fold (lambda (x y) (- y (cadr x)))
                          (cadr tree)
                          (cddr tree))))
      (if (or (null? (cddr tree))
              (not (null? (cdddr tree))))
          (begin
           (cairo-save cr)
           (cairo-set-source-rgba cr 0.7 0.7 0.7 1)
           (cairo-set-line-width cr 1)
           (cairo-move-to cr (+ (* 2 (car x-y) *width*) *margin*)
                          (+ (cdr x-y) *unit-height* 1 (- *margin*)))
           (cairo-line-to cr (- imgwidth *margin*)
                          (+ (cdr x-y) *unit-height* 1 (- *margin*)))
           (cairo-stroke cr)
           (cairo-restore cr)))
      (if (> terminal 0)
          (show-object cr (fmt terminal) (+ (* 2 (car x-y) *width*) *margin*)
                       (+ (cdr x-y) *unit-height* (- *margin*))
                       'left))
      (if (< terminal (cadr tree))
          (show-object cr (fmt (- (cadr tree) terminal))
                       (+ (- (* 2 (car x-y) *width*) *width*) *margin*)
                       (+ (cdr x-y) *unit-height* (- *margin*))
                       'right))
      (show-object cr (car tree) (- imgwidth *margin*)
                   (+ (cdr x-y) *unit-height* (- *margin*))
                   'right)
      (cons (car x-y) (+ (cdr x-y) (* terminal *unit-height*)))))
  (define (subnode subtree x-y)
    (draw-fold subtree node-pre subnode node-post
               (cons (1+ (car x-y)) (+ (cdr x-y) *unit-height-with-spacing*))))
  (define (node-post tree x-y)
    (cons (1- (car x-y)) (cdr x-y)))
  (cairo-set-source-rgba cr 0 0 0 1)
  (cairo-select-font-face cr "Monospace" 'normal 'normal)
  (cairo-set-font-size cr 10.0)
  (draw-fold tree node-pre subnode node-post (cons 1 *margin*)))

(define (draw-node cr tree)
  (define (node-pre tree swoosh-y)
    (let ((terminal (fold (lambda (x y) (- y (cadr x)))
                          (cadr tree)
                          (cddr tree))))
      (cairo-rel-line-to cr *width* 0)
      (cairo-rel-line-to cr 0 (* terminal *unit-height*))
      (+ swoosh-y (* terminal *unit-height*))))
  (define (subnode subtree swoosh-y)
    (receive (current-x current-y) (cairo-get-current-point cr)
      (let* ((swoosh-y (+ *unit-height-with-spacing* swoosh-y))
             (y-offset (- swoosh-y current-y)))
        (cairo-rel-curve-to cr *width* 0 0 y-offset *width* y-offset)
        (let ((swoosh-y (draw-fold subtree node-pre subnode node-post swoosh-y)))
          (cairo-rel-curve-to cr (- *width*) 0 0 (- y-offset)
                              (- *width*) (- y-offset))
          swoosh-y))))
  (define (node-post tree swoosh-y)
    (cairo-rel-line-to cr (- *width*) 0)
    swoosh-y)
  (cairo-move-to cr 0 0)
  (draw-fold tree node-pre subnode node-post 0)
  (cairo-close-path cr)
  (cairo-set-source-rgba cr 1 0.5 0.5 1.0)
  (cairo-fill-preserve cr)
  (cairo-stroke cr))

(define (draw-fold tree node-pre subnode node-post seed)
  (node-post tree (fold subnode (node-pre tree seed) (cddr tree))))

(define (count-nodes tree)
  (fold (lambda (x y) (+ (count-nodes x) y))
        1
        (cddr tree)))

(define (depth tree)
  (+ 1 (fold (lambda (x y) (max (depth x) y))
             0
             (cddr tree))))

(define (chartprof filename)
  (let ((tree (statprof-fetch-call-tree)))
    (if (null? tree)
        (format #t "No stacks collected. Did you run statprof with #:full-stacks #t?")
        (let* ((width (+ (* 2 (depth tree) *width*) (* 2 *margin*) *right-text-width*))
               (height (+ (* (count-nodes tree) *unit-height-with-spacing*)
                          (* (cadr tree) *unit-height*)))
               (surface (cairo-image-surface-create 'rgb24
                                                    (+ width (* 2 *margin*))
                                                    (+ height (* 2 *margin*))))
               (cr (cairo-create surface)))
          (cairo-translate cr *margin* *margin*)
          (draw-background cr)
          (draw-node cr tree)
          (cairo-translate cr (- *margin*) 0)
          (annotate-node cr tree)
          (cairo-surface-write-to-png surface filename)))))