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> 2013-10-09 Dmitry Gutov <dgutov@yandex.ru>
* progmodes/ruby-mode.el (ruby-smie-rules): Indent after hanging * progmodes/ruby-mode.el (ruby-smie-rules): Indent after hanging
......
...@@ -27,6 +27,7 @@ ...@@ -27,6 +27,7 @@
;;; Code: ;;; Code:
(require 'cl-lib) (require 'cl-lib)
(require 'pcase)
(defgroup profiler nil (defgroup profiler nil
"Emacs profiler." "Emacs profiler."
...@@ -86,10 +87,12 @@ ...@@ -86,10 +87,12 @@
(profiler-ensure-string arg))) (profiler-ensure-string arg)))
for len = (length str) for len = (length str)
if (< width len) 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 else
collect collect
(let ((padding (make-string (- width len) ?\s))) (let ((padding (make-string (max 0 (- width len)) ?\s)))
(cl-ecase align (cl-ecase align
(left (concat str padding)) (left (concat str padding))
(right (concat padding str)))) (right (concat padding str))))
...@@ -248,10 +251,10 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." ...@@ -248,10 +251,10 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
(not (profiler-calltree-count< a b))) (not (profiler-calltree-count< a b)))
(defun profiler-calltree-depth (tree) (defun profiler-calltree-depth (tree)
(let ((parent (profiler-calltree-parent tree))) (let ((d 0))
(if (null parent) (while (setq tree (profiler-calltree-parent tree))
0 (cl-incf d))
(1+ (profiler-calltree-depth parent))))) d))
(defun profiler-calltree-find (tree entry) (defun profiler-calltree-find (tree entry)
"Return a child tree of ENTRY under TREE." "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)." ...@@ -269,10 +272,9 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
(profiler-calltree-walk child function))) (profiler-calltree-walk child function)))
(defun profiler-calltree-build-1 (tree log &optional reverse) (defun profiler-calltree-build-1 (tree log &optional reverse)
;; FIXME: Do a better job of reconstructing a complete call-tree ;; This doesn't try to stitch up partial backtraces together.
;; when the backtraces have been truncated. Ideally, we should be ;; We still use it for reverse calltrees, but for forward calltrees, we use
;; able to reduce profiler-max-stack-depth to 3 or 4 and still ;; profiler-calltree-build-unified instead now.
;; get a meaningful call-tree.
(maphash (maphash
(lambda (backtrace count) (lambda (backtrace count)
(let ((node tree) (let ((node tree)
...@@ -289,6 +291,115 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." ...@@ -289,6 +291,115 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
(setq node child))))))) (setq node child)))))))
log)) 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) (defun profiler-calltree-compute-percentages (tree)
(let ((total-count 0)) (let ((total-count 0))
;; FIXME: the memory profiler's total wraps around all too easily! ;; 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)." ...@@ -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) (cl-defun profiler-calltree-build (log &key reverse)
(let ((tree (profiler-make-calltree))) (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) (profiler-calltree-compute-percentages tree)
tree)) tree))
...@@ -371,7 +484,7 @@ RET: expand or collapse")) ...@@ -371,7 +484,7 @@ RET: expand or collapse"))
(defun profiler-report-make-name-part (tree) (defun profiler-report-make-name-part (tree)
(let* ((entry (profiler-calltree-entry tree)) (let* ((entry (profiler-calltree-entry tree))
(depth (profiler-calltree-depth 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) (mark (if (profiler-calltree-leaf-p tree)
profiler-report-leaf-mark profiler-report-leaf-mark
profiler-report-closed-mark)) profiler-report-closed-mark))
...@@ -379,7 +492,7 @@ RET: expand or collapse")) ...@@ -379,7 +492,7 @@ RET: expand or collapse"))
(format "%s%s %s" indent mark entry))) (format "%s%s %s" indent mark entry)))
(defun profiler-report-header-line-format (fmt &rest args) (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))) (escaped (replace-regexp-in-string "%" "%%" header)))
(concat " " escaped))) (concat " " escaped)))
...@@ -404,7 +517,7 @@ RET: expand or collapse")) ...@@ -404,7 +517,7 @@ RET: expand or collapse"))
(insert (propertize (concat line "\n") 'calltree tree)))) (insert (propertize (concat line "\n") 'calltree tree))))
(defun profiler-report-insert-calltree-children (tree) (defun profiler-report-insert-calltree-children (tree)
(mapc 'profiler-report-insert-calltree (mapc #'profiler-report-insert-calltree
(profiler-calltree-children tree))) (profiler-calltree-children tree)))
...@@ -502,6 +615,7 @@ return it." ...@@ -502,6 +615,7 @@ return it."
(define-derived-mode profiler-report-mode special-mode "Profiler-Report" (define-derived-mode profiler-report-mode special-mode "Profiler-Report"
"Profiler Report Mode." "Profiler Report Mode."
(add-to-invisibility-spec '(profiler . t))
(setq buffer-read-only t (setq buffer-read-only t
buffer-undo-list t buffer-undo-list t
truncate-lines t)) truncate-lines t))
...@@ -531,9 +645,10 @@ return it." ...@@ -531,9 +645,10 @@ return it."
(forward-line -1) (forward-line -1)
(profiler-report-move-to-entry)) (profiler-report-move-to-entry))
(defun profiler-report-expand-entry () (defun profiler-report-expand-entry (&optional full)
"Expand entry at point." "Expand entry at point.
(interactive) With a prefix argument, expand the whole subtree."
(interactive "P")
(save-excursion (save-excursion
(beginning-of-line) (beginning-of-line)
(when (search-forward (concat profiler-report-closed-mark " ") (when (search-forward (concat profiler-report-closed-mark " ")
...@@ -543,7 +658,14 @@ return it." ...@@ -543,7 +658,14 @@ return it."
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(replace-match (concat profiler-report-open-mark " ")) (replace-match (concat profiler-report-open-mark " "))
(forward-line) (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)))))) t))))))
(defun profiler-report-collapse-entry () (defun profiler-report-collapse-entry ()
...@@ -568,11 +690,11 @@ return it." ...@@ -568,11 +690,11 @@ return it."
(delete-region start (line-beginning-position))))) (delete-region start (line-beginning-position)))))
t))) t)))
(defun profiler-report-toggle-entry () (defun profiler-report-toggle-entry (&optional arg)
"Expand entry at point if the tree is collapsed, "Expand entry at point if the tree is collapsed,
otherwise collapse." otherwise collapse."
(interactive) (interactive "P")
(or (profiler-report-expand-entry) (or (profiler-report-expand-entry arg)
(profiler-report-collapse-entry))) (profiler-report-collapse-entry)))
(defun profiler-report-find-entry (&optional event) (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> 2013-10-08 Paul Eggert <eggert@cs.ucla.edu>
Fix minor problems found by static checking. Fix minor problems found by static checking.
......
...@@ -3571,9 +3571,7 @@ hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key) ...@@ -3571,9 +3571,7 @@ hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key)
args[0] = ht->user_hash_function; args[0] = ht->user_hash_function;
args[1] = key; args[1] = key;
hash = Ffuncall (2, args); hash = Ffuncall (2, args);
if (!INTEGERP (hash)) return hashfn_eq (ht, hash);
signal_error ("Invalid hash code returned from user-supplied hash function", hash);
return XUINT (hash);
} }
/* An upper bound on the size of a hash table index. It must fit in /* 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. ...@@ -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 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 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. argument and returning an object that is the hash code of the argument.
Hash code computation should use the whole value range of integers, It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
including negative integers. */) returns nil, then (funcall TEST x1 x2) also returns nil. */)
(Lisp_Object name, Lisp_Object test, Lisp_Object hash) (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
{ {
return Fput (name, Qhash_table_test, list2 (test, 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