* lisp/profiler.el: Create a more coherent calltree from partial backtraces.

(profiler-format): Hide the tail with `invisible' so that C-s can still
find the hidden elements.
(profiler-calltree-depth): Don't recurse so enthusiastically.
(profiler-function-equal): New hash-table-test.
(profiler-calltree-build-unified): New function.
(profiler-calltree-build): Use it.
(profiler-report-make-name-part): Indent the calltree less.
(profiler-report-mode): Add visibility specs for profiler-format.
(profiler-report-expand-entry, profiler-report-toggle-entry):
Expand the whole subtree when provided with a prefix arg.
* src/fns.c (hashfn_user_defined): Allow hash functions to return any
Lisp_Object.

4 files changed, 166 insertions, 27 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 73bf12dfb4b..dbfd158f003 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,17 @@
+2013-10-09  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * profiler.el: Create a more coherent calltree from partial backtraces.
+        (profiler-format): Hide the tail with `invisible' so that C-s can still
+        find the hidden elements.
+        (profiler-calltree-depth): Don't recurse so enthusiastically.
+        (profiler-function-equal): New hash-table-test.
+        (profiler-calltree-build-unified): New function.
+        (profiler-calltree-build): Use it.
+        (profiler-report-make-name-part): Indent the calltree less.
+        (profiler-report-mode): Add visibility specs for profiler-format.
+        (profiler-report-expand-entry, profiler-report-toggle-entry):
+        Expand the whole subtree when provided with a prefix arg.
+
 2013-10-09  Dmitry Gutov  <dgutov@yandex.ru>
 
         * progmodes/ruby-mode.el (ruby-smie-rules): Indent after hanging
diff --git a/lisp/profiler.el b/lisp/profiler.el
index 93ab10015ea..84c377e9c9d 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -27,6 +27,7 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'pcase)
 
 (defgroup profiler nil
   "Emacs profiler."
@@ -86,10 +87,12 @@
                        (profiler-ensure-string arg)))
            for len = (length str)
            if (< width len)
-           collect (substring str 0 width) into frags
+           collect (progn (put-text-property (max 0 (- width 2)) len
+                                             'invisible 'profiler str)
+                          str) into frags
            else
            collect
-           (let ((padding (make-string (- width len) ?\s)))
+           (let ((padding (make-string (max 0 (- width len)) ?\s)))
              (cl-ecase align
                (left (concat str padding))
                (right (concat padding str))))
@@ -248,10 +251,10 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
   (not (profiler-calltree-count< a b)))
 
 (defun profiler-calltree-depth (tree)
-  (let ((parent (profiler-calltree-parent tree)))
-    (if (null parent)
-        0
-      (1+ (profiler-calltree-depth parent)))))
+  (let ((d 0))
+    (while (setq tree (profiler-calltree-parent tree))
+      (cl-incf d))
+    d))
 
 (defun profiler-calltree-find (tree entry)
   "Return a child tree of ENTRY under TREE."
@@ -269,10 +272,9 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
     (profiler-calltree-walk child function)))
 
 (defun profiler-calltree-build-1 (tree log &optional reverse)
-  ;; FIXME: Do a better job of reconstructing a complete call-tree
-  ;; when the backtraces have been truncated.  Ideally, we should be
-  ;; able to reduce profiler-max-stack-depth to 3 or 4 and still
-  ;; get a meaningful call-tree.
+  ;; This doesn't try to stitch up partial backtraces together.
+  ;; We still use it for reverse calltrees, but for forward calltrees, we use
+  ;; profiler-calltree-build-unified instead now.
   (maphash
    (lambda (backtrace count)
      (let ((node tree)
@@ -289,6 +291,115 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
                (setq node child)))))))
    log))
 
