Commit 79804536 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* 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.
parent 238150c8
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
......
......@@ -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)
......
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.
......
......@@ -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));
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment