;;;;;; Rudimentary Scheme48 profiler                     -*- Scheme -*-

;;; Taylor Campbell wrote this code; he places it in the public domain.

;;; Warning: falling hacks ahead!  (notably the interrupt handler
;;; installation mechanism)

; ,open interrupts architecture session-data continuations templates
; ,open receiving escapes disclosers primitives sort debug-data tables
; ,open command-processor environments

(define-user-command-syntax 'profile "<command>"
  "profile execution"
  '(command))

(environment-define! (user-command-environment) 'profile
  (lambda (command)
    (profile-and-display (if (eq? (car command) 'run)
                             (eval `(LAMBDA () ,(cadr command))
                                   (environment-for-commands))
                             (lambda () (execute-command command)))
                         (current-output-port))))

(define (profile-and-display thunk port)
  (receive (results samples counts)
           (profile thunk)
    (newline port)
    (display samples port)
    (display " samples" port)
    (newline port)
    (newline port)
    (display "** Sampled:" port)
    (newline port)
    (display-profile counts car port)
    (newline port)
    (display "** Waiting:" port)
    (newline port)
    (display-profile counts cdr port)
    (apply values results)))

(define (display-profile counts cxr port)
  (for-each (lambda (count)
              (cond ((not (zero? (cxr (cdr count))))
                     (display "  " port)
                     (display (cxr (cdr count)) port)
                     (display " " port)
                     (display-location (car count) port)
                     (newline port))))
            (sort-list counts
                       (lambda (x y)
                         (>= (cxr (cdr x))
                             (cxr (cdr y)))))))

(define (display-location ddata port)
  (if (not (and (debug-data? ddata)
                (pair? (debug-data-names ddata))))
      (write `(anonymous ,(if (debug-data? ddata)
                              (debug-data-uid ddata)
                              ddata))
             port)
      (let loop ((names (debug-data-names ddata)))
        (write (or (car names) '(anonymous)) port)
        (if (pair? (cdr names))
            (begin (display " in " port)
                   (loop (cdr names)))))))

(define (profile thunk)
  (receive vals (*profile thunk)
    (set! *profiler-continuation* #f)
    (values vals (swap! *samples* #f) (collect-counts))))

(define (*profile thunk)
  ;; We assume that the thread system is already running, so we don't
  ;; need to schedule our own interrupts.
  (dynamic-wind
    (lambda ()
      (install-profiler-interrupt-handler))
    (lambda ()
      (primitive-cwcc
        (lambda (profiler-cont)
          (set! *profiler-continuation* profiler-cont)
          (set! *samples* 0)
          (set! *templates* (make-table template-id))
          (thunk))))
    (lambda ()
      (uninstall-profiler-interrupt-handler))))



;;; Miscellaneous global state

(define *profiler-continuation* #f)     ;Profiler's top continuation
(define *samples* #f)                   ;Number of profiler interrupts
(define *templates* #f)                 ;Template -> sample count table
(define *saved-interrupt-handler* #f)   ;Non-profiler interrupt handler

;;; Interrupt handlers

(define interrupt-handlers 1)           ;Magic constant!

(define (install-profiler-interrupt-handler)
  (let ((handlers (session-data-ref interrupt-handlers)))
    (set! *saved-interrupt-handler*
          (vector-ref handlers (enum interrupt alarm)))
    (vector-set! handlers (enum interrupt alarm)
                 handle-profiler-interrupt)))

(define (uninstall-profiler-interrupt-handler)
  (let ((handler *saved-interrupt-handler*))
    (set! *saved-interrupt-handler* #f)
    (vector-set! (session-data-ref interrupt-handlers)
                 (enum interrupt alarm)
                 handler)))

(define (handle-profiler-interrupt template enabled)
  ;; There was once a time when the TEMPLATE argument was useful, but
  ;; after Scheme48 1.0's architectural changes it has always been just
  ;; #F.
  (set! *samples* (+ *samples* 1))
  (primitive-cwcc
    (lambda (cont)
      (record-continuation cont)
      (*saved-interrupt-handler* template enabled))))



;;; Recording data

(define (useful-continuation? cont)
  (and cont (not (eq? cont *profiler-continuation*))))

(define (record-continuation cont)
  (cond ((find-template cont)
         => (lambda (template)
              (cond ((table-ref *templates* template)
                     => (lambda (cell)
                          (set-car! cell (+ (car cell) 1))))
                    (else
                     (table-set! *templates* template (cons 1 0)))))))
  (let loop ((cont (continuation-cont cont)))
    (let ((parent (continuation-cont cont)))
      (if (and (useful-continuation? cont)
               (useful-continuation? parent))
          (begin (cond ((continuation-template cont)
                        => (lambda (template)
                             (cond ((table-ref *templates* template)
                                    => (lambda (cell)
                                         (set-cdr! cell
                                                   (+ (cdr cell) 1))))
                                   (else
                                    (table-set! *templates* template
                                                (cons 0 1)))))))
                 (loop parent))))))

(define (find-template cont)
  (let ((len (continuation-length cont)))
    (let loop ((i 0))
      (and (< i len)
           (let ((elt (continuation-ref cont i)))
             (if (template? elt)        ;++ Heuristic.
                 elt
                 (loop (+ i 1))))))))

(define (collect-counts)
  (let ((counts '()))
    (table-walk (lambda (template cell)
                  (set! counts
                        (cons (cons (template-debug-data template)
                                    cell)
                              counts)))
                (swap! *templates* #f))
    counts))



;;; Random utility macro

(define-syntax swap!
  (syntax-rules ()
    ((SWAP! x value)
     (LET ((TEMP x))
       (SET! x value)
       TEMP))))