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
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.
11 ; FIXME: Prefix "proc-" added to not collide with cgen stuff.
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))
16 (define profiled-procedures '())
18 (define-public (profile-enable . args)
20 (nameify profiled-procedures)
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))))
31 (set! apply-frame-handler profile-entry)
32 (set! exit-frame-handler profile-exit)
36 (define-public (profile-disable . args)
38 (not (null? profiled-procedures)))
39 (apply profile-disable profiled-procedures)
41 (for-each (lambda (proc)
42 (set-procedure-property! proc 'trace #f)
43 (set! profiled-procedures (delq! proc profiled-procedures)))
45 (if (null? profiled-procedures)
46 (debug-disable 'trace))
51 (let ((name (procedure-name proc)))
55 ; Subroutine of profile-entry to find the calling procedure.
56 ; Result is name of calling procedure or #f.
58 (define (find-caller frame)
59 (let ((prev (frame-previous frame)))
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))
66 (let ((name (procedure-name (frame-procedure prev))))
67 (if name name 'lambda))
72 ; Return the current time.
73 ; The result is a black box understood only by elapsed-time.
75 (define (current-time) (gettimeofday))
77 ; Return the elapsed time in milliseconds since START.
79 (define (elapsed-time start)
80 (let ((now (gettimeofday)))
81 (+ (* (- (car now) (car start)) 1000)
82 (quotient (- (cdr now) (cdr start)) 1000)))
85 ; Handle invocation of profiled procedures.
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)))
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))
97 (let* ((caller (find-caller frame))
98 (count-elm (assq caller counts)))
100 (set-cdr! count-elm (1+ (cdr count-elm)))
101 (set-procedure-property! proc 'profile-count
102 (acons caller 1 counts)))))))))
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
112 ; Handle exiting of profiled procedures.
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)
125 (set-procedure-property!
127 (+ (procedure-property proc 'total-time)
128 (elapsed-time (procedure-property proc 'entry-time)))))))
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)
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
139 ; ??? Will eventually want to use a hash table or some such.
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))
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.
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))))
160 (display "Profiling results:\n\n")
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))
177 (display (apply + (map cdr calls)))
178 (display " -- total\n\n"))))