cgen/profile.scm

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