[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-162-ge1138ba

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e1138ba1995f970083ad752f1ff8f71876483194

The branch, master has been updated
       via  e1138ba1995f970083ad752f1ff8f71876483194 (commit)
      from  7055591c2e9ba97b9a5d1c15a3b7e1ce409966f5 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit e1138ba1995f970083ad752f1ff8f71876483194
Author: Andy Wingo <address@hidden>
Date:   Thu Jan 14 22:52:07 2010 +0100

    fix call counting in statprof, enhance repl support
    
    * module/statprof.scm: Use VM modules, instead of using @ hacks.
      (statprof): New public export, a functional interface to the profiler.
      (profile-signal-handler, count-call, statprof-start, statprof-stop):
      Fix call counting with the VM.
      (statprof-call-data->stats): Hack around a case in which a call could
      be sampled but not counted, if you get my drift.
      (procedure=?): Update for current API.
      (with-statprof): Use `statprof'.
    
    * module/system/repl/command.scm (profile): Use the `statprof'
      procedural interface.

-----------------------------------------------------------------------

Summary of changes:
 module/statprof.scm            |  114 +++++++++++++++++++++++-----------------
 module/system/repl/command.scm |    2 +-
 2 files changed, 67 insertions(+), 49 deletions(-)

diff --git a/module/statprof.scm b/module/statprof.scm
index 8d6f731..5a1315b 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -1,7 +1,7 @@
 ;;;; (statprof) -- a statistical profiler for Guile
 ;;;; -*-scheme-*-
 ;;;;
-;;;;   Copyright (C) 2009  Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009, 2010  Free Software Foundation, Inc.
 ;;;;    Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
 ;;;;    Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
 ;;;; 
@@ -126,6 +126,9 @@
 (define-module (statprof)
   #:use-module (srfi srfi-1)
   #:autoload   (ice-9 format) (format)
+  #:use-module (system vm vm)
+  #:use-module (system vm frame)
+  #:use-module (system vm program)
   #:export (statprof-active?
             statprof-start
             statprof-stop
@@ -155,6 +158,7 @@
             statprof-fetch-stacks
             statprof-fetch-call-tree
 
+            statprof
             with-statprof))
 
 
@@ -285,7 +289,9 @@
               ;; and eliminate inside-profiler? because it seems to
               ;; confuse guile wrt re-enabling the trap when
               ;; count-call finishes.
