;;; -*- Mode: Scheme; scheme48-package: swank-statistical-profiling-rpc -*-

;;;; SLIME for Scheme48
;;;; Statistical Profiler Interface

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define-swank-session-slot swank-profile
  set-swank-profile!
  modify-swank-profile!
  #f)

(define-swank-session-slot swank-profile-report
  set-swank-profile-report!
  modify-swank-profile-report!
  #f)

(define (swank:swank-sprofile-start)
  (let ((profile (make-profile)))
    (set-swank-profile! profile)
    (set-swank-profile-report! #f)
    (start-profiling profile))
  'nil)

(define (swank:swank-sprofile-stop)
  (let ((profile (swank-profile)))
    (stop-profiling profile)
    (set-swank-profile-report! (profile-report profile)))
  'nil)

(define (swank:swank-sprofile-clear)
  (set-swank-profile! #f)
  (set-swank-profile-report! #f)
  'nil)

(define (swank:swank-sprofile-get-call-graph)
  (let ((report (swank-profile-report))
        (profile (swank-profile)))
    (let loop ((i 0) (total 0) (entries '()))
      (if (= i (vector-length report))
          (reverse! entries)
          (let ((node (vector-ref report i)))
            (let ((samples (profile-node-samples node))
                  (waiting (profile-node-waiting node)))
              (let ((total (+ total
                              (profile-percent samples profile))))
                (loop (+ i 1)
                      total
                      (cons (list i (profile-node-name-for-emacs node)
                                  (profile-percent samples profile)
                                  (profile-percent (+ samples waiting)
                                                   profile)
                                  total)
                            entries)))))))))

(define (profile-percent samples profile)
  (* 100.0 (profile-ratio samples profile)))

(define (profile-ratio samples profile)
  (/ samples (+ (profile-total-samples profile)
                (profile-total-waiting profile))))

(define (reverse! list)
  (let loop ((list list) (tail '()))
    (if (pair? list)
        (let ((tail* (cdr list)))
          (set-cdr! list tail)
          (loop tail* list))
        tail)))

(define (swank:swank-sprofile-expand-node index)
  (let ((profile (swank-profile)))
    (let ((node (vector-ref (swank-profile-report) index))
          (map-nodes
           (let ((divisor (+ (profile-total-samples profile)
                             (profile-total-waiting profile))))
             (lambda (nodes)
               (map (lambda (node.count)
                      (let ((node (car node.count))
                            (count (cdr node.count)))
                        (list (profile-node-index node)
                              (profile-node-name-for-emacs node)
                              (* 100.0 (/ count divisor)))))
                    nodes)))))
      `(:CALLERS ,(map-nodes (profile-node-callers node profile))
        :CALLS ,(map-nodes (profile-node-callees node profile))))))

(define (profile-node-name-for-emacs node)
  (let ((template (profile-node-template node)))
    (cond ((template-debug-data template)
           => (lambda (ddata)
                (call-with-string-output-port
                  (lambda (port)
                    (display-debug-data-names ddata port)))))
          (else "(anonymous)"))))

(define (swank:swank-sprofile-disassemble index)
  (let ((template
         (profile-node-template (vector-ref (swank-profile-report)
                                            index))))
    (with-output-to-string
      (lambda ()
        (disassemble template)))))

(define (swank:swank-sprofile-source-location index)
  ;++ This pattern should be abstracted in another module.
  (let ((template
         (profile-node-template (vector-ref (swank-profile-report)
                                            index))))
    (or (template-source-location template #f)
        '(:ERROR "No source location for profile entry."))))