statprof-display prints source locations

* module/statprof.scm (call-data): Source is after printable.
  (addr->printable): Just produce a name, without source.  Anonymous
  printables get "anon " prefixed.
  (stack-samples->procedure-data): Adapt to call-data change.
  (stats): Add "proc-source" element.
  (statprof-call-data->stats): Give a source to the call-data.
  (statprof-display): Print source also.

1 files changed, 31 insertions, 17 deletions

diff --git a/module/statprof.scm b/module/statprof.scm
index 4310c0f94..c1b21d1de 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -130,6 +130,7 @@
             statprof-call-data->stats
            
             statprof-stats-proc-name
+            statprof-stats-proc-source
             statprof-stats-%-time-in-proc
             statprof-stats-cum-secs-in-proc
             statprof-stats-self-secs-in-proc
@@ -371,12 +372,12 @@ always collects full stacks.)"
   (values))
 
 (define-record-type call-data
-  (make-call-data name source printable
+  (make-call-data name printable source
                   call-count cum-sample-count self-sample-count)
   call-data?
   (name call-data-name)
-  (source call-data-source)
   (printable call-data-printable)
+  (source call-data-source)
   (call-count call-data-call-count set-call-data-call-count!)
   (cum-sample-count call-data-cum-sample-count set-call-data-cum-sample-count!)
   (self-sample-count call-data-self-sample-count set-call-data-self-sample-count!))
@@ -405,9 +406,8 @@ always collects full stacks.)"
       data))))
 
 (define (addr->printable addr pdi)
-  (if pdi
-      (program-debug-info-printable pdi)
-      (string-append "#x" (number->string addr 16))))
+  (or (and=> (and=> pdi program-debug-info-name) symbol->string)
+      (string-append "anon #x" (number->string addr 16))))
 
 (define (inc-call-data-cum-sample-count! cd)
   (set-call-data-cum-sample-count! cd (1+ (call-data-cum-sample-count cd))))
@@ -425,8 +425,8 @@ always collects full stacks.)"
              (entry (if pdi (program-debug-info-addr pdi) addr)))
         (or (hashv-ref table entry)
             (let ((data (make-call-data (and=> pdi program-debug-info-name)
-                                        (find-source-for-addr entry)
                                         (addr->printable entry pdi)
+                                        (find-source-for-addr entry)
                                         (and call-counts
                                              (hashv-ref call-counts entry))
                                         0
@@ -444,8 +444,8 @@ always collects full stacks.)"
                            ;; a primitive
                            ((symbol? callee) callee)
                            (else #f))
-                     #f
                      (with-output-to-string (lambda () (write callee)))
+                     #f
                      (and call-counts (hashv-ref call-counts callee))
                      0
                      0)))
@@ -523,10 +523,12 @@ none is available."
 ;; Stats
 
 (define-record-type stats
-  (make-stats proc-name %-time-in-proc cum-secs-in-proc self-secs-in-proc
+  (make-stats proc-name proc-source
+              %-time-in-proc cum-secs-in-proc self-secs-in-proc
               calls self-secs-per-call cum-secs-per-call)
   stats?
   (proc-name statprof-stats-proc-name)
+  (proc-source statprof-stats-proc-source)
   (%-time-in-proc statprof-stats-%-time-in-proc)
   (cum-secs-in-proc statprof-stats-cum-secs-in-proc)
   (self-secs-in-proc statprof-stats-self-secs-in-proc)
@@ -538,7 +540,8 @@ none is available."
   "Returns an object of type @code{statprof-stats}."
   (define state (existing-profiler-state))
 
-  (let* ((proc-name (call-data-printable call-data))
+  (let* ((proc-name (call-data-name call-data))
+         (proc-source (and=> (call-data-source call-data) source->string))
          (self-samples (call-data-self-sample-count call-data))
          (cum-samples (call-data-cum-sample-count call-data))
          (all-samples (statprof-sample-count))
@@ -547,7 +550,11 @@ none is available."
          (num-calls (and (call-counts state)
                          (statprof-call-data-calls call-data))))
 
-    (make-stats proc-name
+    (make-stats (or proc-name
+                    ;; If there is no name and no source, fall back to
+                    ;; printable.
+                    (and (not proc-source) (call-data-printable call-data)))
+                proc-source
                 (* (/ self-samples all-samples) 100.0)
                 (* cum-samples secs-per-sample 1.0)
                 (* self-samples secs-per-sample 1.0)
@@ -601,20 +608,27 @@ optional @var{port} argument is passed, uses the current output port."
                         (* 1000 (statprof-stats-cum-secs-per-call stats)))
                 (format port "                            "))
             (display "  " port))
-        (display (statprof-stats-proc-name stats) port)
-        (newline port))
+        (let ((source (statprof-stats-proc-source stats))
+              (name (statprof-stats-proc-name stats)))
+          (when source
+            (display source port)
+            (when name
+              (display ":" port)))
+          (when name
+            (display name port))
+          (newline port)))
     
       (if (call-counts state)
           (begin
             (format  port "~5a ~10a   ~7a ~8a ~8a ~8a  ~8@a\n"
                      "%  " "cumulative" "self" "" "self" "total" "")
-            (format  port "~5a  ~9a  ~8a ~8a ~8a ~8a  ~8@a\n"
-                     "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name"))
+            (format  port "~5a  ~9a  ~8a ~8a ~8a ~8a  ~a\n"
+                     "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "procedure"))
           (begin
-            (format  port "~5a ~10a   ~7a  ~8@a\n"
+            (format  port "~5a ~10a   ~7a  ~8a\n"
                      "%" "cumulative" "self" "")
-            (format  port "~5a  ~10a  ~7a  ~8@a\n"
-                     "time" "seconds" "seconds" "name")))
+            (format  port "~5a  ~10a  ~7a  ~a\n"
+                     "time" "seconds" "seconds" "procedure")))
 
       (for-each display-stats-line sorted-stats)