-              (if %count-calls? (trap-disable 'apply-frame))
+              (if %count-calls?
+                  (set-vm-trace-level! (the-vm)
+                                       (1- (vm-trace-level (the-vm)))))
               (accumulate-time stop-time)))
         
         (setitimer ITIMER_PROF
@@ -296,19 +302,21 @@
         (if (not inside-apply-trap?)
             (begin
               (set! last-start-time (get-internal-run-time))
-              (if %count-calls? (trap-enable 'apply-frame))))))
-
+              (if %count-calls?
+                  (set-vm-trace-level! (the-vm)
+                                       (1+ (vm-trace-level (the-vm)))))))))
+  
   (set! inside-profiler? #f))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Count total calls.
 
-(define (count-call trap-name continuation tail)
+(define (count-call frame)
   (if (not inside-profiler?)
       (begin
         (accumulate-time (get-internal-run-time))
 
-        (and=> (frame-procedure (last-stack-frame continuation))
+        (and=> (frame-procedure frame)
                (lambda (proc)
                  (inc-call-data-call-count!
                   (get-call-data proc))))
@@ -343,7 +351,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
                        0 0
                        (car sampling-frequency)
                        (cdr sampling-frequency)))
-        (trap-enable 'apply-frame)
+        (add-hook! (vm-apply-hook (the-vm)) count-call)
+        (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
         #t)))
   
 ;; Do not call this from statprof internal functions -- user only.
@@ -356,7 +365,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
       (begin
         (set! gc-time-taken
               (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
-        (trap-disable 'apply-frame)
+        (set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
+        (remove-hook! (vm-apply-hook (the-vm)) count-call)
         ;; I believe that we need to do this before getting the time
         ;; (unless we want to make things even more complicated).
         (set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
@@ -381,10 +391,6 @@ Enables traps and debugging as necessary."
   (set! sampling-frequency (cons sample-seconds sample-microseconds))
   (set! remaining-prof-time #f)
   (set! procedure-data (make-hash-table 131))
-  (if %count-calls?
-      (begin
-        (trap-set! apply-frame-handler count-call)
-        (trap-enable 'traps)))
   (set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?)))
   (set! stacks '())
   (debug-enable 'debug)
@@ -445,7 +451,11 @@ none is available."
                  (if (zero? self-samples) 0.0
                      (/ (* self-samples secs-per-sample) 1.0 num-calls)))
             (and num-calls ;; cum-samples must be positive
-                 (/ (* cum-samples secs-per-sample) 1.0 num-calls)))))
+                 (/ (* cum-samples secs-per-sample)
+                    1.0
+                    ;; num-calls might be 0 if we entered statprof during the
+                    ;; dynamic extent of the call
+                    (max num-calls 1))))))
 
 (define (statprof-stats-proc-name stats) (vector-ref stats 0))
 (define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1))
@@ -484,7 +494,7 @@ optional @var{port} argument is passed, uses the current 
output port."
 
       (define (display-stats-line stats)
         (if %count-calls?
-            (format  port "~6,2f ~9,2f ~9,2f ~8r ~8,2f ~8,2f  "
+            (format  port "~6,2f ~9,2f ~9,2f ~7d ~8,2f ~8,2f  "
                      (statprof-stats-%-time-in-proc stats)
                      (statprof-stats-cum-secs-in-proc stats)
                      (statprof-stats-self-secs-in-proc stats)
@@ -565,14 +575,8 @@ to @code{statprof-reset} is true."
       (lambda (a b)
         (cond
          ((eq? a b))
-         ((and ((@ (system vm program) program?) a)
-               ((@ (system vm program) program?) b))
-          (eq? ((@ (system vm program) program-objcode) a)
-               ((@ (system vm program) program-objcode) b)))
-         ((and (closure? a) (closure? b)
-               (procedure-source a) (procedure-source b))
-          (and (eq? (procedure-name a) (procedure-name b))
-               (equal? (procedure-source a) (procedure-source b))))
+         ((and (program? a) (program? b))
+          (eq? (program-objcode a) (program-objcode b)))
          (else
           #f)))
       (lambda (a b)
@@ -629,6 +633,39 @@ The return value is a list of nodes, each of which is of 
the type:
 @end code"
   (cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
 
+(define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
+                   (full-stacks? #f))
+  "Profiles the execution of @var{thunk}.
+
+The stack will be sampled @var{hz} times per second, and the thunk itself will
+be called @var{loop} times.
+
+If @var{count-calls?} is true, all procedure calls will be recorded. This
+operation is somewhat expensive.
+
+If @var{full-stacks?} is true, at each sample, statprof will store away the
+whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
address@hidden to retrieve the last-stored stacks."
+  
+  (dynamic-wind
+    (lambda ()
+      (statprof-reset (inexact->exact (floor (/ 1 hz)))
+                      (inexact->exact (* 1e6 (- (/ 1 hz)
+                                                (floor (/ 1 hz)))))
+                      count-calls?
+                      full-stacks?)
+      (statprof-start))
+    (lambda ()
+      (let lp ((i loop))
+        (if (not (zero? i))
+            (begin
+              (thunk)
+              (lp (1- i))))))
+    (lambda ()
+      (statprof-stop)
+      (statprof-display)
+      (set! procedure-data #f))))
+
 (define-macro (with-statprof . args)
   "Profiles the expressions in its body.
 
@@ -662,29 +699,10 @@ default: @code{#f}
      ((eq? kw #f def) ;; asking for the body
       args)
      (else def))) ;; kw not found
-  (let ((loop (kw-arg-ref #:loop args #f))
-        (hz (kw-arg-ref #:hz args 20))
-        (count-calls? (kw-arg-ref #:count-calls? args #f))
-        (full-stacks? (kw-arg-ref #:full-stacks? args #f))
-        (body (kw-arg-ref #f args #f)))
-    `(dynamic-wind
-         (lambda ()
-            (statprof-reset (inexact->exact (floor (/ 1 ,hz)))
-                            (inexact->exact (* 1e6 (- (/ 1 ,hz)
-                                                      (floor (/ 1 ,hz)))))
-                            ,count-calls?
-                            ,full-stacks?)
-            (statprof-start))
-         (lambda ()
-           ,(if loop
-                (let ((lp (gensym "statprof ")) (x (gensym)))
-                  `(let ,lp ((,x ,loop))
-                        (if (not (zero? ,x))
-                            (begin ,@body (,lp (1- ,x))))))
-                `(begin ,@body)))
-         (lambda ()
-            (statprof-stop)
-            (statprof-display)
-            (set! (@@ (statprof) procedure-data) #f)))))
-
-;;; arch-tag: 83969178-b576-4c52-a31c-6a9c2be85d10
+  `((@ (statprof) statprof)
+    (lambda () ,@(kw-arg-ref #f args #f))
+    #:loop ,(kw-arg-ref #:loop args 1)
+    #:hz ,(kw-arg-ref #:hz args 100)
+    #:count-calls? ,(kw-arg-ref #:count-calls? args #f)
+    #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
+
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 5626e1f..ae8568a 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -360,7 +360,7 @@ Profile execution."
   ;; FIXME opts
   (let ((vm (repl-vm repl))
         (proc (make-program (repl-compile repl (repl-parse repl form)))))
-    (with-statprof #:hz 100 (vm-apply vm proc '()))))
+    (apply statprof (lambda () (vm-apply vm proc '())) opts)))
 
 
 


hooks/post-receive
-- 
GNU Guile