* 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.
This commit is contained in:
Stefan Monnier
parent
238150c8ff
commit
79804536d8
4 changed files with 166 additions and 27 deletions
|
|
@ -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
|
||||
|
|
|
|||
164
lisp/profiler.el
164
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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
10
src/fns.c
10
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));
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue