profile.scm from Gdb at Krugle
Show profile.scm syntax highlighted
;;; {Profile}
;;;
;;; This code is just an experimental prototype (e. g., it is not
;;; thread safe), but since it's at the same time useful, it's
;;; included anyway.
;;;
;;; This is copied from the tracing support in debug.scm.
;;; If merged into the main distribution it will need an efficiency
;;; and layout cleanup pass.
; FIXME: Prefix "proc-" added to not collide with cgen stuff.
; Put this stuff in the debug module since we need the trace facilities.
(define-module (ice-9 profile) :use-module (ice-9 debug))
(define profiled-procedures '())
(define-public (profile-enable . args)
(if (null? args)
(nameify profiled-procedures)
(begin
(for-each (lambda (proc)
(if (not (procedure? proc))
(error "profile: Wrong type argument:" proc))
; `trace' is a magic property understood by guile
(set-procedure-property! proc 'trace #t)
(if (not (memq proc profiled-procedures))
(set! profiled-procedures
(cons proc profiled-procedures))))
args)
(set! apply-frame-handler profile-entry)
(set! exit-frame-handler profile-exit)
(debug-enable 'trace)
(nameify args))))
(define-public (profile-disable . args)
(if (and (null? args)
(not (null? profiled-procedures)))
(apply profile-disable profiled-procedures)
(begin
(for-each (lambda (proc)
(set-procedure-property! proc 'trace #f)
(set! profiled-procedures (delq! proc profiled-procedures)))
args)
(if (null? profiled-procedures)
(debug-disable 'trace))
(nameify args))))
(define (nameify ls)
(map (lambda (proc)
(let ((name (procedure-name proc)))
(or name proc)))
ls))
; Subroutine of profile-entry to find the calling procedure.
; Result is name of calling procedure or #f.
(define (find-caller frame)
(let ((prev (frame-previous frame)))
(if prev
; ??? Not sure this is right. The goal is to find the real "caller".
(if (and (frame-procedure? prev)
;(or (frame-real? prev) (not (frame-evaluating-args? prev)))
(not (frame-evaluating-args? prev))
)
(let ((name (procedure-name (frame-procedure prev))))
(if name name 'lambda))
(find-caller prev))
'top-level))
)
; Return the current time.
; The result is a black box understood only by elapsed-time.
(define (current-time) (gettimeofday))
; Return the elapsed time in milliseconds since START.
(define (elapsed-time start)
(let ((now (gettimeofday)))
(+ (* (- (car now) (car start)) 1000)
(quotient (- (cdr now) (cdr start)) 1000)))
)
; Handle invocation of profiled procedures.
(define (profile-entry key cont tail)
(if (eq? (stack-id cont) 'repl-stack)
(let* ((stack (make-stack cont))
(frame (stack-ref stack 0))
(proc (frame-procedure frame)))
(if proc
; procedure-property returns #f if property not present
(let ((counts (procedure-property proc 'profile-count)))
(set-procedure-property! proc 'entry-time (current-time))
(if counts
(let* ((caller (find-caller frame))
(count-elm (assq caller counts)))
(if count-elm
(set-cdr! count-elm (1+ (cdr count-elm)))
(set-procedure-property! proc 'profile-count
(acons caller 1 counts)))))))))
; SCM_TRACE_P is reset each time by the interpreter
;(display "entry\n" (current-error-port))
(debug-enable 'trace)
;; It's not necessary to call the continuation since
;; execution will continue if the handler returns
;(cont #f)
)
; Handle exiting of profiled procedures.
(define (profile-exit key cont retval)
;(display "exit\n" (current-error-port))
(display (list key cont retval)) (newline)
(display (stack-id cont)) (newline)
(if (eq? (stack-id cont) 'repl-stack)
(let* ((stack (make-stack cont))
(frame (stack-ref stack 0))
(proc (frame-procedure frame)))
(display stack) (newline)
(display frame) (newline)
(if proc
(set-procedure-property!
proc 'total-time
(+ (procedure-property proc 'total-time)
(elapsed-time (procedure-property proc 'entry-time)))))))
; ??? Need to research if we have to do this or not.
; SCM_TRACE_P is reset each time by the interpreter
(debug-enable 'trace)
)
; Called before something is to be profiled.
; All desired procedures to be profiled must have been previously selected.
; Property `profile-count' is an association list of caller name and call
; count.
; ??? Will eventually want to use a hash table or some such.
(define-public (profile-init)
(for-each (lambda (proc)
(set-procedure-property! proc 'profile-count '())
(set-procedure-property! proc 'total-time 0))
profiled-procedures)
)
; Called after execution to print profile counts.
; If ARGS contains 'all, stats on all profiled procs are printed, not just
; those that were actually called.
(define-public (profile-stats . args)
(let ((stats (map (lambda (proc)
(cons (procedure-name proc)
(procedure-property proc 'profile-count)))
profiled-procedures))
(all? (memq 'all args))
(sort (if (defined? 'sort) (local-ref '(sort)) (lambda args args))))
(display "Profiling results:\n\n")
; Print the procs in sorted order.
(let ((stats (sort stats (lambda (a b) (string<? (car a) (car b))))))
(for-each (lambda (proc-stats)
(if (or all? (not (null? (cdr proc-stats))))
; Print by decreasing frequency.
(let ((calls (sort (cdr proc-stats) (lambda (a b) (> (cdr a) (cdr b))))))
(display (string-append (car proc-stats) "\n"))
(for-each (lambda (call)
(display (string-append " "
(number->string (cdr call))
" "
(car call)
"\n")))
calls)
(display " ")
(display (apply + (map cdr calls)))
(display " -- total\n\n"))))
stats)))
)
See more files for this project here