Allow the profiler's sampler to collect user-specified continuation marks.

original commit: a2c964dbdd42f0eb8d6bff8b3832d0e7f6544e26

collects/profile/sampler.rkt

@@ -12,6 +12,8 @@
 ;;   custodian (track all threads managed by the custodian), or a list of
 ;;   threads and/or custodians.  If a custodian is given, it must be
 ;;   subordinate to the current custodian or to the given super custodian.
+;;   Also optionally takes a list of continuation mark keys, which will be
+;;   monitored in addition to the stack trace continuation mark key.
 ;; * The collected values are (<thread-id> <thread-time> . <stack>), where
 ;;   - The <thread-id> is an integer number identifying the thread, starting
 ;;     from 0.  If the collected data has thread ids in a 0..N range
@@ -50,9 +52,16 @@
 ;;   - 'get-snapshots: returns the currently collected list of snapshots.  Note
 ;;     that this can be called multiple times, each will return the data that
 ;;     is collected up to that point in time.
-(define (create-sampler to-track delay [super-cust (current-custodian)])
+;;   - 'get-custom-snapshots: returns the currently collected list of custom
+;;     key snapshots. Returns a list of samples, where each sample is in the
+;;     same format as the output of continuation-mark-set->list*.
+(define (create-sampler to-track delay
+                        [super-cust  (current-custodian)]
+                        [custom-keys #f])
   ;; the collected data
   (define snapshots '())
+  ;; listof (cons continuation-mark-key value/#f)
+  (define custom-snapshots '())
   ;; intern the entries (which are (cons id/#f srcloc/#f))
   (define entry-table (make-hash))
   (define (intern-entry entry)
@@ -66,6 +75,9 @@
       en
       (begin (hash-set! entry-table key entry) entry)))
   (define (validate to-track who)
+    (unless (or (not custom-keys) (list? custom-keys))
+      (raise-type-error
+       who "list of continuation mark keys" custom-keys))
     (let loop ([t to-track])
       (cond
         [(thread? t)]
@@ -92,6 +104,15 @@
       (let loop ([t to-track])
         (cond [(thread? t)
                (unless (eq? t sampler-thread)
+                 (when custom-keys
+                   (set! custom-snapshots
+                         (cons (let ([cms (continuation-mark-set->list*
+                                           (continuation-marks t)
+                                           custom-keys)])
+                                 (if (null? cms)
+                                     #f
+                                     (car cms))) ; value
+                               custom-snapshots)))
                  (set! snapshots
                        (cons (list* (thread-id t)
                                     (current-process-milliseconds t)
@@ -132,5 +153,6 @@
                       (w/sema (set! to-track arg))]
       [(set-delay!)   (w/sema (set! delay arg))]
       [(get-snapshots) (add-time) (cons cpu-time snapshots)]
+      [(get-custom-snapshots) custom-snapshots]
       [else (error 'sampler-controller "unknown message: ~e" msg)]))
   sampler-controller)

collects/profile/scribblings/sampler.scrbl

@@ -10,7 +10,8 @@
 @defproc[(create-sampler [to-track (or/c thread? custodian?
                                          (listof (or/c thread? custodian?)))]
                          [delay (>=/c 0.0)]
-                         [super-cust custodian? (current-custodian)])
+                         [super-cust custodian? (current-custodian)]
+                         [custom-keys (listof any/c) '()])
          ((symbol?) (any/c) . ->* . any/c)]{
 
 Creates a stack-snapshot collector thread, which tracks the given
@@ -21,6 +22,10 @@ a list of threads and/or custodians.  If a custodian is given, it must
 be subordinate to @racket[super-cust], which defaults to the current
 custodian.
 
+When @racket[custom-keys] are provided, the sampler takes snapshots of the
+continuation marks corresponding to the given keys, in addition to taking
+snapshots of the stack.
+
 The resulting value is a controller function, which consumes a message
 consisting of a symbol and an optional argument, and can affect the
 sampler.  The following messages are currently supported:
@@ -45,11 +50,11 @@ sampler.  The following messages are currently supported:
   distributed, the results will still be correct: the cpu time between
   samples is taken into account when the collected data is analyzed.}
 
-@item{Finally, a @racket['get-snapshots] message will make the
+@item{A @racket['get-snapshots] message will make the controller return
-  controller return the currently collected data.  Note that this can
+  the currently collected data.  Note that this can be called multiple
-  be called multiple times, each call will return the data that is
+  times, each call will return the data that is collected up to that
-  collected up to that point in time.  In addition, it can be (and
+  point in time.  In addition, it can be (and usually is) called after
-  usually is) called after the sampler was stopped.
+  the sampler was stopped.
 
   The value that is returned should be considered as an undocumented
   internal detail of the profiler, intended to be sent to
@@ -59,4 +64,10 @@ sampler.  The following messages are currently supported:
   analysis from several individual runs, possibly from different
   machines.}
 
+@item{Finally, a @racket['get-custom-snapshots] message will make the
+  controller return the currently collected snapshots corresponding to
+  @racket[custom-keys]. This returns a list of samples, where each sample
+  is a list of vectors of marks in the same format as the output of
+  @racket[continuation-mark-set->list*].}
+
 ]}