2 ;;; Copyright (C) 2009 Red Hat, Inc.
3 ;;; This file is part of CGEN.
4 ;;; See file COPYING.CGEN for details.
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
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.
14 ; FIXME: Prefix "proc-" added to not collide with cgen stuff.
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))
19 (define profiled-procedures '())
21 (define-public (profile-enable . args)
23 (nameify profiled-procedures)
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))))
34 (set! apply-frame-handler profile-entry)
35 (set! exit-frame-handler profile-exit)
39 (define-public (profile-disable . args)
41 (not (null? profiled-procedures)))
42 (apply profile-disable profiled-procedures)
44 (for-each (lambda (proc)
45 (set-procedure-property! proc 'trace #f)
46 (set! profiled-procedures (delq! proc profiled-procedures)))
48 (if (null? profiled-procedures)
49 (debug-disable 'trace))
54 (let ((name (procedure-name proc)))
58 ; Subroutine of profile-entry to find the calling procedure.
59 ; Result is name of calling procedure or #f.
61 (define (find-caller frame)
62 (let ((prev (frame-previous frame)))
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))
69 (let ((name (procedure-name (frame-procedure prev))))
70 (if name name 'lambda))
75 ; Return the current time.
76 ; The result is a black box understood only by elapsed-time.
78 (define (current-time) (gettimeofday))
80 ; Return the elapsed time in milliseconds since START.
82 (define (elapsed-time start)
83 (let ((now (gettimeofday)))
84 (+ (* (- (car now) (car start)) 1000)
85 (quotient (- (cdr now) (cdr start)) 1000)))
88 ; Handle invocation of profiled procedures.
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)))
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))
100 (let* ((caller (find-caller frame))
101 (count-elm (assq caller counts)))
103 (set-cdr! count-elm (1+ (cdr count-elm)))
104 (set-procedure-property! proc 'profile-count
105 (acons caller 1 counts)))))))))
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
115 ; Handle exiting of profiled procedures.
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)
128 (set-procedure-property!
130 (+ (procedure-property proc 'total-time)
131 (elapsed-time (procedure-property proc 'entry-time)))))))
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)
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
142 ; ??? Will eventually want to use a hash table or some such.
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))
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.
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))))
163 (display "Profiling results:\n\n")
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))
180 (display (apply + (map cdr calls)))
181 (display " -- total\n\n"))))