Poor man's profiling attempt...
Friedrich Delgado Friedrichs <[email protected]> Tue, 4 Sep 2007 20:57:42 +0200
| Newsgroups | gmane.comp.java.sisc.user |
|---|---|
| Message-ID | <[email protected]> |
Hiho!
I've recently wrote some code which behaved like a snail on diazepam
and I wanted to know what slowed it down.
So I borrowed some code here and there and came up with the attached
code.
comparator.scm
is just borrowed from
http://sisc-scheme.org/manual/html/ch08.html#JavaProxies to get a list
sorting procedure... Yesterday it dawned on me that there's also at
least one srfi for that purpose included with SISC, but this works
just as well. Put in a seperate file to be able to test it seperately.
profiling.scm
was inspired by https://webmail.iro.umontreal.ca/pipermail/gambit-list/2007-June/001494.html
and a feature request and ensuing discussion on this list, see
http://sourceforge.net/mailarchive/message.php?msg_id=E1FjcVe-00082h-Dq%40sc8-sf-web1.sourceforge.net
This is basically ripped off from sisc/modules/debug.scm and mostly
rewrites all of it verbatim, with very little changes. So this code
should really be merged with debug.scm, after it has matured somewhat.
Therefore I hereby publish this under the same combination of licenses
as SISC itself (MPL and/or GPL).
How to use:
(import s2j)
(import hashtable)
(import misc)
(import procedure-properties)
(load "comparator.scm")
(load "profiling.scm")
Then you can
(profile 'procedure1 'procedure2)
to get some timing and call-tree information for procedure1 and
procedure2. Or if you feel especially daring you can try:
(profile-all!)
which adds profiling hooks too *all* procedures (except a chosen few,
such as apply). If this hangs or crashes, probably the list of
forbidden procedures in profiling.scm needs to be updated.
(unprofile 'procedure1 'procedure2) ;; to turn off profiling for certain
;; procedures.
(unprofile-all!) to restore the old, unprofiled procedures.
(set! *DO-PROFILING* #f) ; to turn profiling off temporarily
(Yes it's a global variable and it will probably cause problems with
threaded code.)
(reset-timer!) ;; resets all collected profiling information
and finally:
(get-times) ;; gets timing and call-tree information sorted by total
;; time
(get-counts) ;; same, sorted by total call count
(get-averages) ;; same, sorted by average time per call
The call graphs are only weighted with counts and will be emitted
sorted by count. If you want to see which procedures where called from
the top-level, you need to evaluate (*current-calls*).
If you have a huge time leak (like I do) it will probably show up
pretty high on all three lists.
There are a few additional caveats, if you want to use it.
- Since this uses the same technique as the tracing code, probably
the same warnings apply, especially tail-calls won't be tail-calls
any more.
- Since the global variable *DO-PROFILING* is used to turn off
profiling for the profiling code itself, multithreading code could
cause errors in the profiling information and/or deadlocks. I've
tried to use a dynamic parameter for that, but I couldn't figure
out how to do it in a way that doesn't mess up the profiling
information
- Since we create a thunk out of the whole call, the procedures
needed to evaluate the parameters of a call will be listed in the
call graph for the procedure. So if you do (profile '< '* '+) and
(< (+ 1 2) (* 3 6)), * and + will appear in the call graph of <.
- Using (profile-all!) for a larger project slows down my code by a
factor of a little below 100. The slowdown will probably scale with
the number of traced procedure calls, not considering the time for
hashtable access. There will be no estimation of the slowdown, so
you have to scale the numbers in your head.
- If you use java 1.4 or earlier, you need to replace (define
real-time nanotime) with (define real-time millitime) in
profiling.scm. And you'll probably need to comment out the
references to nano-time, since it doesn't exist in java <= 1.4.
Since this slows down your code so much, using nanoseconds is
probably pointless anyway.
- I didn't do a lot of reasoning about how this will make your code
behave. I do copy the procedure properties over from generics, so
you can use this with object oriented code as well. There could be
other effects I didn't consider. Also weird things happen if you
use TRACE and PROFILE with the same procedures and forget the order
in which you called them.
So, maybe this helps someone or you have some ideas how to improve
that code.
If someone could write an analyser GUI for the call graphs that would
be extremely neat. :)
Kind regards
FDF
--
Friedrich Delgado Friedrichs <[email protected]>
TauPan on Ircnet and Freenode ;)
-------------------------------------------------------------------------
This SF.net email is sponsored by: Splunk Inc.
Still grepping through log files to find problems? Stop.
Now Search log events and configuration files using AJAX and a browser.
Download your FREE copy of Splunk now >> http://get.splunk.com/
_______________________________________________
Sisc-users mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/sisc-users
comparator.scm
(text/plain, 685 B)
;;; stolen from http://sisc-scheme.org/manual/html/ch08.html#JavaProxies
(define-java-classes
<java.util.comparator>
<java.util.arrays>
<java.lang.object>)
(define-java-proxy (comparator fn)
(<java.util.comparator>)
(define (compare this obj1 obj2)
(let ([x (java-unwrap obj1)]
[y (java-unwrap obj2)])
(->jint (cond [(fn x y) -1]
[(fn y x) +1]
[else 0])))))
(define-generic-java-method sort)
(define-java-class <java.lang.object>)
(define (list-sort fn l)
(let ([a (->jarray (map java-wrap l) <java.lang.object>)])
(sort (java-null <java.util.arrays>) a (comparator fn))
(map java-unwrap (->list a))))
profiling.scm
(text/plain, 7.9 KB)
;;;; record timings and half-automatically instrument bindings
;;; timing recorder, modelled after
;;; https://webmail.iro.umontreal.ca/pipermail/gambit-list/2007-June/001494.html
#|
(import s2j)
(import hashtable)
(import misc)
(import procedure-properties)
(load "comparator.scm")
;;(require-extension (srfi 39)) ;; useless, since sisc includes it by
;;default, but in a broken way, see
;;http://sourceforge.net/tracker/index.php?func=detail&aid=1772170&group_id=23735&atid=379534
|#
(define (make-table)
(make-hashtable eq?))
(define *DO-PROFILING* #t)
(define *current-calls* (make-parameter (make-table)))
(define *timerhash*
(make-table))
(define-java-class <java.lang.system>)
(define-generic-java-methods
current-time-millis
nano-time)
(define java-system (java-null <java.lang.system>))
(define (nanotime)
(->number (nano-time java-system)))
(define (millitime)
(->number (current-time-millis java-system)))
(define real-time nanotime)
(define-simple-syntax (with-profiling flag body1 ...)
(let ((old-profiling *DO-PROFILING*))
(dynamic-wind
(lambda ()
(set! *DO-PROFILING* flag))
(lambda ()
body1
...)
(lambda ()
(set! *DO-PROFILING* old-profiling)))))
(define-simple-syntax (unprofiled body1 ...)
(with-profiling #f body1 ...))
(define-simple-syntax (profiled body1 ...)
(with-profiling #t body1 ...))
(define (reset-timer!)
(unprofiled (hashtable/clear! *timerhash*)
(hashtable/clear! (*current-calls*))))
(define (accum-time name thunk)
(if *DO-PROFILING*
(unprofiled
(let* ((time+count (hashtable/get! *timerhash*
name
(lambda () (list 0 0 (make-table)))))
(timebefore (real-time))
(res (parameterize ((*current-calls* (caddr time+count)))
(profiled (thunk))))
(elapsed-time (- (real-time) timebefore)))
(hashtable/put! (*current-calls*)
name
(+ (hashtable/get! (*current-calls*)
name
(lambda () 0))
1))
(hashtable/put! *timerhash*
name
(list (+ (car time+count) elapsed-time)
(+ (cadr time+count) 1)
(caddr time+count)))
res))
(thunk)))
;; needs list-sort from comparator.scm
(define (sort-list l fn) (list-sort fn l))
(define (get-sorted-results accessor)
(unprofiled
(map
(lambda (el)
(list (car el)
(cadr el)
(caddr el)
(sort-list (hashtable->alist (cadddr el))
(lambda (a b)
(> (cdr a)
(cdr b))))))
(sort-list (hashtable->alist *timerhash*)
(lambda (a b) (> (accessor a)
(accessor b)))))))
(define (get-times)
(get-sorted-results cadr))
(define (get-counts)
(get-sorted-results caddr))
(define (get-averages)
(get-sorted-results
(lambda (x)
(let ((count (caddr x)))
(if (zero? count)
-1
(/ (cadr x)
count))))))
;;; profiling modelled after tracing code in sisc/modules/debug.scm
;;; Idea from
;;; http://sourceforge.net/mailarchive/message.php?msg_id=E1FjcVe-00082h-Dq%40sc8-sf-web1.sourceforge.net
;;; FIXME: This should really be integrated with the tracing code, as
;;; I'm re-writing most of it here
(define *PROFILED-PROCEDURES* (make-hashtable eq?))
(define (make-profiled real-ps proc)
(lambda args
(accum-time real-ps
(lambda ()
(apply proc args)))))
(define (install-profiler real-ps proc)
(let ((profiled-proc (make-profiled real-ps proc)))
(putprop real-ps profiled-proc)
;; copy the properties for generic procedures
(for-each (lambda (property)
(set-procedure-property! profiled-proc
property
(procedure-property proc property)))
(annotation-keys proc))
(cons proc profiled-proc)))
(define (verify-profiled!)
(hashtable/for-each
(lambda (real-ps rest)
(if (not (eq? (cdr rest) (getprop real-ps)))
(let* ([real-ps (sc-expand real-ps)]
[proc (getprop real-ps)])
(if (procedure? proc)
(hashtable/put! *PROFILED-PROCEDURES*
real-ps
(install-profiler real-ps proc))))))
*PROFILED-PROCEDURES*))
(define (profile . procs)
(unprofiled
(verify-profiled!)
(if (null? procs)
(display (format "{currently profiled procedures: ~a}~%"
(hashtable/keys *PROFILED-PROCEDURES*)))
(for-each
(lambda (procedure-symbol)
(let* ([real-ps (sc-expand procedure-symbol)]
[proc (getprop real-ps)])
(if (procedure? proc)
(hashtable/get! *PROFILED-PROCEDURES*
real-ps
(lambda ()
(install-profiler real-ps proc)))
(error 'profile "'~s' is not bound to a procedure."
procedure-symbol))))
procs))))
(define (unprofile . procs)
(unprofiled
(verify-profiled!)
(if (null? procs)
(display (format "{currently profiled procedures: ~a}~%"
(hashtable/keys *PROFILED-PROCEDURES*)))
(for-each
(lambda (procedure-symbol)
(let* ([real-ps (sc-expand procedure-symbol)]
[proc (hashtable/remove! *PROFILED-PROCEDURES* real-ps)])
(if proc
(when (eq? (cdr proc) (getprop real-ps))
(putprop real-ps (car proc)))
(error 'unprofile "~a is not bound to a profiled procedure."
procedure-symbol))))
procs))))
;;;; Get all bindings from an environment
(define-generic-java-field-accessors :symbol-map)
(define-generic-java-methods
key-set
to-array
get-parent)
(define (list-bindings . rest)
(let ((env (if (null? rest)
(java-wrap (interaction-environment))
(car rest))))
(let accum
((env env)
(sofar '()))
(if (java-null? env)
sofar
(accum (get-parent env)
(append sofar
(map java-unwrap
(->list
(to-array
(key-set
(:symbol-map
env)))))))))))
(define (forbidden-procedures)
(list $sc-put-cte
apply
dynamic-wind
*current-calls*
nanotime
millitime
real-time
reset-timer!
accum-time
sort-list
get-sorted-results
get-times
get-counts
make-profiled
install-profiler
verify-profiled!
profile
unprofile
when-proc+allowed
profile-all!
unprofile-all!))
(define (when-proc+allowed proc)
(lambda (p)
(with-failure-continuation
(lambda (e k)
(void))
(lambda ()
(if (let ((realproc (getprop (sc-expand p))))
(and (procedure? realproc)
(not (memq realproc (forbidden-procedures)))))
(proc p))))))
(define (profile-all!)
(unprofiled
(for-each (when-proc+allowed
(lambda (p)
(format #t "Profiling: ~a~%" p)
(profile p)))
(list-bindings))))
(define (unprofile-all!)
(unprofiled
(hashtable/for-each (lambda (real-ps rest)
(format #t "Unprofiling: ~a~%" real-ps)
(unprofile real-ps))
*PROFILED-PROCEDURES*)))
signature.asc
(application/pgp-signature, 197 B)
-----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.6 (GNU/Linux) iEYEARECAAYFAkbdqqYACgkQCTmCEtF2zECJ7wCgmvQjxE7sWmtZ6tP/O5O9PnoV oLoAn1VnS/e/5BPS7hZ36msylwGJLR+w =hbEL -----END PGP SIGNATURE-----