,profile, statprof, gcprof have an outer stack cut

* module/statprof.scm (<state>): Add outer-cut member.
  (fresh-profiler-state): Add outer-cut kwarg.
  (sample-stack-procs): Stop when the stack-length is zero, which will
  be before the frames run out if there is an outer cut.
  (profile-signal-handler): Use the outer cut when capturing the stack.
  (call-thunk): New helper, for use as an outer cut.
  (statprof, gcprof): Call the thunk within call-thunk, and use
  call-thunk as an outer cut.

1 files changed, 28 insertions, 22 deletions

diff --git a/module/statprof.scm b/module/statprof.scm
index 760235a4b..cf3532eac 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -240,7 +240,7 @@
   (make-state accumulated-time last-start-time sample-count
               sampling-period remaining-prof-time profile-level
               call-counts gc-time-taken inside-profiler?
-              prev-sigprof-handler buffer buffer-pos)
+              prev-sigprof-handler outer-cut buffer buffer-pos)
   state?
   ;; Total time so far.
   (accumulated-time accumulated-time set-accumulated-time!)
@@ -260,8 +260,10 @@
   (gc-time-taken gc-time-taken set-gc-time-taken!)
   ;; True if we are inside the profiler.
   (inside-profiler? inside-profiler? set-inside-profiler?!)
-  ;; True if we are inside the profiler.
+  ;; Previous sigprof handler.
   (prev-sigprof-handler prev-sigprof-handler set-prev-sigprof-handler!)
+  ;; Outer stack cut, or 0.
+  (outer-cut outer-cut)
   ;; Stack samples.
   (buffer buffer set-buffer!)
   (buffer-pos buffer-pos set-buffer-pos!))
@@ -278,11 +280,12 @@
     new))
 
 (define* (fresh-profiler-state #:key (count-calls? #f)
-                               (sampling-period 10000))
+                               (sampling-period 10000)
+                               (outer-cut 0))
   (make-state 0 #f 0
               sampling-period 0 0
               (and count-calls? (make-hash-table)) 0 #f
-              #f (fresh-buffer) 0))
+              #f outer-cut (fresh-buffer) 0))
 
 (define (ensure-profiler-state)
   (or (profiler-state)
@@ -306,19 +309,20 @@
   (set-sample-count! state (+ (sample-count state) 1))
 
   (let lp ((frame (stack-ref stack 0))
+           (len (stack-length stack))
            (buffer (buffer state))
            (pos (buffer-pos state)))
     (define (write-sample sample)
       (vector-set! buffer pos sample))
     (define (continue pos)
-      (lp (frame-previous frame) buffer pos))
+      (lp (frame-previous frame) (1- len) buffer pos))
     (define (write-sample-and-continue sample)
       (write-sample sample)
       (continue (1+ pos)))
     (cond
      ((= pos (vector-length buffer))
-      (lp frame (expand-buffer buffer) pos))
-     ((not frame)
+      (lp frame len (expand-buffer buffer) pos))
+     ((or (zero? len) (not frame))
       (write-sample #f)
       (set-buffer! state buffer)
       (set-buffer-pos! state (1+ pos)))
@@ -338,17 +342,15 @@
 
   (set-inside-profiler?! state #t)
 
-  ;; FIXME: with-statprof should be able to set an outer frame for the
-  ;; stack cut
   (when (positive? (profile-level state))
     (let* ((stop-time (get-internal-run-time))
-           ;; cut down to the signal handler. note that this will only
-           ;; work if statprof.scm is compiled; otherwise we get
-           ;; `eval' on the stack instead, because if it's not
-           ;; compiled, profile-signal-handler is a thunk that
-           ;; tail-calls eval. perhaps we should always compile the
-           ;; signal handler instead...
-           (stack (or (make-stack #t profile-signal-handler)
+           ;; Cut down to the signal handler.  Note that this will only
+           ;; work if statprof.scm is compiled; otherwise we get `eval'
+           ;; on the stack instead, because if it's not compiled,
+           ;; profile-signal-handler is a thunk that tail-calls eval.
+           ;; Perhaps we should always compile the signal handler
+           ;; instead.
+           (stack (or (make-stack #t profile-signal-handler (outer-cut state))
                       (pk 'what! (make-stack #t)))))
 
       (sample-stack-procs state stack)
@@ -815,6 +817,10 @@ The return value is a list of nodes, each of which is of the type:
                                 (stack-samples->callee-lists state))
                            equal?))))
 
+(define (call-thunk thunk)
+  (thunk)
+  (values))
+
 (define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
                    (port (current-output-port)) full-stacks?)
   "Profiles the execution of @var{thunk}.
@@ -827,7 +833,8 @@ operation is somewhat expensive."
   
   (let ((state (fresh-profiler-state #:count-calls? count-calls?
                                      #:sampling-period
-                                     (inexact->exact (round (/ 1e6 hz))))))
+                                     (inexact->exact (round (/ 1e6 hz)))
+                                     #:outer-cut call-thunk)))
     (parameterize ((profiler-state state))
       (dynamic-wind
         (lambda ()
@@ -835,7 +842,7 @@ operation is somewhat expensive."
         (lambda ()
           (let lp ((i loop))
             (unless (zero? i)
-              (thunk)
+              (call-thunk thunk)
               (lp (1- i)))))
         (lambda ()
           (statprof-stop state)
@@ -887,18 +894,17 @@ Since GC does not occur very frequently, you may need to use the
 @var{loop} parameter, to cause @var{thunk} to be called @var{loop}
 times."
   
-  (let ((state (fresh-profiler-state)))
+  (let ((state (fresh-profiler-state #:outer-cut call-thunk)))
     (parameterize ((profiler-state state))
       (define (gc-callback)
         (unless (inside-profiler? state)
           (set-inside-profiler?! state #t)
 
-          ;; FIXME: should be able to set an outer frame for the stack cut
           (let ((stop-time (get-internal-run-time))
                 ;; Cut down to gc-callback, and then one before (the
                 ;; after-gc async).  See the note in profile-signal-handler
                 ;; also.
-                (stack (or (make-stack #t gc-callback 0 1)
+                (stack (or (make-stack #t gc-callback (outer-cut state) 1)
                            (pk 'what! (make-stack #t)))))
             (sample-stack-procs state stack)
             (accumulate-time state stop-time)
@@ -915,7 +921,7 @@ times."
         (lambda ()
           (let lp ((i loop))
             (unless (zero? i)
-              (thunk)
+              (call-thunk thunk)
               (lp (1- i)))))
         (lambda ()
           (remove-hook! after-gc-hook gc-callback)