profile.scm

(define (string.rpad s n c) (string s (string.rep c (- n (string.count s)))))

(define (string.rep s k)
  (cond ((< k 4)
         (cond ((<= k 0) "")
               ((=  k 1) (string s))
               ((=  k 2) (string s s))
               (else     (string s s s))))
        ((odd? k) (string s (string.rep s (- k 1))))
        (else     (string.rep (string s s) (/ k 2)))))

(let ((*profiles* (table))
      (running #f))
  (set! profile
        (lambda (s)
          (let ((f (top-level-value s)))
            (put! *profiles* s (cons 0 (cons 0 0))) ; count, self, total
            (set-top-level-value! s
             (lambda args
               (define tt (get *profiles* s))
               (define last-tt running)
               (define last-t0 (cddr tt))
               (define t0 (time.now))
               (set! running tt)
               (define v (apply f args))
               (set! running last-tt)
               (define t1 (time.now))
               (define tdelta (- t1 t0))
               (if last-tt (set-car! (cdr last-tt) (- (cadr last-tt) tdelta)))
               (set-car! (cdr tt) (+ (cadr tt) tdelta))
               (set-cdr! (cdr tt) (+ last-t0 tdelta))
               (set-car! tt (+ (car tt) 1))
               v)))))
  (set! show-profiles
        (lambda ()
          (define total 0)
          (define pr (filter (lambda (x) (> (cadr x) 0))
                             (table.pairs *profiles*)))
          (define width (+ 4
                           (apply max
                                  (map (lambda (x)
                                         (length (string x)))
                                       (cons 'Function
                                             (map car pr))))))
          (princ (string.rpad "Function" width #\ )
                 "#Calls     Total Time (seconds)    Self Time (seconds)")
          (newline)
          (princ (string.rpad "--------" width #\ )
                 "------     --------------------    -------------------")
          (newline)
          (for-each
           (lambda (p)
         (set! total (+ total (cadr p)))
             (princ (string.rpad (string (cadddr p)) width #\ )
                    (string.rpad (string (caddr p)) 11 #\ )
                    (string.rpad (string (car p)) 24 #\ )
            (cadr p))
             (newline))
           (reverse (simple-sort (map (lambda (l) (reverse (to-proper l)))
                                      pr))))
       (princ (string.rpad "--------" width #\ )
                 "------     --------------------    -------------------")
       (newline)
       (princ (string.rpad "Total   " width #\ )
                 "           " (string total))
       (newline)))
  (set! clear-profiles
        (lambda ()
          (for-each (lambda (k)
                      (put! *profiles* k (cons 0 (cons 0 0))))
                    (table.keys *profiles*)))))