#!/bin/sh
# -*- scheme -*-
exec guile --debug -e main -s "$0" "$@"
!#
;;; Copyright (c) 2007 Andy Wingo <wingo at pobox.com>
;;; LGPL, like Guile itself.


(use-modules (srfi srfi-13)
             (ice-9 optargs)
             (ice-9 regex)
             (ice-9 rdelim)
             (ice-9 format))

(define-macro (define-accessors type . fields)
  `(begin
     ,@(map (lambda (field)
              ;; can't have : as a symbol
              `(begin
                 (define (,(string->symbol
                            (string-append
                             (symbol->string type) ":" (symbol->string field)))
                          obj)
                   (vector-ref obj ,(list-index fields field)))
                 (define (,(symbol-append 'set- type '- field '!) obj v)
                   (vector-set! obj ,(list-index fields field) v))))
            fields)))

(define (make-call-data)
  (vector 0 0 0 #f #f #f))
(define-accessors call-data
  calls self incl name source object)

(define-accessors grow-vector
  len constructor vector)
(define (make-grow-vector element-constructor)
  (vector 0 element-constructor (vector)))

(define (grow-vector-set! gvec n val)
  (cond
   ((< n (grow-vector:len gvec))
    (vector-set! (grow-vector:vector gvec) n val))
   (else
    (let ((new (make-vector (if (zero? (grow-vector:len gvec))
                                1
                                (* (grow-vector:len gvec) 2))
                            #f)))
      (do ((i 0 (1+ i)))
          ((>= i (grow-vector:len gvec)))
        (vector-set! new i (vector-ref (grow-vector:vector gvec) i)))
      (set-grow-vector-vector! gvec new)
      (set-grow-vector-len! gvec (vector-length new))
      (grow-vector-set! gvec n val)))))

(define (grow-vector-ref gvec n)
  (or (and (< n (grow-vector:len gvec))
           (vector-ref (grow-vector:vector gvec) n))
      (let ((data ((grow-vector:constructor gvec))))
        (grow-vector-set! gvec n data)
        data)))

(define (grow-vector-fold gvec proc init)
  (let ((vec (grow-vector:vector gvec)))
    (let lp ((i 0) (ret init))
      (cond ((>= i (vector-length vec))
             ret)
            ((not (vector-ref vec i))
             (lp (1+ i) ret))
            (else
             (lp (1+ i) (proc i (vector-ref vec i) ret)))))))

(define-macro (match-bind regex str vars consequent . alternate)
  (or (string? regex) (error "regex needs to be a string so we can compile it"))
  (let ((re (gensym)) (match (gensym)))
    `(let ((,re ,(make-regexp regex)))
       ((lambda (,match)
          (if ,match
              (apply (lambda ,vars ,consequent)
                     (map (lambda (x) (match:substring ,match x))
                          (iota (match:count ,match))))
              ,@alternate))
        (regexp-exec ,re ,str)))))

(define (parse-paren val set)
  (match-bind "^\\(([0-9]+)\\) *(.+)?$" val (_ n name)
              (let ((n (string->number n)))
                (if name (set n name))
                n)
              (error "could not parse" val)))

(define (parse-data)
  (let ((functions (make-grow-vector make-call-data))
        (sources (make-grow-vector (lambda () #f)))
        (objects (make-grow-vector (lambda () #f)))
        (headers '()))
    (define (inc-self-cost! n cost)
      (let ((call-data (grow-vector-ref functions n)))
        (set-call-data-self! call-data (+ cost (call-data:self call-data)))))
    (define (inc-incl-cost! n cost)
      (let ((call-data (grow-vector-ref functions n)))
        (set-call-data-incl! call-data (+ cost (call-data:incl call-data)))))
    (define (inc-calls! n calls)
      (let ((call-data (grow-vector-ref functions n)))
        (set-call-data-calls! call-data (+ calls (call-data:calls call-data)))))
    (let lp ((fn #f) (cfn #f) (fi #f) (ob #f) (cfi #f) (cob #f))
      (let ((line (read-line)))
        (define (parse-func val fi ob)
          (parse-paren
           val
           (lambda (n name)
             (let ((call-data (grow-vector-ref functions n)))
               (set-call-data-name! call-data name)
               (if fi (set-call-data-source! call-data fi))
               (if ob (set-call-data-object! call-data ob))))))
        (define (-fn val)
          (lp (parse-func val fi ob) #f fi ob fi ob))
        (define (-cfn val)
          (lp fn (parse-func val (or cfi fi) (or cob ob)) fi ob fi ob))
        (define (-calls val)
          (match-bind "^([0-9]+)[ ]+(.*)$" val (_ calls dest-pos)
                      (inc-calls! cfn (string->number calls))
                      (error "count not parse calls" val))
          (lp fn cfn fi ob cfi cob))
        (define (-ob val)
          (let ((n (parse-paren
                    val (lambda (n name) (grow-vector-set! objects n name)))))
            (lp fn cfn fi n cfi n)))
        (define (-cob val)
          (let ((n (parse-paren
                    val (lambda (n name) (grow-vector-set! objects n name)))))
            (lp fn cfn fi ob cfi n)))
        (define (-fi val)
          (let ((n (parse-paren
                    val (lambda (n name) (grow-vector-set! sources n name)))))
            (lp fn cfn n ob n cob)))
        (define (-cfi val)
          (let ((n (parse-paren
                    val (lambda (n name) (grow-vector-set! sources n name)))))
            (lp fn cfn fi ob n cob)))
        (define (-ignore val)
          (lp fn cfn fi ob cfi cob))
        (cond
         ((eof-object? line)
          (values headers functions sources objects))
         ((string-index line #\:)
          (match-bind "^(.*):[ ]*(.*)$" line (_ key val)
                      (set! headers (acons key val headers)))
          (lp fn cfn fi ob cfi cob))
         ((or (= (string-length line) 0)
              (char=? (string-ref line 0) #\#))
          (lp fn cfn fi ob cfi cob))
         ((string-index line #\=)
          (match-bind "^(.*)= *(.*)$" line (_ spec position)
                      ((assoc-ref
                        `(("fn" . ,-fn)
                          ("cfn" . ,-cfn)
                          ("ob" . ,-ob)
                          ("cob" . ,-cob)
                          ("fl" . ,-fi)
                          ("fi" . ,-fi)
                          ("cfi" . ,-cfi)
                          ("calls" . ,-calls)
                          ("fe" . ,-ignore))
                        spec) position)
                      (error "unparseable:" line)))
         (else
          (match-bind "^([^ ]+)[ ]([0-9]+)$" line (_ pos cost)
                      (let ((cost (string->number cost)))
                        (inc-incl-cost! fn cost)
                        (if (not cfn)
                            (inc-self-cost! fn cost))))
          (lp fn #f fi ob fi ob)))))))

; fixme: self secs per call
(define (display-stats headers functions sources objects)
  (let ((total-count (grow-vector-fold
                      functions
                      (lambda (i call-data x)
                        (if (not (call-data:source call-data))
                            (pk i call-data))
                        (+ x (call-data:self call-data)))
                      0)))
    (sort! (grow-vector:vector functions)
           (lambda (x y)
             (cond ((not x) #f)
                   ((not y) #t)
                   (else
                    (let ((diff (- (call-data:self x) (call-data:self y))))
                      (positive?
                       (if (= diff 0)
                           (- (call-data:incl x) (call-data:incl y))
                           diff)))))))
    (cond
     ((zero? total-count)
      (format port "No samples recorded.\n"))
     (else
      (for-each (lambda (pair)
                  (format #t "~a: ~a\n" (car pair) (cdr pair)))
                (reverse! headers))
      (display "---\n")
      (format #t "cumulative   self      total\n")
      (format #t " percent    percent    calls    file:function\n")

      (grow-vector-fold
       functions
       (lambda (i call-data _)
         (and call-data
              (format #t "~8,2f    ~6,2f ~10d   ~a:~a[~a]\n"
                      (* (/ (call-data:incl call-data) total-count) 100.0)
                      (* (/ (call-data:self call-data) total-count) 100.0)
                      (call-data:calls call-data)
                      (or (and=> (call-data:source call-data)
                                 (lambda (n) (grow-vector-ref sources n)))
                          "???")
                      (call-data:name call-data)
                      (or (and=> (call-data:object call-data)
                                 (lambda (n) (grow-vector-ref objects n)))
                          "???"))))
       #f)
    
      (display "---\n")
      (format #t "Sample count: ~A\n" total-count)))))

(define* (main args)
  (with-input-from-port (if (null? (cdr args))
                            (current-input-port)
                            (apply open-input-file (cdr args)))
    (lambda ()
      (call-with-values parse-data display-stats))))