This is the mail archive of the guile@cygnus.com mailing list for the guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

Here's a guile profiling tool/a question/a *remarkable* guile fact (was Re: Guile profiling tools?)


Christian Lynbech <lynbech@tbit.dk> writes:

 > >>>>> "Jim" == Jim Blandy <jimb@red-bean.com> writes:
 > 
 > Jim> I'd encourage folks to take a stab at this; post your code to the
 > Jim> list.
 > 
 > I am working at a simple solution, using Harvey Steins excellent idea
 > about hooking into the trace facility. I'll post my results when I
 > have something working, presumably during this weekend.
 > 
 > My current code will only profile functions that have been explicitly
 > instrumented (having the trace property set to true), which isn't
 > perfect but better than nothing (and it will instrument whole modules
 > in one fell swoop, so it isn't that bad).
 > 
 > Harvey Stein was asking why only functions with the trace property
 > would be traced. Having spent some time yesterday on the issue
 > (substituting experiments for philosophical reasoning) the answer
 > seems to be that enabling tracing on *every* apply would yield an
 > infinite loop since the trace handler (and surrounding facilities such
 > as the repl) would need to do applys also. If this is to work, there
 > needs to be some mechanism that would allow the code in the evaluator
 > to decide when to trace the apply and when not to. Ideas are welcome.

What I really meant was where in the code is it taken into effect.  I
wanted to know a little more about what exactly is possible with the
tracing facility.

BTW, I got my wrapping code working with guile.  It's appended below.

Using it, I discovered that the sgml output time from extract.scm was
almost all in the following function:

(define (sgml-markup s)
  (define proc-regexp (make-regexp "`([^'` \t]*)'"))
  (define tf-regexp (make-regexp "(#[tf])"))
  (my-regexp-substitute/global
   #f
   tf-regexp
   (my-regexp-substitute/global #f
				proc-regexp
				s
				`pre
				"<link linkend=\"" 
				(lambda (m) (sgml-escape-xref
				(match:substring m 1)))
				"\"><function>"
				1
				"</function></link>" `post)
   `pre "<literal>" 1 "</literal>" `post))

I also found the following startling fact:

guile> (with-profiling (sgml sgml-markup sgml-render-start sgml-render-end my-regexp-substitute/global sgml-escape-xref make-regexp) (with-output-to-file "foo" (lambda () (sgml s))))
Function            Called     Time
------------------- ---------- ---------
make-regexp             2564.0     2.130
sgml-escape-xref          20.0     0.070
my-regexp-substitute/global    5128.0    13.770
sgml-render-end         1594.0     0.240
sgml-render-start       1594.0     0.270
sgml-markup             1272.0    25.440
sgml                    2866.0    27.190

defines inside of defines are *not* just being evaluated at load
time!!!!!  I find this truly remarkable!  Why is this!?!?!?!?


;;; wrappers.scm - Library for wrapping functions & executing forms.
;;;                Useful for implementing tracing & profiling (as is
;;;                done here).
;;;                Version 0.8
;;;
;;; Copyright (c) 1995 Harvey J. Stein (hjstein@math.huji.ac.il)
;;; This code is GPLed.  For more info
;;;
;;; Usage:
;;;   For tracing:
;;;      (with-tracing (foo bar baz) (baz 19))
;;;      Executes (baz 19), while tracing entries to & exits from foo,
;;;      bar & baz.
;;;
;;;   For profiling:
;;;      (with-profiling ...)
;;;      Same story, but keeps track of execution times and prints
;;;      results at end.
;;;
;;;   In general:
;;;      (with-wrappers wrapper starter ender simlist form)
;;;      wrapper should be a function which takes 2 args, a symbol & a
;;;      fcn.  It should return a fcn.  Starter & ender are thunks.
;;;      Simlist is a list of symbols.  Form is an sexp to evaluate.
;;;      Basically, the defn of all symbols s in simlist are replaced with
;;;      (wrapper 's s).  Then starter is called, form is executed,
;;;      ender is called, and the result of form is returned.  The
;;;      execution of ender is guaranteed by the use of dynamic-wind.
;;;      Undoing the damage of wrapper is guaranteed by fluid-let.

;;; Bugs/To do:
;;;   -Requires call to clock to be added to Stk - I added it to
;;;    posix, even though it's not really posix (but it is ANSI C).
;;;    If clock doesn't exist, I use the time from
;;;    (get-internal-info).  But, this causes lots of extra consing
;;;    (and extra time taken up in the profiling).
;;;   -How can I wrap symbols defined in children environments?
;;;   -Would be nice to add some more statistics to the profiling
;;;    (such as # of cells consed, etc).
;;;   -Profiling should also figure out how much time of the time
;;;    spent in a subroutine is actually spent amongst the children... 
;;;   -Maybe dynamic-wind should also be used in wrappers - On the one
;;;    hand this would enable tracing to track continuation usage, but
;;;    on the other hand, it might introduce alot of overhead.

(if (not (member "/usr/lib" %load-path))
    (set! %load-path (cons "/usr/lib" %load-path))) ; HACK for guile to find slib!!!!!!!
(use-modules (ice-9 slib))
(require 'format)

(define-macro (with-wrappers wrapper starter ender symlist form)
  (let ((oldsym (map (lambda (sym) (gensym)) symlist)))
    `(let ,(map (lambda (old sym)
		  (list old sym))
		oldsym
		symlist)
       (dynamic-wind (lambda ()
		       (,starter)
		       ,@(map (lambda (sym)
				`(set! ,sym (,wrapper ',sym ,sym)))
			      symlist))
		     (lambda ()
		       ,form)
		     (lambda ()
		       ,@(map (lambda (sym old)
				`(set! ,sym ,old))
			      symlist oldsym)
		       (,ender))))))

;;; ----------- Tracing code ------------------

(define-macro (with-tracing simlist form)
  `(with-wrappers trace:trace-wrap trace:trace-start (lambda () ())
		  ,simlist ,form))

(define trace:trace-start #f)
(define trace:trace-wrap #f)
(define trace:start #f)
(define trace:end #f)
(define trace:header #f)

;;; Trying to be safe in the face of the user wrapping these fcns, but
;;; I didn't quite make it - it didn't seem to work.
(let ((set! set!)
      (lambda lambda)
      (let let)
      (apply apply)
      (format format)
      (cons cons)
      (+ +)
      (1+ 1+)
      (length length)
      (>= >=)
      (*trace-stack* '()))


(define (loc-trace:trace-start)
  (set! *trace-stack* ()))

(define (loc-trace:trace-wrap name func)
  (lambda l
    (loc-trace:start name l)
    (let ((res (apply func l)))
      (loc-trace:end name l res)
      res)))

(define (loc-trace:start name l)
  (loc-trace:header)
  (format #t "~s\n" (cons name l))
  (set! *trace-stack* (cons name *trace-stack*)))

(define (loc-trace:end name l res)
  (set! *trace-stack* (cdr *trace-stack*))
  (loc-trace:header)
  (format #t "~s = ~s\n" (cons name l) res))

(define (loc-trace:header)
  (do ((i 0 (1+ i))
       (end (length *trace-stack*)))
      ((>= i end))
    (format #t "| ")))

(set! trace:trace-start loc-trace:trace-start)
(set! trace:trace-wrap loc-trace:trace-wrap)
(set! trace:start loc-trace:start)
(set! trace:end loc-trace:end)
(set! trace:header loc-trace:header ))


;;; ----------- Profiling code ------------------

(define (profile:hash-table-for-each table func)
  (for-each (lambda (d) (func (car d) (cdr d))) (cdr table)))

(define (profile:make-hash-table)
  (list 'hash-table))

(define (profile:hash-table-put! table key val)
  (let ((v (assoc key (cdr table))))
    (if v
	(set-cdr! v val)
	(set-cdr! table (cons (cons key val) (cdr table))))))


(define (profile:clock)
  (/ (get-internal-run-time)
     internal-time-units-per-second))

(define-macro (with-profiling simlist form)
  `(with-wrappers profile:profile-wrap
		  profile:profile-start
		  profile:profile-end
		  ,simlist ,form))


(define *profile-stack* #f)
(define *profile-times* #f)

(define (profile:profile-start)
  (set! *profile-stack* ())
  (set! *profile-times* (profile:make-hash-table)))

(define (formout:make-fmt-fcn s)
  (lambda (p . args) (apply format p s args)))

(define (profile:profile-end)
  (define funccol   (formout:make-fmt-fcn "~20a"))
  (define calledcol (formout:make-fmt-fcn "~10f"))
  (define timecol   (formout:make-fmt-fcn "~10,3f"))
  (format #t "Function            Called     Time\n")
  (format #t "------------------- ---------- ---------\n")
  (profile:hash-table-for-each *profile-times*
			       (lambda (func prof-data)
				 (funccol   #t (symbol->string func))
				 (calledcol #t (profile:times-called prof-data))
				 (timecol   #t (profile:elapsed-time prof-data))
				 (format #t "\n"))))
				 
			 
(define (profile:times-called v)
  (vector-ref v 0))

(define (profile:elapsed-time v)
  (vector-ref v 1))

(define (profile:profile-wrap name func)
  (let ((results (make-vector 10 0)))
    (let ((res ())
	  (time -1))
      (profile:hash-table-put! *profile-times* name results)
      (lambda l
	(cond ((< time 0)
	       (set! time (profile:clock))
	       (set! res (apply func l))
	       (vector-set! results 1 (+ (vector-ref results 1)
					 (- (profile:clock) time)))
	       (vector-set! results 0 (1+ (vector-ref results 0)))
	       (set! time -1)
	       res)
	      (else
	       (set! res (apply func l))
	       (vector-set! results 0 (1+ (vector-ref results 0)))
	       res))))))
	       

-- 
Harvey J. Stein
BFM Financial Research
hjstein@bfr.co.il