+
+(define-hash-table-test 'profiler-function-equal #'function-equal
+  (lambda (f) (cond
+          ((byte-code-function-p f) (aref f 1))
+          ((eq (car-safe f) 'closure) (cddr f))
+          (t f))))
+
+(defun profiler-calltree-build-unified (tree log)
+  ;; Let's try to unify all those partial backtraces into a single
+  ;; call tree.  First, we record in fun-map all the functions that appear
+  ;; in `log' and where they appear.
+  (let ((fun-map (make-hash-table :test 'profiler-function-equal))
+        (parent-map (make-hash-table :test 'eq))
+        (leftover-tree (profiler-make-calltree
+                        :entry (intern "...") :parent tree)))
+    (push leftover-tree (profiler-calltree-children tree))
+    (maphash
+     (lambda (backtrace _count)
+       (let ((max (length backtrace)))
+         ;; Don't record the head elements in there, since we want to use this
+         ;; fun-map to find parents of partial backtraces, but parents only
+         ;; make sense if they have something "above".
+         (dotimes (i (1- max))
+           (let ((f (aref backtrace i)))
+             (when f
+               (push (cons i backtrace) (gethash f fun-map)))))))
+     log)
+    ;; Then, for each partial backtrace, try to find a parent backtrace
+    ;; (i.e. a backtrace that describes (part of) the truncated part of
+    ;; the partial backtrace).  For a partial backtrace like "[f3 f2 f1]" (f3
+    ;; is deeper), any backtrace that includes f1 could be a parent; and indeed
+    ;; the counts of this partial backtrace could each come from a different
+    ;; parent backtrace (some of which may not even be in `log').  So we should
+    ;; consider each backtrace that includes f1 and give it some percentage of
+    ;; `count'.  But we can't know for sure what percentage to give to each
+    ;; possible parent.
+    ;; The "right" way might be to give a percentage proportional to the counts
+    ;; already registered for that parent, or some such statistical principle.
+    ;; But instead, we will give all our counts to a single "best
+    ;; matching" parent.  So let's look for the best matching parent, and store
+    ;; the result in parent-map.
+    ;; Using the "best matching parent" is important also to try and avoid
+    ;; stitching together backtraces that can't possibly go together.
+    ;; For example, when the head is `apply' (or `mapcar', ...), we want to
+    ;; make sure we don't just use any parent that calls `apply', since most of
+    ;; them would never, in turn, cause apply to call the subsequent function.
+    (maphash
+     (lambda (backtrace _count)
+       (let* ((max (1- (length backtrace)))
+              (head (aref backtrace max))
+              (best-parent nil)
+              (best-match (1+ max))
+              (parents (gethash head fun-map)))
+         (pcase-dolist (`(,i . ,parent) parents)
+           (when t ;; (<= (- max i) best-match) ;Else, it can't be better.
+             (let ((match max)
+                   (imatch i))
+               (cl-assert (>= match imatch))
+               (cl-assert (function-equal (aref backtrace max)
+                                          (aref parent i)))
+               (while (progn
+                        (cl-decf imatch) (cl-decf match)
+                        (when (> imatch 0)
+                          (function-equal (aref backtrace match)
+                                          (aref parent imatch)))))
+               (when (< match best-match)
+                 (cl-assert (<= (- max i) best-match))
+                 ;; Let's make sure this parent is not already our child: we
+                 ;; don't want cycles here!
+                 (let ((valid t)
+                       (tmp-parent parent))
+                   (while (setq tmp-parent
+                                (if (eq tmp-parent backtrace)
+                                    (setq valid nil)
+                                  (cdr (gethash tmp-parent parent-map)))))
+                   (when valid
+                     (setq best-match match)
+                     (setq best-parent (cons i parent))))))))
+         (puthash backtrace best-parent parent-map)))
+     log)
+    ;; Now we have a single parent per backtrace, so we have a unified tree.
+    ;; Let's build the actual call-tree from it.
+    (maphash
+     (lambda (backtrace count)
+       (let ((node tree)
+             (parents (list (cons -1 backtrace)))
+             (tmp backtrace)
+             (max (length backtrace)))
+         (while (setq tmp (gethash tmp parent-map))
+           (push tmp parents)
+           (setq tmp (cdr tmp)))
+         (when (aref (cdar parents) (1- max))
+           (cl-incf (profiler-calltree-count leftover-tree) count)
+           (setq node leftover-tree))
+         (pcase-dolist (`(,i . ,parent) parents)
+           (let ((j (1- max)))
+             (while (> j i)
+               (let ((f (aref parent j)))
+                 (cl-decf j)
+                 (when f
+                   (let ((child (profiler-calltree-find node f)))
+                     (unless child
+                       (setq child (profiler-make-calltree
+                                    :entry f :parent node))
+                       (push child (profiler-calltree-children node)))
+                     (cl-incf (profiler-calltree-count child) count)
+                     (setq node child)))))))))
+     log)))
+
 (defun profiler-calltree-compute-percentages (tree)
   (let ((total-count 0))
     ;; FIXME: the memory profiler's total wraps around all too easily!
@@ -303,7 +414,9 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
 
 (cl-defun profiler-calltree-build (log &key reverse)
   (let ((tree (profiler-make-calltree)))
-    (profiler-calltree-build-1 tree log reverse)
+    (if reverse
+        (profiler-calltree-build-1 tree log reverse)
+      (profiler-calltree-build-unified tree log))
     (profiler-calltree-compute-percentages tree)
     tree))
 
@@ -371,7 +484,7 @@ RET: expand or collapse"))
 (defun profiler-report-make-name-part (tree)
   (let* ((entry (profiler-calltree-entry tree))
          (depth (profiler-calltree-depth tree))
-         (indent (make-string (* (1- depth) 2) ?\s))
+         (indent (make-string (* (1- depth) 1) ?\s))
          (mark (if (profiler-calltree-leaf-p tree)
                    profiler-report-leaf-mark
                  profiler-report-closed-mark))
@@ -379,7 +492,7 @@ RET: expand or collapse"))
     (format "%s%s %s" indent mark entry)))
 
 (defun profiler-report-header-line-format (fmt &rest args)
-  (let* ((header (apply 'profiler-format fmt args))
+  (let* ((header (apply #'profiler-format fmt args))
          (escaped (replace-regexp-in-string "%" "%%" header)))
     (concat " " escaped)))
 
@@ -404,7 +517,7 @@ RET: expand or collapse"))
     (insert (propertize (concat line "\n") 'calltree tree))))
 
 (defun profiler-report-insert-calltree-children (tree)
-  (mapc 'profiler-report-insert-calltree
+  (mapc #'profiler-report-insert-calltree
         (profiler-calltree-children tree)))
 
 
@@ -502,6 +615,7 @@ return it."
 
 (define-derived-mode profiler-report-mode special-mode "Profiler-Report"
   "Profiler Report Mode."
+  (add-to-invisibility-spec '(profiler . t))
   (setq buffer-read-only t
         buffer-undo-list t
         truncate-lines t))
@@ -531,9 +645,10 @@ return it."
   (forward-line -1)
   (profiler-report-move-to-entry))
 
-(defun profiler-report-expand-entry ()
-  "Expand entry at point."
-  (interactive)
+(defun profiler-report-expand-entry (&optional full)
+  "Expand entry at point.
+With a prefix argument, expand the whole subtree."
+  (interactive "P")
   (save-excursion
     (beginning-of-line)
     (when (search-forward (concat profiler-report-closed-mark " ")
@@ -543,7 +658,14 @@ return it."
           (let ((inhibit-read-only t))
             (replace-match (concat profiler-report-open-mark " "))
             (forward-line)
-            (profiler-report-insert-calltree-children tree)
+            (let ((first (point))
+                  (last (copy-marker (point) t)))
+              (profiler-report-insert-calltree-children tree)
+              (when full
+                (goto-char first)
+                (while (< (point) last)
+                  (profiler-report-expand-entry)
+                  (forward-line 1))))
             t))))))
 
 (defun profiler-report-collapse-entry ()
@@ -568,11 +690,11 @@ return it."
             (delete-region start (line-beginning-position)))))
       t)))
 
-(defun profiler-report-toggle-entry ()
+(defun profiler-report-toggle-entry (&optional arg)
   "Expand entry at point if the tree is collapsed,
 otherwise collapse."
-  (interactive)
-  (or (profiler-report-expand-entry)
+  (interactive "P")
+  (or (profiler-report-expand-entry arg)
       (profiler-report-collapse-entry)))
 
 (defun profiler-report-find-entry (&optional event)
diff --git a/src/ChangeLog b/src/ChangeLog
index 5196eb230d8..a205ea72b7f 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,8 @@
+2013-10-09  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * fns.c (hashfn_user_defined): Allow hash functions to return any
+        Lisp_Object.
+
 2013-10-08  Paul Eggert  <eggert@cs.ucla.edu>
 
         Fix minor problems found by static checking.
diff --git a/src/fns.c b/src/fns.c
index 151977ecdc4..e991711b871 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -3571,9 +3571,7 @@ hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key)
   args[0] = ht->user_hash_function;
   args[1] = key;
   hash = Ffuncall (2, args);
-  if (!INTEGERP (hash))
-    signal_error ("Invalid hash code returned from user-supplied hash function", hash);
-  return XUINT (hash);
+  return hashfn_eq (ht, hash);
 }
 
 /* An upper bound on the size of a hash table index.  It must fit in
@@ -4542,9 +4540,9 @@ compare keys, and HASH for computing hash codes of keys.
 
 TEST must be a function taking two arguments and returning non-nil if
 both arguments are the same.  HASH must be a function taking one
-argument and return an integer that is the hash code of the argument.
-Hash code computation should use the whole value range of integers,
-including negative integers.  */)
+argument and returning an object that is the hash code of the argument.
+It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
+returns nil, then (funcall TEST x1 x2) also returns nil.  */)
   (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
 {
   return Fput (name, Qhash_table_test, list2 (test, hash));