Patch: Add call graph to elp.el

[Christian Ohler]

The attached patch makes elp.el record and display call graph 
information.  This makes the profiler much more useful.

Christian.

--- elp.el      28 Jan 2008 22:48:53 +0100      1.43
+++ elp.el      08 Feb 2008 21:58:18 +0100      
@@ -126,6 +126,8 @@
 
 ;;; Code:
 
+(require 'cl)
+
 
 ;; start of user configuration variables
 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
@@ -205,14 +207,29 @@
 (defvar elp-master nil
   "Master function symbol.")
 
+(defun elp-compute-not-profilable ()
+  (loop for prev = nil then funsyms
+        for funsyms = '(elp-wrapper called-interactively-p)
+        then (remove-duplicates
+              (append funsyms
+                      (loop for funsym in funsyms
+                            for fn = (symbol-function funsym)
+                            unless (subrp fn)
+                            append (remove-if-not
+                                    (lambda (x)
+                                      (and (symbolp x) (fboundp x)))
+                                    (coerce (aref fn 2) 'list))))
+              :from-end t)
+        until (equal prev funsyms)
+        finally (return funsyms)))
+
 (defvar elp-not-profilable
-  ;; First, the functions used inside each instrumented function:
-  '(elp-wrapper called-interactively-p
-    ;; Then the functions used by the above functions.  I used
-    ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x))
-    ;;                   (aref (symbol-function 'elp-wrapper) 2)))
-    ;; to help me find this list.
-    error call-interactively apply current-time)
+  '(
+    ;; To recompute this list, hit C-x C-e at the end of
+    ;; this line: (print (elp-compute-not-profilable) (current-buffer))
+    (elp-wrapper called-interactively-p error call-interactively apply
+                 current-time assoc vector signal format)
+    )
   "List of functions that cannot be profiled.
 Those functions are used internally by the profiling code and profiling
 them would thus lead to infinite recursion.")
@@ -245,7 +262,7 @@
   ;; definition.
   (elp-restore-function funsym)
   (let* ((funguts (symbol-function funsym))
-        (infovec (vector 0 0 funguts))
+         (infovec (vector 0 0 funguts (list) (list)))
         (newguts '(lambda (&rest args))))
     ;; we cannot profile macros
     (and (eq (car-safe funguts) 'macro)
@@ -386,6 +403,8 @@
     (aset info 0 0)                    ;reset call counter
     (aset info 1 0.0)                  ;reset total time
     ;; don't muck with aref 2 as that is the old symbol definition
+    (aset info 3 (list))               ;reset children
+    (aset info 4 (list))                ;reset parents
     ))
 
 (defun elp-reset-list (&optional list)
@@ -424,49 +443,80 @@
      (- (car (cdr end)) (car (cdr start)))
      (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0)))
 
-(defun elp-wrapper (funsym interactive-p args)
-  "This function has been instrumented for profiling by the ELP.
+(defvar elp-parent-info nil)
+(defvar elp-parent-name nil)
+
+(defstruct (elp-entry (:constructor elp-make-entry))
+  (total-time 0)
+  (call-count 0))
+
+(defun elp-wrapper (elp--funsym elp--interactive-p elp--args)
+  "This function has been instrumented for profiling by ELP.
 ELP is the Emacs Lisp Profiler.  To restore the function to its
 original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
-  ;; turn on recording if this is the master function
-  (if (and elp-master
-          (eq funsym elp-master))
-      (setq elp-record-p t))
-  ;; get info vector and original function symbol
-  (let* ((info (get funsym elp-timer-info-property))
-        (func (aref info 2))
-        result)
-    (or func
-       (error "%s is not instrumented for profiling" funsym))
-    (if (not elp-record-p)
-       ;; when not recording, just call the original function symbol
-       ;; and return the results.
-       (setq result
-             (if interactive-p
-                 (call-interactively func)
-               (apply func args)))
-      ;; we are recording times
-      (let (enter-time exit-time)
-       ;; increment the call-counter
-       (aset info 0 (1+ (aref info 0)))
-       ;; now call the old symbol function, checking to see if it
-       ;; should be called interactively.  make sure we return the
-       ;; correct value
-       (if interactive-p
-           (setq enter-time (current-time)
-                 result (call-interactively func)
-                 exit-time (current-time))
-         (setq enter-time (current-time)
-               result (apply func args)
-               exit-time (current-time)))
-       ;; calculate total time in function
-       (aset info 1 (+ (aref info 1) (elp-elapsed-time enter-time exit-time)))
-       ))
-    ;; turn off recording if this is the master function
+  (lexical-let ((funsym elp--funsym)
+                (interactive-p elp--interactive-p)
+                (args elp--args))
+    ;; turn on recording if this is the master function
     (if (and elp-master
-            (eq funsym elp-master))
-       (setq elp-record-p nil))
-    result))
+             (eq funsym elp-master))
+        (setq elp-record-p t))
+    ;; get info vector and original function symbol
+    (lexical-let* ((info (get funsym elp-timer-info-property))
+                   (func (aref info 2))
+                   result)
+      (or func
+          (error "%s is not instrumented for profiling" funsym))
+      (if (not elp-record-p)
+          ;; when not recording, just call the original function symbol
+          ;; and return the results.
+          (setq result
+                (let ((elp-parent-info info)
+                      (elp-parent-name funsym))
+                  (if interactive-p
+                      (call-interactively func)
+                    (apply func args))))
+        ;; we are recording times
+        (let (enter-time exit-time)
+          ;; increment the call-counter
+          (aset info 0 (1+ (aref info 0)))
+          ;; now call the old symbol function, checking to see if it
+          ;; should be called interactively.  make sure we return the
+          ;; correct value
+          (let ((elp-parent-info info)
+                (elp-parent-name funsym))
+            (if interactive-p
+                (setq enter-time (current-time)
+                      result (call-interactively func)
+                      exit-time (current-time))
+              (setq enter-time (current-time)
+                    result (apply func args)
+                    exit-time (current-time))))
+          (let ((elapsed-time (elp-elapsed-time enter-time exit-time)))
+            (aset info 1 (+ (aref info 1) elapsed-time))
+            (unless (null elp-parent-info)
+              (let ((entry-in-parent (cdr
+                                      (assoc funsym (aref elp-parent-info 
3)))))
+                (unless entry-in-parent
+                  (push (cons funsym
+                              (setq entry-in-parent (elp-make-entry)))
+                        (aref elp-parent-info 3)))
+                (incf (elp-entry-total-time entry-in-parent) elapsed-time)
+                (incf (elp-entry-call-count entry-in-parent)))
+              (let ((parent-name elp-parent-name))
+                (let ((entry-in-self (cdr (assoc parent-name (aref info 4)))))
+                  (unless entry-in-self
+                    (push (cons parent-name
+                                (setq entry-in-self (elp-make-entry)))
+                          (aref info 4)))
+                  (incf (elp-entry-total-time entry-in-self) elapsed-time)
+                  (incf (elp-entry-call-count entry-in-self))))))
+          ))
+      ;; turn off recording if this is the master function
+      (if (and elp-master
+               (eq funsym elp-master))
+          (setq elp-record-p nil))
+      result)))
 
 
 ;; shut the byte-compiler up
@@ -502,35 +552,79 @@
                (match-string 2 number))
       (substring number 0 width))))
 
+(defun elp-output-result-entries (prefix entries)
+  (loop for vec in 
+        (if (null elp-sort-by-function)
+            entries
+          (sort (copy-list entries) elp-sort-by-function))
+        for (fn-or-self-marker cc tt at tp ap) = (coerce vec 'list)
+        do
+        (insert prefix)
+        (let ((inserted-length
+               (elp-output-insert-symbol fn-or-self-marker)))
+          (insert-char 32 (+ elp-field-len
+                             (- (+ inserted-length 1))
+                             2)))
+        (let ((ccstr (number-to-string cc))
+              (ttstr (number-to-string tt))
+              (tpstr (number-to-string tp))
+              (atstr (number-to-string at))
+              (apstr (number-to-string ap)))
+          (insert ccstr)
+          (insert-char 32 (+ elp-cc-len (- (length ccstr)) 2))
+          (let ((ttstr (elp-pack-number ttstr elp-et-len))
+                (atstr (elp-pack-number atstr elp-at-len)))
+            (insert ttstr)
+            (insert-char 32 (+ elp-et-len (- (length ttstr)) 2))
+            (insert atstr)))
+        (insert "\n")))
+
+(defun elp-safe-/ (a b)
+  (if (zerop b) 0.0 (/ a b)))
+
 (defun elp-output-result (resultvec)
   ;; output the RESULTVEC into the results buffer. RESULTVEC is a 4 or
   ;; more element vector where aref 0 is the call count, aref 1 is the
   ;; total time spent in the function, aref 2 is the average time
   ;; spent in the function, and aref 3 is the symbol's string
-  ;; name. All other elements in the vector are ignored.
-  (let* ((cc (aref resultvec 0))
-        (tt (aref resultvec 1))
-        (at (aref resultvec 2))
-        (symname (aref resultvec 3))
-        callcnt totaltime avetime)
-    (setq callcnt (number-to-string cc)
-         totaltime (number-to-string tt)
-         avetime (number-to-string at))
+  ;; name. All other elements in the vector are ignored.  aref 4 is
+  ;; list of children.  aref 5 is list of parents.
+  (let* ((symname (aref resultvec 0))
+         (cc (aref resultvec 1))
+         (tt (aref resultvec 2))
+         (at (aref resultvec 3))
+         (children (aref resultvec 4))
+         (parents (aref resultvec 5)))
     ;; possibly prune the results
     (if (and elp-report-limit
             (numberp elp-report-limit)
             (< cc elp-report-limit))
        nil
-      (elp-output-insert-symname symname)
-      (insert-char 32 (+ elp-field-len (- (length symname)) 2))
-      ;; print stuff out, formatting it nicely
-      (insert callcnt)
-      (insert-char 32 (+ elp-cc-len (- (length callcnt)) 2))
-      (let ((ttstr (elp-pack-number totaltime elp-et-len))
-           (atstr (elp-pack-number avetime elp-at-len)))
-       (insert ttstr)
-       (insert-char 32 (+ elp-et-len (- (length ttstr)) 2))
-       (insert atstr))
+      (elp-output-result-entries
+       "  "
+       (loop for (parent . entry) in parents
+             collect (let* ((cc (elp-entry-call-count entry))
+                            (tt (elp-entry-total-time entry))
+                            (at (elp-safe-/ tt cc)))
+                       (vector parent cc tt at 0 0))))
+      (elp-output-result-entries
+       ""
+       (list (vector symname cc tt at 0 0)))
+      (elp-output-result-entries
+       "  "
+       (append
+        (loop for (child . entry) in children
+              collect (let* ((cc (elp-entry-call-count entry))
+                             (tt (elp-entry-total-time entry))
+                             (at (elp-safe-/ tt cc)))
+                        (vector child cc tt at 0 0)))
+        (list (let* ((cc cc)
+                     (tt (- tt
+                            (reduce #'+ (mapcar #'cdr children)
+                                    :key #'elp-entry-total-time)))
+                     (at (elp-safe-/ tt cc))
+                     (self-marker '(self)))
+                (vector self-marker cc tt at 0 0)))))
       (insert "\n"))))
 
 (defvar elp-results-symname-map
@@ -546,13 +640,18 @@
   (if event (posn-set-point (event-end event)))
   (find-function (get-text-property (point) 'elp-symname)))
 
-(defun elp-output-insert-symname (symname)
-  ;; Insert SYMNAME with text properties.
-  (insert (propertize symname
-                     'elp-symname (intern symname)
-                     'keymap elp-results-symname-map
-                     'mouse-face 'highlight
-                     'help-echo "mouse-2 or RET jumps to definition")))
+(defun elp-output-insert-symbol (symbol-or-self-marker)
+  (cond ((equal symbol-or-self-marker '(self))
+         (let ((text "<self or not profiled>"))
+           (insert text)
+           (length text)))
+        (t
+         (insert (propertize (symbol-name symbol-or-self-marker)
+                             'elp-symname symbol-or-self-marker
+                             'keymap elp-results-symname-map
+                             'mouse-face 'highlight
+                             'help-echo "mouse-2 or RET jumps to definition"))
+         (length (symbol-name symbol-or-self-marker)))))
 
 ;;;###autoload
 (defun elp-results ()
@@ -585,15 +684,17 @@
                (let* ((info (get funsym elp-timer-info-property))
                       (symname (format "%s" funsym))
                       (cc (aref info 0))
-                      (tt (aref info 1)))
+                       (tt (aref info 1))
+                       (at (elp-safe-/ tt cc))
+                       (children (aref info 3))
+                       (parents (aref info 4)))
                  (if (not info)
                      (insert "No profiling information found for: "
                              symname)
                    (setq longest (max longest (length symname)))
-                   (vector cc tt (if (zerop cc)
-                                     0.0 ;avoid arithmetic div-by-zero errors
-                                   (/ (float tt) (float cc)))
-                           symname)))))
+                    (vector funsym
+                            cc tt at
+                            children parents)))))
             elp-all-instrumented-list))
           )                            ; end let*
       ;; If printing to stdout, insert the header so it will print.