cgen/profile.scm

   1 ;;; {Profile}
   2 ;;;
   3 ;;; This code is just an experimental prototype (e. g., it is not
   4 ;;; thread safe), but since it's at the same time useful, it's
   5 ;;; included anyway.
   6 ;;;
   7 ;;; This is copied from the tracing support in debug.scm.
   8 ;;; If merged into the main distribution it will need an efficiency
   9 ;;; and layout cleanup pass.
  10
  11 ; FIXME: Prefix "proc-" added to not collide with cgen stuff.
  12
  13 ; Put this stuff in the debug module since we need the trace facilities.
  14 (define-module (ice-9 profile) :use-module (ice-9 debug))
  15
  16 (define profiled-procedures '())
  17
  18 (define-public (profile-enable . args)
  19   (if (null? args)
  20       (nameify profiled-procedures)
  21       (begin
  22         (for-each (lambda (proc)
  23                     (if (not (procedure? proc))
  24                         (error "profile: Wrong type argument:" proc))
  25                     ; `trace' is a magic property understood by guile
  26                     (set-procedure-property! proc 'trace #t)
  27                     (if (not (memq proc profiled-procedures))
  28                         (set! profiled-procedures
  29                               (cons proc profiled-procedures))))
  30                   args)
  31         (set! apply-frame-handler profile-entry)
  32         (set! exit-frame-handler profile-exit)
  33         (debug-enable 'trace)
  34         (nameify args))))
  35
  36 (define-public (profile-disable . args)
  37   (if (and (null? args)
  38            (not (null? profiled-procedures)))
  39       (apply profile-disable profiled-procedures)
  40       (begin
  41         (for-each (lambda (proc)
  42                     (set-procedure-property! proc 'trace #f)
  43                     (set! profiled-procedures (delq! proc profiled-procedures)))
  44                   args)
  45         (if (null? profiled-procedures)
  46             (debug-disable 'trace))
  47         (nameify args))))
  48
  49 (define (nameify ls)
  50   (map (lambda (proc)
  51          (let ((name (procedure-name proc)))
  52            (or name proc)))
  53        ls))
  54
  55 ; Subroutine of profile-entry to find the calling procedure.
  56 ; Result is name of calling procedure or #f.
  57
  58 (define (find-caller frame)
  59   (let ((prev (frame-previous frame)))
  60     (if prev
  61         ; ??? Not sure this is right.  The goal is to find the real "caller".
  62         (if (and (frame-procedure? prev)
  63                  ;(or (frame-real? prev) (not (frame-evaluating-args? prev)))
  64                  (not (frame-evaluating-args? prev))
  65                  )
  66             (let ((name (procedure-name (frame-procedure prev))))
  67               (if name name 'lambda))
  68             (find-caller prev))
  69         'top-level))
  70 )
  71
  72 ; Return the current time.
  73 ; The result is a black box understood only by elapsed-time.
  74
  75 (define (current-time) (gettimeofday))
  76
  77 ; Return the elapsed time in milliseconds since START.
  78
  79 (define (elapsed-time start)
  80   (let ((now (gettimeofday)))
  81     (+ (* (- (car now) (car start)) 1000)
  82        (quotient (- (cdr now) (cdr start)) 1000)))
  83 )
  84
  85 ; Handle invocation of profiled procedures.
  86
  87 (define (profile-entry key cont tail)
  88   (if (eq? (stack-id cont) 'repl-stack)
  89       (let* ((stack (make-stack cont))
  90              (frame (stack-ref stack 0))
  91              (proc (frame-procedure frame)))
  92         (if proc
  93             ; procedure-property returns #f if property not present
  94             (let ((counts (procedure-property proc 'profile-count)))
  95               (set-procedure-property! proc 'entry-time (current-time))
  96               (if counts
  97                   (let* ((caller (find-caller frame))
  98                          (count-elm (assq caller counts)))
  99                     (if count-elm
 100                         (set-cdr! count-elm (1+ (cdr count-elm)))
 101                         (set-procedure-property! proc 'profile-count
 102                                                  (acons caller 1 counts)))))))))
 103
 104   ; SCM_TRACE_P is reset each time by the interpreter
 105   ;(display "entry\n" (current-error-port))
 106   (debug-enable 'trace)
 107   ;; It's not necessary to call the continuation since
 108   ;; execution will continue if the handler returns
 109   ;(cont #f)
 110 )
 111
 112 ; Handle exiting of profiled procedures.
 113
 114 (define (profile-exit key cont retval)
 115   ;(display "exit\n" (current-error-port))
 116   (display (list key cont retval)) (newline)
 117   (display (stack-id cont)) (newline)
 118   (if (eq? (stack-id cont) 'repl-stack)
 119       (let* ((stack (make-stack cont))
 120              (frame (stack-ref stack 0))
 121              (proc (frame-procedure frame)))
 122         (display stack) (newline)
 123         (display frame) (newline)
 124         (if proc
 125             (set-procedure-property!
 126              proc 'total-time
 127              (+ (procedure-property proc 'total-time)
 128                 (elapsed-time (procedure-property proc 'entry-time)))))))
 129
 130   ; ??? Need to research if we have to do this or not.
 131   ; SCM_TRACE_P is reset each time by the interpreter
 132   (debug-enable 'trace)
 133 )
 134
 135 ; Called before something is to be profiled.
 136 ; All desired procedures to be profiled must have been previously selected.
 137 ; Property `profile-count' is an association list of caller name and call
 138 ; count.
 139 ; ??? Will eventually want to use a hash table or some such.
 140
 141 (define-public (profile-init)
 142   (for-each (lambda (proc)
 143               (set-procedure-property! proc 'profile-count '())
 144               (set-procedure-property! proc 'total-time 0))
 145             profiled-procedures)
 146 )
 147
 148 ; Called after execution to print profile counts.
 149 ; If ARGS contains 'all, stats on all profiled procs are printed, not just
 150 ; those that were actually called.
 151
 152 (define-public (profile-stats . args)
 153   (let ((stats (map (lambda (proc)
 154                       (cons (procedure-name proc)
 155                             (procedure-property proc 'profile-count)))
 156                     profiled-procedures))
 157         (all? (memq 'all args))
 158         (sort (if (defined? 'sort) (local-ref '(sort)) (lambda args args))))
 159
 160     (display "Profiling results:\n\n")
 161
 162     ; Print the procs in sorted order.
 163     (let ((stats (sort stats (lambda (a b) (string<? (car a) (car b))))))
 164       (for-each (lambda (proc-stats)
 165                   (if (or all? (not (null? (cdr proc-stats))))
 166                       ; Print by decreasing frequency.
 167                       (let ((calls (sort (cdr proc-stats) (lambda (a b) (> (cdr a) (cdr b))))))
 168                         (display (string-append (car proc-stats) "\n"))
 169                         (for-each (lambda (call)
 170                                     (display (string-append "  "
 171                                                             (number->string (cdr call))
 172                                                             " "
 173                                                             (car call)
 174                                                             "\n")))
 175                                   calls)
 176                         (display "  ")
 177                         (display (apply + (map cdr calls)))
 178                         (display " -- total\n\n"))))
 179                 stats)))
 180 )