From: Andy Wingo <wingo@pobox.com>
Date: Thu, 22 Jan 2015 13:37:18 +0000 (+0100)
Subject: Merge commit 'cdcba5b2f6270de808e51b3b933374170611b91d'
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/6f248df1f67cfc18b210a431d540077f9f4b8da2

Merge commit 'cdcba5b2f6270de808e51b3b933374170611b91d'

Conflicts:
	module/statprof.scm
---

6f248df1f67cfc18b210a431d540077f9f4b8da2
diff --cc module/statprof.scm
index 961f769e4,cb8834011..e613aad2d
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@@ -1,7 -1,7 +1,7 @@@
  ;;;; (statprof) -- a statistical profiler for Guile
  ;;;; -*-scheme-*-
  ;;;;
- ;;;; 	Copyright (C) 2009, 2010, 2011, 2013, 2014  Free Software Foundation, Inc.
 -;;;; 	Copyright (C) 2009, 2010, 2011, 2015  Free Software Foundation, Inc.
++;;;; 	Copyright (C) 2009, 2010, 2011, 2013-2015  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>
  ;;;; 
@@@ -808,60 -628,44 +808,62 @@@ The return value is a list of nodes, ea
  @code
   node ::= (@var{proc} @var{count} . @var{nodes})
  @end code"
 -  (cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
 +  (define (callee->printable callee)
 +    (cond
 +     ((number? callee)
 +      (addr->printable callee (find-program-debug-info callee)))
 +     (else
 +      (with-output-to-string (lambda () (write callee))))))
 +  (define (memoizev/1 proc table)
 +    (lambda (x)
 +      (cond
 +       ((hashv-get-handle table x) => cdr)
 +       (else
 +        (let ((res (proc x)))
 +          (hashv-set! table x res)
 +          res)))))
 +  (let ((callee->printable (memoizev/1 callee->printable (make-hash-table))))
 +    (cons #t (lists->trees (map (lambda (callee-list)
 +                                  (map callee->printable callee-list))
 +                                (stack-samples->callee-lists state))
 +                           equal?))))
 +
 +(define (call-thunk thunk)
-   (thunk)
-   (values))
++  (call-with-values (lambda () (thunk))
++    (lambda results
++      (apply values results))))
  
  (define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
 -                   (full-stacks? #f))
 +                   (port (current-output-port)) full-stacks?)
-   "Profiles the execution of @var{thunk}.
+   "Profile the execution of @var{thunk}, and return its return values.
  
- The stack will be sampled @var{hz} times per second, and the thunk itself will
- be called @var{loop} times.
+ 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
 -@code{statprof-fetch-call-tree} 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)
 -               (result '()))
 -        (if (zero? i)
 -            (apply values result)
 -            (call-with-values thunk
 -              (lambda result
 -                (lp (1- i) result))))))
 -    (lambda ()
 -      (statprof-stop)
 -      (statprof-display)
 -      (set! procedure-data #f))))
 +operation is somewhat expensive."
 +  
 +  (let ((state (fresh-profiler-state #:count-calls? count-calls?
 +                                     #:sampling-period
 +                                     (inexact->exact (round (/ 1e6 hz)))
 +                                     #:outer-cut
 +                                     (program-address-range call-thunk))))
 +    (parameterize ((profiler-state state))
 +      (dynamic-wind
 +        (lambda ()
 +          (statprof-start state))
 +        (lambda ()
 +          (let lp ((i loop))
-             (unless (zero? i)
++            (unless (= i 1)
 +              (call-thunk thunk)
-               (lp (1- i)))))
++              (lp (1- i))))
++          (call-thunk thunk))
 +        (lambda ()
 +          (statprof-stop state)
 +          (statprof-display port state))))))
  
  (define-macro (with-statprof . args)
-   "Profiles the expressions in its body.
+   "Profile the expressions in the body, and return the body's return values.
  
  Keyword arguments: