[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] /srv/bzr/emacs/trunk r110206: Merge profiler branch
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] /srv/bzr/emacs/trunk r110206: Merge profiler branch |
|
Date: |
Wed, 26 Sep 2012 11:19:10 -0400 |
|
User-agent: |
Bazaar (2.5.0) |
------------------------------------------------------------
revno: 110206 [merge]
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Wed 2012-09-26 11:19:10 -0400
message:
Merge profiler branch
added:
lisp/profiler.el
src/profiler.c
modified:
etc/NEWS
lisp/ChangeLog
src/ChangeLog
src/Makefile.in
src/alloc.c
src/emacs.c
src/eval.c
src/lisp.h
src/makefile.w32-in
src/xdisp.c
=== modified file 'etc/NEWS'
--- a/etc/NEWS 2012-09-25 04:13:02 +0000
+++ b/etc/NEWS 2012-09-26 15:19:10 +0000
@@ -678,6 +678,11 @@
* Lisp changes in Emacs 24.3
+** New sampling-based Elisp profiler.
+Try M-x profiler-start ... M-x profiler-stop; and then M-x profiler-report.
+The sampling rate can be based on CPU time (only supported on some
+systems), or based on memory allocations.
+
** CL-style generalized variables are now in core Elisp.
`setf' is autoloaded; `push' and `pop' accept generalized variables.
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2012-09-26 14:41:05 +0000
+++ b/lisp/ChangeLog 2012-09-26 15:19:10 +0000
@@ -1,3 +1,8 @@
+2012-09-26 Tomohiro Matsuyama <address@hidden>
+ Stefan Monnier <address@hidden>
+
+ * profiler.el: New file.
+
2012-09-26 Stefan Monnier <address@hidden>
* emacs-lisp/testcover.el (testcover-after): Add gv-expander.
=== added file 'lisp/profiler.el'
--- a/lisp/profiler.el 1970-01-01 00:00:00 +0000
+++ b/lisp/profiler.el 2012-09-26 15:19:10 +0000
@@ -0,0 +1,665 @@
+;;; profiler.el --- UI and helper functions for Emacs's native profiler -*-
lexical-binding: t -*-
+
+;; Copyright (C) 2012 Free Software Foundation, Inc.
+
+;; Author: Tomohiro Matsuyama <address@hidden>
+;; Keywords: lisp
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl-lib))
+
+(defgroup profiler nil
+ "Emacs profiler."
+ :group 'lisp
+ :prefix "profiler-")
+
+(defcustom profiler-sample-interval 1
+ "Default sample interval in millisecond."
+ :type 'integer
+ :group 'profiler)
+
+;;; Utilities
+
+(defun profiler-ensure-string (object)
+ (cond ((stringp object)
+ object)
+ ((symbolp object)
+ (symbol-name object))
+ ((numberp object)
+ (number-to-string object))
+ (t
+ (format "%s" object))))
+
+(defun profiler-format (fmt &rest args)
+ (cl-loop for (width align subfmt) in fmt
+ for arg in args
+ for str = (cond
+ ((consp subfmt)
+ (apply 'profiler-format subfmt arg))
+ ((stringp subfmt)
+ (format subfmt arg))
+ ((and (symbolp subfmt)
+ (fboundp subfmt))
+ (funcall subfmt arg))
+ (t
+ (profiler-ensure-string arg)))
+ for len = (length str)
+ if (< width len)
+ collect (substring str 0 width) into frags
+ else
+ collect
+ (let ((padding (make-string (- width len) ?\s)))
+ (cl-ecase align
+ (left (concat str padding))
+ (right (concat padding str))))
+ into frags
+ finally return (apply #'concat frags)))
+
+(defun profiler-format-percent (number divisor)
+ (concat (number-to-string (/ (* number 100) divisor)) "%"))
+
+(defun profiler-format-nbytes (nbytes)
+ "Format NBYTES in humarn readable string."
+ (if (and (integerp nbytes) (> nbytes 0))
+ (cl-loop with i = (% (1+ (floor (log10 nbytes))) 3)
+ for c in (append (number-to-string nbytes) nil)
+ if (= i 0)
+ collect ?, into s
+ and do (setq i 3)
+ collect c into s
+ do (cl-decf i)
+ finally return
+ (apply 'string (if (eq (car s) ?,) (cdr s) s)))
+ (profiler-ensure-string nbytes)))
+
+
+;;; Entries
+
+(defun profiler-entry-format (entry)
+ "Format ENTRY in human readable string. ENTRY would be a
+function name of a function itself."
+ (cond ((memq (car-safe entry) '(closure lambda))
+ (format "#<lambda 0x%x>" (sxhash entry)))
+ ((byte-code-function-p entry)
+ (format "#<compiled 0x%x>" (sxhash entry)))
+ ((or (subrp entry) (symbolp entry) (stringp entry))
+ (format "%s" entry))
+ (t
+ (format "#<unknown 0x%x>" (sxhash entry)))))
+
+;;; Log data structure
+
+;; The C code returns the log in the form of a hash-table where the keys are
+;; vectors (of size profiler-max-stack-depth, holding truncated
+;; backtraces, where the first element is the top of the stack) and
+;; the values are integers (which count how many times this backtrace
+;; has been seen, multiplied by a "weight factor" which is either the
+;; sample-interval or the memory being allocated).
+;; We extend it by adding a few other entries to the hash-table, most notably:
+;; - Key `type' has a value indicating the kind of log (`memory' or `cpu').
+;; - Key `timestamp' has a value giving the time when the log was obtained.
+;; - Key `diff-p' indicates if this log represents a diff between two logs.
+
+(defun profiler-log-timestamp (log) (gethash 'timestamp log))
+(defun profiler-log-type (log) (gethash 'type log))
+(defun profiler-log-diff-p (log) (gethash 'diff-p log))
+
+(defun profiler-log-diff (log1 log2)
+ "Compare LOG1 with LOG2 and return a diff log. Both logs must
+be same type."
+ (unless (eq (profiler-log-type log1)
+ (profiler-log-type log2))
+ (error "Can't compare different type of logs"))
+ (let ((newlog (make-hash-table :test 'equal)))
+ ;; Make a copy of `log1' into `newlog'.
+ (maphash (lambda (backtrace count) (puthash backtrace count newlog))
+ log1)
+ (puthash 'diff-p t newlog)
+ (maphash (lambda (backtrace count)
+ (when (vectorp backtrace)
+ (puthash backtrace (- (gethash backtrace log1 0) count)
+ newlog)))
+ log2)
+ newlog))
+
+(defun profiler-log-fixup-entry (entry)
+ (if (symbolp entry)
+ entry
+ (profiler-entry-format entry)))
+
+(defun profiler-log-fixup-backtrace (backtrace)
+ (mapcar 'profiler-log-fixup-entry backtrace))
+
+(defun profiler-log-fixup (log)
+ "Fixup LOG so that the log could be serialized into file."
+ (let ((newlog (make-hash-table :test 'equal)))
+ (maphash (lambda (backtrace count)
+ (puthash (if (not (vectorp backtrace))
+ backtrace
+ (profiler-log-fixup-backtrace backtrace))
+ count newlog))
+ log)
+ newlog))
+
+(defun profiler-log-write-file (log filename &optional confirm)
+ "Write LOG into FILENAME."
+ (with-temp-buffer
+ (let (print-level print-length)
+ (print (profiler-log-fixup log) (current-buffer)))
+ (write-file filename confirm)))
+
+(defun profiler-log-read-file (filename)
+ "Read log from FILENAME."
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (read (current-buffer))))
+
+
+;;; Calltree data structure
+
+(cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
+ entry
+ (count 0) (count-percent "")
+ parent children)
+
+(defun profiler-calltree-leaf-p (tree)
+ (null (profiler-calltree-children tree)))
+
+(defun profiler-calltree-count< (a b)
+ (cond ((eq (profiler-calltree-entry a) t) t)
+ ((eq (profiler-calltree-entry b) t) nil)
+ (t (< (profiler-calltree-count a)
+ (profiler-calltree-count b)))))
+
+(defun profiler-calltree-count> (a b)
+ (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)))))
+
+(defun profiler-calltree-find (tree entry)
+ "Return a child tree of ENTRY under TREE."
+ ;; OPTIMIZED
+ (let (result (children (profiler-calltree-children tree)))
+ ;; FIXME: Use `assoc'.
+ (while (and children (null result))
+ (let ((child (car children)))
+ (when (equal (profiler-calltree-entry child) entry)
+ (setq result child))
+ (setq children (cdr children))))
+ result))
+
+(defun profiler-calltree-walk (calltree function)
+ (funcall function calltree)
+ (dolist (child (profiler-calltree-children calltree))
+ (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.
+ (maphash
+ (lambda (backtrace count)
+ (when (vectorp backtrace)
+ (let ((node tree)
+ (max (length backtrace)))
+ (dotimes (i max)
+ (let ((entry (aref backtrace (if reverse i (- max i 1)))))
+ (when entry
+ (let ((child (profiler-calltree-find node entry)))
+ (unless child
+ (setq child (profiler-make-calltree
+ :entry entry :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!
+ (dolist (child (profiler-calltree-children tree))
+ (cl-incf total-count (profiler-calltree-count child)))
+ (unless (zerop total-count)
+ (profiler-calltree-walk
+ tree (lambda (node)
+ (setf (profiler-calltree-count-percent node)
+ (profiler-format-percent (profiler-calltree-count node)
+ total-count)))))))
+
+(cl-defun profiler-calltree-build (log &key reverse)
+ (let ((tree (profiler-make-calltree)))
+ (profiler-calltree-build-1 tree log reverse)
+ (profiler-calltree-compute-percentages tree)
+ tree))
+
+(defun profiler-calltree-sort (tree predicate)
+ (let ((children (profiler-calltree-children tree)))
+ (setf (profiler-calltree-children tree) (sort children predicate))
+ (dolist (child (profiler-calltree-children tree))
+ (profiler-calltree-sort child predicate))))
+
+
+;;; Report rendering
+
+(defcustom profiler-report-closed-mark "+"
+ "An indicator of closed calltrees."
+ :type 'string
+ :group 'profiler)
+
+(defcustom profiler-report-open-mark "-"
+ "An indicator of open calltrees."
+ :type 'string
+ :group 'profiler)
+
+(defcustom profiler-report-leaf-mark " "
+ "An indicator of calltree leaves."
+ :type 'string
+ :group 'profiler)
+
+(defvar profiler-report-sample-line-format
+ '((60 left)
+ (14 right ((9 right)
+ (5 right)))))
+
+(defvar profiler-report-memory-line-format
+ '((55 left)
+ (19 right ((14 right profiler-format-nbytes)
+ (5 right)))))
+
+(defvar-local profiler-report-log nil
+ "The current profiler log.")
+
+(defvar-local profiler-report-reversed nil
+ "True if calltree is rendered in bottom-up. Do not touch this
+variable directly.")
+
+(defvar-local profiler-report-order nil
+ "The value can be `ascending' or `descending'. Do not touch
+this variable directly.")
+
+(defun profiler-report-make-entry-part (entry)
+ (let ((string (cond
+ ((eq entry t)
+ "Others")
+ ((and (symbolp entry)
+ (fboundp entry))
+ (propertize (symbol-name entry)
+ 'face 'link
+ 'mouse-face 'highlight
+ 'help-echo "mouse-2 or RET jumps to definition"))
+ (t
+ (profiler-entry-format entry)))))
+ (propertize string 'profiler-entry entry)))
+
+(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))
+ (mark (if (profiler-calltree-leaf-p tree)
+ profiler-report-leaf-mark
+ profiler-report-closed-mark))
+ (entry (profiler-report-make-entry-part entry)))
+ (format "%s%s %s" indent mark entry)))
+
+(defun profiler-report-header-line-format (fmt &rest args)
+ (let* ((header (apply 'profiler-format fmt args))
+ (escaped (replace-regexp-in-string "%" "%%" header)))
+ (concat " " escaped)))
+
+(defun profiler-report-line-format (tree)
+ (let ((diff-p (profiler-log-diff-p profiler-report-log))
+ (name-part (profiler-report-make-name-part tree))
+ (count (profiler-calltree-count tree))
+ (count-percent (profiler-calltree-count-percent tree)))
+ (profiler-format (cl-ecase (profiler-log-type profiler-report-log)
+ (cpu profiler-report-sample-line-format)
+ (memory profiler-report-memory-line-format))
+ name-part
+ (if diff-p
+ (list (if (> count 0)
+ (format "+%s" count)
+ count)
+ "")
+ (list count count-percent)))))
+
+(defun profiler-report-insert-calltree (tree)
+ (let ((line (profiler-report-line-format tree)))
+ (insert (propertize (concat line "\n") 'calltree tree))))
+
+(defun profiler-report-insert-calltree-children (tree)
+ (mapc 'profiler-report-insert-calltree
+ (profiler-calltree-children tree)))
+
+
+;;; Report mode
+
+(defvar profiler-report-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; FIXME: Add menu.
+ (define-key map "n" 'profiler-report-next-entry)
+ (define-key map "p" 'profiler-report-previous-entry)
+ ;; I find it annoying more than helpful to not be able to navigate
+ ;; normally with the cursor keys. --Stef
+ ;; (define-key map [down] 'profiler-report-next-entry)
+ ;; (define-key map [up] 'profiler-report-previous-entry)
+ (define-key map "\r" 'profiler-report-toggle-entry)
+ (define-key map "\t" 'profiler-report-toggle-entry)
+ (define-key map "i" 'profiler-report-toggle-entry)
+ (define-key map "f" 'profiler-report-find-entry)
+ (define-key map "j" 'profiler-report-find-entry)
+ (define-key map [mouse-2] 'profiler-report-find-entry)
+ (define-key map "d" 'profiler-report-describe-entry)
+ (define-key map "C" 'profiler-report-render-calltree)
+ (define-key map "B" 'profiler-report-render-reversed-calltree)
+ (define-key map "A" 'profiler-report-ascending-sort)
+ (define-key map "D" 'profiler-report-descending-sort)
+ (define-key map "=" 'profiler-report-compare-log)
+ (define-key map (kbd "C-x C-w") 'profiler-report-write-log)
+ (define-key map "q" 'quit-window)
+ map))
+
+(defun profiler-report-make-buffer-name (log)
+ (format "*%s-Profiler-Report %s*"
+ (cl-ecase (profiler-log-type log) (cpu 'CPU) (memory 'Memory))
+ (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log))))
+
+(defun profiler-report-setup-buffer (log)
+ "Make a buffer for LOG and return it."
+ (let* ((buf-name (profiler-report-make-buffer-name log))
+ (buffer (get-buffer-create buf-name)))
+ (with-current-buffer buffer
+ (profiler-report-mode)
+ (setq profiler-report-log log
+ profiler-report-reversed nil
+ profiler-report-order 'descending))
+ buffer))
+
+(define-derived-mode profiler-report-mode special-mode "Profiler-Report"
+ "Profiler Report Mode."
+ (setq buffer-read-only t
+ buffer-undo-list t
+ truncate-lines t))
+
+
+;;; Report commands
+
+(defun profiler-report-calltree-at-point ()
+ (get-text-property (point) 'calltree))
+
+(defun profiler-report-move-to-entry ()
+ (let ((point (next-single-property-change (line-beginning-position)
+ 'profiler-entry)))
+ (if point
+ (goto-char point)
+ (back-to-indentation))))
+
+(defun profiler-report-next-entry ()
+ "Move cursor to next entry."
+ (interactive)
+ (forward-line)
+ (profiler-report-move-to-entry))
+
+(defun profiler-report-previous-entry ()
+ "Move cursor to previous entry."
+ (interactive)
+ (forward-line -1)
+ (profiler-report-move-to-entry))
+
+(defun profiler-report-expand-entry ()
+ "Expand entry at point."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (when (search-forward (concat profiler-report-closed-mark " ")
+ (line-end-position) t)
+ (let ((tree (profiler-report-calltree-at-point)))
+ (when tree
+ (let ((inhibit-read-only t))
+ (replace-match (concat profiler-report-open-mark " "))
+ (forward-line)
+ (profiler-report-insert-calltree-children tree)
+ t))))))
+
+(defun profiler-report-collapse-entry ()
+ "Collpase entry at point."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (when (search-forward (concat profiler-report-open-mark " ")
+ (line-end-position) t)
+ (let* ((tree (profiler-report-calltree-at-point))
+ (depth (profiler-calltree-depth tree))
+ (start (line-beginning-position 2))
+ d)
+ (when tree
+ (let ((inhibit-read-only t))
+ (replace-match (concat profiler-report-closed-mark " "))
+ (while (and (eq (forward-line) 0)
+ (let ((child (get-text-property (point) 'calltree)))
+ (and child
+ (numberp (setq d (profiler-calltree-depth
child)))))
+ (> d depth)))
+ (delete-region start (line-beginning-position)))))
+ t)))
+
+(defun profiler-report-toggle-entry ()
+ "Expand entry at point if the tree is collapsed,
+otherwise collapse."
+ (interactive)
+ (or (profiler-report-expand-entry)
+ (profiler-report-collapse-entry)))
+
+(defun profiler-report-find-entry (&optional event)
+ "Find entry at point."
+ (interactive (list last-nonmenu-event))
+ (if event (posn-set-point (event-end event)))
+ (let ((tree (profiler-report-calltree-at-point)))
+ (when tree
+ (let ((entry (profiler-calltree-entry tree)))
+ (find-function entry)))))
+
+(defun profiler-report-describe-entry ()
+ "Describe entry at point."
+ (interactive)
+ (let ((tree (profiler-report-calltree-at-point)))
+ (when tree
+ (let ((entry (profiler-calltree-entry tree)))
+ (require 'help-fns)
+ (describe-function entry)))))
+
+(cl-defun profiler-report-render-calltree-1
+ (log &key reverse (order 'descending))
+ (let ((calltree (profiler-calltree-build profiler-report-log
+ :reverse reverse)))
+ (setq header-line-format
+ (cl-ecase (profiler-log-type log)
+ (cpu
+ (profiler-report-header-line-format
+ profiler-report-sample-line-format
+ "Function" (list "Time (ms)" "%")))
+ (memory
+ (profiler-report-header-line-format
+ profiler-report-memory-line-format
+ "Function" (list "Bytes" "%")))))
+ (let ((predicate (cl-ecase order
+ (ascending #'profiler-calltree-count<)
+ (descending #'profiler-calltree-count>))))
+ (profiler-calltree-sort calltree predicate))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (profiler-report-insert-calltree-children calltree)
+ (goto-char (point-min))
+ (profiler-report-move-to-entry))))
+
+(defun profiler-report-rerender-calltree ()
+ (profiler-report-render-calltree-1 profiler-report-log
+ :reverse profiler-report-reversed
+ :order profiler-report-order))
+
+(defun profiler-report-render-calltree ()
+ "Render calltree view."
+ (interactive)
+ (setq profiler-report-reversed nil)
+ (profiler-report-rerender-calltree))
+
+(defun profiler-report-render-reversed-calltree ()
+ "Render reversed calltree view."
+ (interactive)
+ (setq profiler-report-reversed t)
+ (profiler-report-rerender-calltree))
+
+(defun profiler-report-ascending-sort ()
+ "Sort calltree view in ascending order."
+ (interactive)
+ (setq profiler-report-order 'ascending)
+ (profiler-report-rerender-calltree))
+
+(defun profiler-report-descending-sort ()
+ "Sort calltree view in descending order."
+ (interactive)
+ (setq profiler-report-order 'descending)
+ (profiler-report-rerender-calltree))
+
+(defun profiler-report-log (log)
+ (let ((buffer (profiler-report-setup-buffer log)))
+ (with-current-buffer buffer
+ (profiler-report-render-calltree))
+ (pop-to-buffer buffer)))
+
+(defun profiler-report-compare-log (buffer)
+ "Compare the current profiler log with another."
+ (interactive (list (read-buffer "Compare to: ")))
+ (let* ((log1 (with-current-buffer buffer profiler-report-log))
+ (log2 profiler-report-log)
+ (diff-log (profiler-log-diff log1 log2)))
+ (profiler-report-log diff-log)))
+
+(defun profiler-report-write-log (filename &optional confirm)
+ "Write the current profiler log into FILENAME."
+ (interactive
+ (list (read-file-name "Write log: " default-directory)
+ (not current-prefix-arg)))
+ (profiler-log-write-file profiler-report-log
+ filename
+ confirm))
+
+
+;;; Profiler commands
+
+;;;###autoload
+(defun profiler-start (mode)
+ "Start/restart profilers.
+MODE can be one of `cpu', `mem', or `cpu+mem'.
+If MODE is `cpu' or `cpu+mem', time-based profiler will be started.
+Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started."
+ (interactive
+ (list (if (not (fboundp 'profiler-cpu-start)) 'mem
+ (intern (completing-read "Mode (default cpu): "
+ '("cpu" "mem" "cpu+mem")
+ nil t nil nil "cpu")))))
+ (cl-ecase mode
+ (cpu
+ (profiler-cpu-start profiler-sample-interval)
+ (message "CPU profiler started"))
+ (mem
+ (profiler-memory-start)
+ (message "Memory profiler started"))
+ (cpu+mem
+ (profiler-cpu-start profiler-sample-interval)
+ (profiler-memory-start)
+ (message "CPU and memory profiler started"))))
+
+(defun profiler-stop ()
+ "Stop started profilers. Profiler logs will be kept."
+ (interactive)
+ (let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop)))
+ (mem (profiler-memory-stop)))
+ (message "%s profiler stopped"
+ (cond ((and mem cpu) "CPU and memory")
+ (mem "Memory")
+ (cpu "CPU")
+ (t "No")))))
+
+(defun profiler-reset ()
+ "Reset profiler log."
+ (interactive)
+ (when (fboundp 'profiler-cpu-log)
+ (ignore (profiler-cpu-log)))
+ (ignore (profiler-memory-log))
+ t)
+
+(defun profiler--report-cpu ()
+ (let ((log (if (fboundp 'profiler-cpu-log) (profiler-cpu-log))))
+ (when log
+ (puthash 'type 'cpu log)
+ (puthash 'timestamp (current-time) log)
+ (profiler-report-log log))))
+
+(defun profiler--report-memory ()
+ (let ((log (profiler-memory-log)))
+ (when log
+ (puthash 'type 'memory log)
+ (puthash 'timestamp (current-time) log)
+ (profiler-report-log log))))
+
+(defun profiler-report ()
+ "Report profiling results."
+ (interactive)
+ (profiler--report-cpu)
+ (profiler--report-memory))
+
+;;;###autoload
+(defun profiler-find-log (filename)
+ "Read a profiler log from FILENAME and report it."
+ (interactive
+ (list (read-file-name "Find log: " default-directory)))
+ (profiler-report-log (profiler-log-read-file filename)))
+
+
+;;; Profiling helpers
+
+;; (cl-defmacro with-sample-profiling ((&key interval) &rest body)
+;; `(unwind-protect
+;; (progn
+;; (ignore (profiler-cpu-log))
+;; (profiler-cpu-start ,interval)
+;; ,@body)
+;; (profiler-cpu-stop)
+;; (profiler--report-cpu)))
+
+;; (defmacro with-memory-profiling (&rest body)
+;; `(unwind-protect
+;; (progn
+;; (ignore (profiler-memory-log))
+;; (profiler-memory-start)
+;; ,@body)
+;; (profiler-memory-stop)
+;; (profiler--report-memory)))
+
+(provide 'profiler)
+;;; profiler.el ends here
=== modified file 'src/ChangeLog'
--- a/src/ChangeLog 2012-09-26 14:44:22 +0000
+++ b/src/ChangeLog 2012-09-26 15:19:10 +0000
@@ -1,3 +1,29 @@
+2012-09-26 Tomohiro Matsuyama <address@hidden>
+ Stefan Monnier <address@hidden>
+ Juanma Barranquero <address@hidden>
+
+ * profiler.c: New file.
+ * Makefile.in (base_obj): Add profiler.o.
+ * makefile.w32-in (OBJ2, GLOBAL_SOURCES): Add profiler.c.
+ ($(BLD)/profiler.$(O)): New target.
+ * emacs.c (main): Call syms_of_profiler.
+ * alloc.c (Qautomatic_gc): New constant.
+ (MALLOC_PROBE): New macro.
+ (xmalloc, xzalloc, xrealloc, lisp_malloc, lisp_align_malloc): Use it.
+ (total_bytes_of_live_objects): New function.
+ (Fgarbage_collect): Use it. Record itself in backtrace_list.
+ Call malloc_probe for the memory profiler.
+ (syms_of_alloc): Define Qautomatic_gc.
+ * eval.c (eval_sub, Ffuncall): Reorder assignments to avoid
+ race condition.
+ (struct backtrace): Move definition...
+ * lisp.h (struct backtrace): ..here.
+ (Qautomatic_gc, profiler_memory_running): Declare vars.
+ (malloc_probe, syms_of_profiler): Declare functions.
+ * xdisp.c (Qautomatic_redisplay): New constant.
+ (redisplay_internal): Record itself in backtrace_list.
+ (syms_of_xdisp): Define Qautomatic_redisplay.
+
2012-09-25 Juanma Barranquero <address@hidden>
* makefile.w32-in ($(BLD)/callproc.$(O)): Update dependencies.
@@ -291,8 +317,8 @@
(reinvoke_input_signal): Remove. All uses replaced by
handle_async_input.
(quit_count): Now volatile, since a signal handler uses it.
- (handle_interrupt): Now takes bool IN_SIGNAL_HANDLER as arg. All
- callers changed. Block SIGINT only if not already blocked.
+ (handle_interrupt): Now takes bool IN_SIGNAL_HANDLER as arg.
+ All callers changed. Block SIGINT only if not already blocked.
Clear sigmask reliably, even if Fsignal returns, which it can.
Omit unnecessary accesses to volatile var.
(quit_throw_to_read_char): No need to restore sigmask.
@@ -392,8 +418,8 @@
if it is defined. Arguments and return value changed.
(valid_image_p, make_image): Callers changed.
(xbm_type, xpm_type, pbm_type, png_type, jpeg_type, tiff_type)
- (gif_type, imagemagick_type, svg_type, gs_type): Add
- initialization functions.
+ (gif_type, imagemagick_type, svg_type, gs_type):
+ Add initialization functions.
(Finit_image_library): Call lookup_image_type.
(CHECK_LIB_AVAILABLE): Macro deleted.
(lookup_image_type): Call define_image_type here, rather than via
@@ -415,8 +441,8 @@
* window.c (Fsplit_window_internal): Handle only Qt value of
Vwindow_combination_limit separately.
(Qtemp_buffer_resize): New symbol.
- (Vwindow_combination_limit): New default value. Rewrite
- doc-string.
+ (Vwindow_combination_limit): New default value.
+ Rewrite doc-string.
2012-09-22 Eli Zaretskii <address@hidden>
@@ -515,7 +541,7 @@
(Fx_create_frame): Call x_set_offset to correctly interpret
top_pos in geometry.
- * frame.c (read_integer, XParseGeometry): Moved from w32xfns.c.
+ * frame.c (read_integer, XParseGeometry): Move from w32xfns.c.
(Fx_parse_geometry): If there is a space in string, call
Qns_parse_geometry, otherwise do as on other terms (Bug#12368).
@@ -616,8 +642,8 @@
2012-09-16 Martin Rudalics <address@hidden>
- * window.c (Fwindow_parameter, Fset_window_parameter): Accept
- any window as argument (Bug#12452).
+ * window.c (Fwindow_parameter, Fset_window_parameter):
+ Accept any window as argument (Bug#12452).
2012-09-16 Jan Djärv <address@hidden>
@@ -692,8 +718,8 @@
2012-09-14 Dmitry Antipov <address@hidden>
Avoid out-of-range marker position (Bug#12426).
- * insdel.c (replace_range, replace_range_2): Adjust
- markers before overlays, as suggested by comments.
+ * insdel.c (replace_range, replace_range_2):
+ Adjust markers before overlays, as suggested by comments.
(insert_1_both, insert_from_buffer_1, adjust_after_replace):
Remove redundant check before calling offset_intervals.
@@ -992,8 +1018,8 @@
in the internal border.
(x_set_window_size): Remove static variables and their usage.
(ns_redraw_scroll_bars): Fix NSTRACE arg.
- (ns_after_update_window_line, ns_draw_fringe_bitmap): Remove
- fringe/internal border adjustment (Bug#11052).
+ (ns_after_update_window_line, ns_draw_fringe_bitmap):
+ Remove fringe/internal border adjustment (Bug#11052).
(ns_draw_fringe_bitmap): Make code more like other terms (xterm.c).
(ns_draw_window_cursor): Remove fringe/internal border adjustment.
(ns_fix_rect_ibw): Remove.
@@ -1210,8 +1236,8 @@
(init_signals) [FORWARD_SIGNAL_TO_MAIN_THREAD]: Initialize it;
code moved here from emacs.c's main function.
* sysdep.c, syssignal.h (handle_on_main_thread): New function,
- replacing the old SIGNAL_THREAD_CHECK. All uses changed. This
- lets callers save and restore errno properly.
+ replacing the old SIGNAL_THREAD_CHECK. All uses changed.
+ This lets callers save and restore errno properly.
2012-09-05 Dmitry Antipov <address@hidden>
@@ -1520,8 +1546,8 @@
* process.c: Include TERM_HEADER instead of listing all possible
window-system headers.
- * nsterm.h: Remove declarations now in frame.h. Define
- FRAME_X_SCREEN, FRAME_X_VISUAL.
+ * nsterm.h: Remove declarations now in frame.h.
+ Define FRAME_X_SCREEN, FRAME_X_VISUAL.
* menu.c: Include TERM_HEADER instead of listing all possible
window-system headers.
@@ -1717,8 +1743,8 @@
* nsterm.h (NSPanel): New class variable dialog_return.
- * nsmenu.m (initWithContentRect:styleMask:backing:defer:): Initialize
- dialog_return.
+ * nsmenu.m (initWithContentRect:styleMask:backing:defer:):
+ Initialize dialog_return.
(windowShouldClose:): Use stop instead of stopModalWithCode.
(clicked:): Ditto, and also set dialog_return (Bug#12258).
(timeout_handler:): Use stop instead of abortModal. Send a dummy
=== modified file 'src/Makefile.in'
--- a/src/Makefile.in 2012-09-16 19:17:20 +0000
+++ b/src/Makefile.in 2012-09-26 15:19:10 +0000
@@ -339,6 +339,7 @@
process.o gnutls.o callproc.o \
region-cache.o sound.o atimer.o \
doprnt.o intervals.o textprop.o composite.o xml.o \
+ profiler.o \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
$(WINDOW_SYSTEM_OBJ)
obj = $(base_obj) $(NS_OBJC_OBJ)
=== modified file 'src/alloc.c'
--- a/src/alloc.c 2012-09-23 17:05:14 +0000
+++ b/src/alloc.c 2012-09-26 15:19:10 +0000
@@ -205,6 +205,7 @@
static Lisp_Object Qbuffers;
static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
static Lisp_Object Qgc_cons_threshold;
+Lisp_Object Qautomatic_gc;
Lisp_Object Qchar_table_extra_slots;
/* Hook run after GC has finished. */
@@ -648,6 +649,13 @@
# define MALLOC_UNBLOCK_INPUT ((void) 0)
#endif
+#define MALLOC_PROBE(size) \
+ do { \
+ if (profiler_memory_running) \
+ malloc_probe (size); \
+ } while (0)
+
+
/* Like malloc but check for no memory and block interrupt input.. */
void *
@@ -661,6 +669,7 @@
if (!val && size)
memory_full (size);
+ MALLOC_PROBE (size);
return val;
}
@@ -678,6 +687,7 @@
if (!val && size)
memory_full (size);
memset (val, 0, size);
+ MALLOC_PROBE (size);
return val;
}
@@ -699,6 +709,7 @@
if (!val && size)
memory_full (size);
+ MALLOC_PROBE (size);
return val;
}
@@ -888,6 +899,7 @@
MALLOC_UNBLOCK_INPUT;
if (!val && nbytes)
memory_full (nbytes);
+ MALLOC_PROBE (nbytes);
return val;
}
@@ -1093,6 +1105,8 @@
MALLOC_UNBLOCK_INPUT;
+ MALLOC_PROBE (nbytes);
+
eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
return val;
}
@@ -5043,6 +5057,23 @@
return make_number (min (MOST_POSITIVE_FIXNUM, number));
}
+/* Calculate total bytes of live objects. */
+
+static size_t
+total_bytes_of_live_objects (void)
+{
+ size_t tot = 0;
+ tot += total_conses * sizeof (struct Lisp_Cons);
+ tot += total_symbols * sizeof (struct Lisp_Symbol);
+ tot += total_markers * sizeof (union Lisp_Misc);
+ tot += total_string_bytes;
+ tot += total_vector_slots * word_size;
+ tot += total_floats * sizeof (struct Lisp_Float);
+ tot += total_intervals * sizeof (struct interval);
+ tot += total_strings * sizeof (struct Lisp_String);
+ return tot;
+}
+
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: /* Reclaim storage for Lisp objects no longer needed.
Garbage collection happens automatically if you cons more than
@@ -5068,6 +5099,8 @@
ptrdiff_t count = SPECPDL_INDEX ();
EMACS_TIME start;
Lisp_Object retval = Qnil;
+ size_t tot_before = 0;
+ struct backtrace backtrace;
if (abort_on_gc)
emacs_abort ();
@@ -5077,6 +5110,14 @@
if (pure_bytes_used_before_overflow)
return Qnil;
+ /* Record this function, so it appears on the profiler's backtraces. */
+ backtrace.next = backtrace_list;
+ backtrace.function = &Qautomatic_gc;
+ backtrace.args = &Qautomatic_gc;
+ backtrace.nargs = 0;
+ backtrace.debug_on_exit = 0;
+ backtrace_list = &backtrace;
+
check_cons_list ();
/* Don't keep undo information around forever.
@@ -5084,6 +5125,9 @@
FOR_EACH_BUFFER (nextb)
compact_buffer (nextb);
+ if (profiler_memory_running)
+ tot_before = total_bytes_of_live_objects ();
+
start = current_emacs_time ();
/* In case user calls debug_print during GC,
@@ -5255,16 +5299,7 @@
gc_relative_threshold = 0;
if (FLOATP (Vgc_cons_percentage))
{ /* Set gc_cons_combined_threshold. */
- double tot = 0;
-
- tot += total_conses * sizeof (struct Lisp_Cons);
- tot += total_symbols * sizeof (struct Lisp_Symbol);
- tot += total_markers * sizeof (union Lisp_Misc);
- tot += total_string_bytes;
- tot += total_vector_slots * word_size;
- tot += total_floats * sizeof (struct Lisp_Float);
- tot += total_intervals * sizeof (struct interval);
- tot += total_strings * sizeof (struct Lisp_String);
+ double tot = total_bytes_of_live_objects ();
tot *= XFLOAT_DATA (Vgc_cons_percentage);
if (0 < tot)
@@ -5367,6 +5402,17 @@
gcs_done++;
+ /* Collect profiling data. */
+ if (profiler_memory_running)
+ {
+ size_t swept = 0;
+ size_t tot_after = total_bytes_of_live_objects ();
+ if (tot_before > tot_after)
+ swept = tot_before - tot_after;
+ malloc_probe (swept);
+ }
+
+ backtrace_list = backtrace.next;
return retval;
}
@@ -6527,6 +6573,7 @@
DEFSYM (Qstring_bytes, "string-bytes");
DEFSYM (Qvector_slots, "vector-slots");
DEFSYM (Qheap, "heap");
+ DEFSYM (Qautomatic_gc, "Automatic GC");
DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
=== modified file 'src/emacs.c'
--- a/src/emacs.c 2012-09-25 11:57:30 +0000
+++ b/src/emacs.c 2012-09-26 15:19:10 +0000
@@ -1419,6 +1419,8 @@
syms_of_ntterm ();
#endif /* WINDOWSNT */
+ syms_of_profiler ();
+
keys_of_casefiddle ();
keys_of_cmds ();
keys_of_buffer ();
=== modified file 'src/eval.c'
--- a/src/eval.c 2012-09-23 08:44:20 +0000
+++ b/src/eval.c 2012-09-26 15:19:10 +0000
@@ -31,17 +31,7 @@
#include "xterm.h"
#endif
-struct backtrace
-{
- struct backtrace *next;
- Lisp_Object *function;
- Lisp_Object *args; /* Points to vector of args. */
- ptrdiff_t nargs; /* Length of vector. */
- /* Nonzero means call value of debugger when done with this operation. */
- unsigned int debug_on_exit : 1;
-};
-
-static struct backtrace *backtrace_list;
+struct backtrace *backtrace_list;
#if !BYTE_MARK_STACK
static
@@ -2055,11 +2045,11 @@
original_args = XCDR (form);
backtrace.next = backtrace_list;
- backtrace_list = &backtrace;
backtrace.function = &original_fun; /* This also protects them from gc. */
backtrace.args = &original_args;
backtrace.nargs = UNEVALLED;
backtrace.debug_on_exit = 0;
+ backtrace_list = &backtrace;
if (debug_on_next_call)
do_debug_on_call (Qt);
@@ -2730,11 +2720,11 @@
}
backtrace.next = backtrace_list;
- backtrace_list = &backtrace;
backtrace.function = &args[0];
backtrace.args = &args[1]; /* This also GCPROs them. */
backtrace.nargs = nargs - 1;
backtrace.debug_on_exit = 0;
+ backtrace_list = &backtrace;
/* Call GC after setting up the backtrace, so the latter GCPROs the args. */
maybe_gc ();
=== modified file 'src/lisp.h'
--- a/src/lisp.h 2012-09-25 11:57:30 +0000
+++ b/src/lisp.h 2012-09-26 15:19:10 +0000
@@ -2031,6 +2031,18 @@
#define SPECPDL_INDEX() (specpdl_ptr - specpdl)
+struct backtrace
+{
+ struct backtrace *next;
+ Lisp_Object *function;
+ Lisp_Object *args; /* Points to vector of args. */
+ ptrdiff_t nargs; /* Length of vector. */
+ /* Nonzero means call value of debugger when done with this operation. */
+ unsigned int debug_on_exit : 1;
+};
+
+extern struct backtrace *backtrace_list;
+
/* Everything needed to describe an active condition case.
Members are volatile if their values need to survive _longjmp when
@@ -2916,6 +2928,7 @@
extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
extern void make_byte_code (struct Lisp_Vector *);
+extern Lisp_Object Qautomatic_gc;
extern Lisp_Object Qchar_table_extra_slots;
extern struct Lisp_Vector *allocate_vector (EMACS_INT);
extern struct Lisp_Vector *allocate_pseudovector (int memlen, int lisplen, int
tag);
@@ -3534,6 +3547,13 @@
void syms_of_dbusbind (void);
#endif
+
+/* Defined in profiler.c. */
+extern bool profiler_memory_running;
+extern void malloc_probe (size_t);
+extern void syms_of_profiler (void);
+
+
#ifdef DOS_NT
/* Defined in msdos.c, w32.c. */
extern char *emacs_root_dir (void);
=== modified file 'src/makefile.w32-in'
--- a/src/makefile.w32-in 2012-09-25 22:07:22 +0000
+++ b/src/makefile.w32-in 2012-09-26 15:19:10 +0000
@@ -125,6 +125,7 @@
$(BLD)/terminal.$(O) \
$(BLD)/menu.$(O) \
$(BLD)/xml.$(O) \
+ $(BLD)/profiler.$(O) \
$(BLD)/w32term.$(O) \
$(BLD)/w32xfns.$(O) \
$(BLD)/w32fns.$(O) \
@@ -222,7 +223,7 @@
process.c callproc.c unexw32.c \
region-cache.c sound.c atimer.c \
doprnt.c intervals.c textprop.c composite.c \
- gnutls.c xml.c
+ gnutls.c xml.c profiler.c
SOME_MACHINE_OBJECTS = dosfns.o msdos.o \
xterm.o xfns.o xmenu.o xselect.o xrdb.o xsmfns.o dbusbind.o
obj = $(GLOBAL_SOURCES:.c=.o)
@@ -973,6 +974,11 @@
$(CONFIG_H) \
$(LISP_H)
+$(BLD)/profiler.$(O) : \
+ $(SRC)/profiler.c \
+ $(CONFIG_H) \
+ $(LISP_H)
+
$(BLD)/image.$(O) : \
$(SRC)/image.c \
$(SRC)/blockinput.h \
=== added file 'src/profiler.c'
--- a/src/profiler.c 1970-01-01 00:00:00 +0000
+++ b/src/profiler.c 2012-09-26 15:19:10 +0000
@@ -0,0 +1,426 @@
+/* Profiler implementation.
+
+Copyright (C) 2012 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <stdio.h>
+#include <limits.h>
+#include <sys/time.h>
+#include <signal.h>
+#include <setjmp.h>
+#include "lisp.h"
+
+/* Logs. */
+
+typedef struct Lisp_Hash_Table log_t;
+
+static Lisp_Object
+make_log (int heap_size, int max_stack_depth)
+{
+ /* We use a standard Elisp hash-table object, but we use it in
+ a special way. This is OK as long as the object is not exposed
+ to Elisp, i.e. until it is returned by *-profiler-log, after which
+ it can't be used any more. */
+ Lisp_Object log = make_hash_table (Qequal, make_number (heap_size),
+ make_float (DEFAULT_REHASH_SIZE),
+ make_float (DEFAULT_REHASH_THRESHOLD),
+ Qnil, Qnil, Qnil);
+ struct Lisp_Hash_Table *h = XHASH_TABLE (log);
+
+ /* What is special about our hash-tables is that the keys are pre-filled
+ with the vectors we'll put in them. */
+ int i = ASIZE (h->key_and_value) / 2;
+ while (0 < i)
+ set_hash_key_slot (h, --i,
+ Fmake_vector (make_number (max_stack_depth), Qnil));
+ return log;
+}
+
+/* Evict the least used half of the hash_table.
+
+ When the table is full, we have to evict someone.
+ The easiest and most efficient is to evict the value we're about to add
+ (i.e. once the table is full, stop sampling).
+
+ We could also pick the element with the lowest count and evict it,
+ but finding it is O(N) and for that amount of work we get very
+ little in return: for the next sample, this latest sample will have
+ count==1 and will hence be a prime candidate for eviction :-(
+
+ So instead, we take O(N) time to eliminate more or less half of the
+ entries (the half with the lowest counts). So we get an amortized
+ cost of O(1) and we get O(N) time for a new entry to grow larger
+ than the other least counts before a new round of eviction. */
+
+static EMACS_INT approximate_median (log_t *log,
+ ptrdiff_t start, ptrdiff_t size)
+{
+ eassert (size > 0);
+ if (size < 2)
+ return XINT (HASH_VALUE (log, start));
+ if (size < 3)
+ /* Not an actual median, but better for our application than
+ choosing either of the two numbers. */
+ return ((XINT (HASH_VALUE (log, start))
+ + XINT (HASH_VALUE (log, start + 1)))
+ / 2);
+ else
+ {
+ ptrdiff_t newsize = size / 3;
+ ptrdiff_t start2 = start + newsize;
+ EMACS_INT i1 = approximate_median (log, start, newsize);
+ EMACS_INT i2 = approximate_median (log, start2, newsize);
+ EMACS_INT i3 = approximate_median (log, start2 + newsize,
+ size - 2 * newsize);
+ return (i1 < i2
+ ? (i2 < i3 ? i2 : (i1 < i3 ? i3 : i1))
+ : (i1 < i3 ? i1 : (i2 < i3 ? i3 : i2)));
+ }
+}
+
+static void evict_lower_half (log_t *log)
+{
+ ptrdiff_t size = ASIZE (log->key_and_value) / 2;
+ EMACS_INT median = approximate_median (log, 0, size);
+ ptrdiff_t i;
+
+ for (i = 0; i < size; i++)
+ /* Evict not only values smaller but also values equal to the median,
+ so as to make sure we evict something no matter what. */
+ if (XINT (HASH_VALUE (log, i)) <= median)
+ {
+ Lisp_Object key = HASH_KEY (log, i);
+ { /* FIXME: we could make this more efficient. */
+ Lisp_Object tmp;
+ XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */
+ Fremhash (key, tmp);
+ }
+ eassert (EQ (log->next_free, make_number (i)));
+ {
+ int j;
+ eassert (VECTORP (key));
+ for (j = 0; j < ASIZE (key); j++)
+ ASET (key, j, Qnil);
+ }
+ set_hash_key_slot (log, i, key);
+ }
+}
+
+/* Record the current backtrace in LOG. BASE is a special name for
+ describing which the backtrace come from. BASE can be nil. COUNT is
+ a number how many times the profiler sees the backtrace at the
+ time. ELAPSED is a elapsed time in millisecond that the backtrace
+ took. */
+
+static void
+record_backtrace (log_t *log, size_t count)
+{
+ struct backtrace *backlist = backtrace_list;
+ Lisp_Object backtrace;
+ ptrdiff_t index, i = 0;
+ ptrdiff_t asize;
+
+ if (!INTEGERP (log->next_free))
+ /* FIXME: transfer the evicted counts to a special entry rather
+ than dropping them on the floor. */
+ evict_lower_half (log);
+ index = XINT (log->next_free);
+
+ /* Get a "working memory" vector. */
+ backtrace = HASH_KEY (log, index);
+ asize = ASIZE (backtrace);
+
+ /* Copy the backtrace contents into working memory. */
+ for (; i < asize && backlist; i++, backlist = backlist->next)
+ /* FIXME: For closures we should ignore the environment. */
+ ASET (backtrace, i, *backlist->function);
+
+ /* Make sure that unused space of working memory is filled with nil. */
+ for (; i < asize; i++)
+ ASET (backtrace, i, Qnil);
+
+ { /* We basically do a `gethash+puthash' here, except that we have to be
+ careful to avoid memory allocation since we're in a signal
+ handler, and we optimize the code to try and avoid computing the
+ hash+lookup twice. See fns.c:Fputhash for reference. */
+ EMACS_UINT hash;
+ ptrdiff_t j = hash_lookup (log, backtrace, &hash);
+ if (j >= 0)
+ set_hash_value_slot (log, j,
+ make_number (count + XINT (HASH_VALUE (log, j))));
+ else
+ { /* BEWARE! hash_put in general can allocate memory.
+ But currently it only does that if log->next_free is nil. */
+ int j;
+ eassert (!NILP (log->next_free));
+ j = hash_put (log, backtrace, make_number (count), hash);
+ /* Let's make sure we've put `backtrace' right where it
+ already was to start with. */
+ eassert (index == j);
+
+ /* FIXME: If the hash-table is almost full, we should set
+ some global flag so that some Elisp code can offload its
+ data elsewhere, so as to avoid the eviction code.
+ There are 2 ways to do that, AFAICT:
+ - Set a flag checked in QUIT, such that QUIT can then call
+ Fprofiler_cpu_log and stash the full log for later use.
+ - Set a flag check in post-gc-hook, so that Elisp code can call
+ profiler-cpu-log. That gives us more flexibility since that
+ Elisp code can then do all kinds of fun stuff like write
+ the log to disk. Or turn it right away into a call tree.
+ Of course, using Elisp is generally preferable, but it may
+ take longer until we get a chance to run the Elisp code, so
+ there's more risk that the table will get full before we
+ get there. */
+ }
+ }
+}
+
+/* Sample profiler. */
+
+/* FIXME: Add support for the CPU profiler in W32. */
+/* FIXME: the sigprof_handler suffers from race-conditions if the signal
+ is delivered to a thread other than the main Emacs thread. */
+
+#if defined SIGPROF && defined HAVE_SETITIMER
+#define PROFILER_CPU_SUPPORT
+
+/* True if sampling profiler is running. */
+static bool profiler_cpu_running;
+
+static Lisp_Object cpu_log;
+/* Separate counter for the time spent in the GC. */
+static EMACS_INT cpu_gc_count;
+
+/* The current sample interval in millisecond. */
+
+static int current_sample_interval;
+
+/* Signal handler for sample profiler. */
+
+static void
+sigprof_handler (int signal, siginfo_t *info, void *ctx)
+{
+ eassert (HASH_TABLE_P (cpu_log));
+ if (backtrace_list && EQ (*backtrace_list->function, Qautomatic_gc))
+ /* Special case the time-count inside GC because the hash-table
+ code is not prepared to be used while the GC is running.
+ More specifically it uses ASIZE at many places where it does
+ not expect the ARRAY_MARK_FLAG to be set. We could try and
+ harden the hash-table code, but it doesn't seem worth the
+ effort. */
+ cpu_gc_count += current_sample_interval;
+ else
+ record_backtrace (XHASH_TABLE (cpu_log), current_sample_interval);
+}
+
+DEFUN ("profiler-cpu-start", Fprofiler_cpu_start, Sprofiler_cpu_start,
+ 1, 1, 0,
+ doc: /* Start or restart the cpu profiler.
+The cpu profiler will take call-stack samples each SAMPLE-INTERVAL (expressed
in milliseconds).
+See also `profiler-log-size' and `profiler-max-stack-depth'. */)
+ (Lisp_Object sample_interval)
+{
+ struct sigaction sa;
+ struct itimerval timer;
+
+ if (profiler_cpu_running)
+ error ("Sample profiler is already running");
+
+ if (NILP (cpu_log))
+ {
+ cpu_gc_count = 0;
+ cpu_log = make_log (profiler_log_size,
+ profiler_max_stack_depth);
+ }
+
+ current_sample_interval = XINT (sample_interval);
+
+ sa.sa_sigaction = sigprof_handler;
+ sa.sa_flags = SA_RESTART | SA_SIGINFO;
+ sigemptyset (&sa.sa_mask);
+ sigaction (SIGPROF, &sa, 0);
+
+ timer.it_interval.tv_sec = 0;
+ timer.it_interval.tv_usec = current_sample_interval * 1000;
+ timer.it_value = timer.it_interval;
+ setitimer (ITIMER_PROF, &timer, 0);
+
+ profiler_cpu_running = true;
+
+ return Qt;
+}
+
+DEFUN ("profiler-cpu-stop", Fprofiler_cpu_stop, Sprofiler_cpu_stop,
+ 0, 0, 0,
+ doc: /* Stop the cpu profiler. The profiler log is not affected.
+Return non-nil if the profiler was running. */)
+ (void)
+{
+ if (!profiler_cpu_running)
+ return Qnil;
+ profiler_cpu_running = false;
+
+ setitimer (ITIMER_PROF, 0, 0);
+
+ return Qt;
+}
+
+DEFUN ("profiler-cpu-running-p",
+ Fprofiler_cpu_running_p, Sprofiler_cpu_running_p,
+ 0, 0, 0,
+ doc: /* Return non-nil iff cpu profiler is running. */)
+ (void)
+{
+ return profiler_cpu_running ? Qt : Qnil;
+}
+
+DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_log,
+ 0, 0, 0,
+ doc: /* Return the current cpu profiler log.
+The log is a hash-table mapping backtraces to counters which represent
+the amount of time spent at those points. Every backtrace is a vector
+of functions, where the last few elements may be nil.
+Before returning, a new log is allocated for future samples. */)
+ (void)
+{
+ Lisp_Object result = cpu_log;
+ /* Here we're making the log visible to Elisp , so it's not safe any
+ more for our use afterwards since we can't rely on its special
+ pre-allocated keys anymore. So we have to allocate a new one. */
+ cpu_log = (profiler_cpu_running
+ ? make_log (profiler_log_size, profiler_max_stack_depth)
+ : Qnil);
+ Fputhash (Fmake_vector (make_number (1), Qautomatic_gc),
+ make_number (cpu_gc_count),
+ result);
+ cpu_gc_count = 0;
+ return result;
+}
+#endif /* not defined PROFILER_CPU_SUPPORT */
+
+/* Memory profiler. */
+
+/* True if memory profiler is running. */
+bool profiler_memory_running;
+
+static Lisp_Object memory_log;
+
+DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start,
+ 0, 0, 0,
+ doc: /* Start/restart the memory profiler.
+The memory profiler will take samples of the call-stack whenever a new
+allocation takes place. Note that most small allocations only trigger
+the profiler occasionally.
+See also `profiler-log-size' and `profiler-max-stack-depth'. */)
+ (void)
+{
+ if (profiler_memory_running)
+ error ("Memory profiler is already running");
+
+ if (NILP (memory_log))
+ memory_log = make_log (profiler_log_size,
+ profiler_max_stack_depth);
+
+ profiler_memory_running = true;
+
+ return Qt;
+}
+
+DEFUN ("profiler-memory-stop",
+ Fprofiler_memory_stop, Sprofiler_memory_stop,
+ 0, 0, 0,
+ doc: /* Stop the memory profiler. The profiler log is not affected.
+Return non-nil if the profiler was running. */)
+ (void)
+{
+ if (!profiler_memory_running)
+ return Qnil;
+ profiler_memory_running = false;
+ return Qt;
+}
+
+DEFUN ("profiler-memory-running-p",
+ Fprofiler_memory_running_p, Sprofiler_memory_running_p,
+ 0, 0, 0,
+ doc: /* Return non-nil if memory profiler is running. */)
+ (void)
+{
+ return profiler_memory_running ? Qt : Qnil;
+}
+
+DEFUN ("profiler-memory-log",
+ Fprofiler_memory_log, Sprofiler_memory_log,
+ 0, 0, 0,
+ doc: /* Return the current memory profiler log.
+The log is a hash-table mapping backtraces to counters which represent
+the amount of memory allocated at those points. Every backtrace is a vector
+of functions, where the last few elements may be nil.
+Before returning, a new log is allocated for future samples. */)
+ (void)
+{
+ Lisp_Object result = memory_log;
+ /* Here we're making the log visible to Elisp , so it's not safe any
+ more for our use afterwards since we can't rely on its special
+ pre-allocated keys anymore. So we have to allocate a new one. */
+ memory_log = (profiler_memory_running
+ ? make_log (profiler_log_size, profiler_max_stack_depth)
+ : Qnil);
+ return result;
+}
+
+
+/* Signals and probes. */
+
+/* Record that the current backtrace allocated SIZE bytes. */
+void
+malloc_probe (size_t size)
+{
+ eassert (HASH_TABLE_P (memory_log));
+ record_backtrace (XHASH_TABLE (memory_log), size);
+}
+
+void
+syms_of_profiler (void)
+{
+ DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
+ doc: /* Number of elements from the call-stack recorded in the
log. */);
+ profiler_max_stack_depth = 16;
+ DEFVAR_INT ("profiler-log-size", profiler_log_size,
+ doc: /* Number of distinct call-stacks that can be recorded in a
profiler log.
+If the log gets full, some of the least-seen call-stacks will be evicted
+to make room for new entries. */);
+ profiler_log_size = 10000;
+
+#ifdef PROFILER_CPU_SUPPORT
+ profiler_cpu_running = false;
+ cpu_log = Qnil;
+ staticpro (&cpu_log);
+ defsubr (&Sprofiler_cpu_start);
+ defsubr (&Sprofiler_cpu_stop);
+ defsubr (&Sprofiler_cpu_running_p);
+ defsubr (&Sprofiler_cpu_log);
+#endif
+ profiler_memory_running = false;
+ memory_log = Qnil;
+ staticpro (&memory_log);
+ defsubr (&Sprofiler_memory_start);
+ defsubr (&Sprofiler_memory_stop);
+ defsubr (&Sprofiler_memory_running_p);
+ defsubr (&Sprofiler_memory_log);
+}
=== modified file 'src/xdisp.c'
--- a/src/xdisp.c 2012-09-25 04:13:02 +0000
+++ b/src/xdisp.c 2012-09-26 15:19:10 +0000
@@ -333,10 +333,10 @@
static Lisp_Object Qbuffer_position, Qposition, Qobject;
static Lisp_Object Qright_to_left, Qleft_to_right;
-/* Cursor shapes */
+/* Cursor shapes. */
Lisp_Object Qbar, Qhbar, Qbox, Qhollow;
-/* Pointer shapes */
+/* Pointer shapes. */
static Lisp_Object Qarrow, Qhand;
Lisp_Object Qtext;
@@ -347,6 +347,7 @@
static Lisp_Object Qwrap_prefix;
static Lisp_Object Qline_prefix;
+static Lisp_Object Qautomatic_redisplay;
/* Non-nil means don't actually do any redisplay. */
@@ -12929,12 +12930,13 @@
struct frame *sf;
int polling_stopped_here = 0;
Lisp_Object old_frame = selected_frame;
+ struct backtrace backtrace;
/* Non-zero means redisplay has to consider all windows on all
frames. Zero means, only selected_window is considered. */
int consider_all_windows_p;
- /* Non-zero means redisplay has to redisplay the miniwindow */
+ /* Non-zero means redisplay has to redisplay the miniwindow. */
int update_miniwindow_p = 0;
TRACE ((stderr, "redisplay_internal %d\n", redisplaying_p));
@@ -12971,6 +12973,14 @@
redisplaying_p = 1;
specbind (Qinhibit_free_realized_faces, Qnil);
+ /* Record this function, so it appears on the profiler's backtraces. */
+ backtrace.next = backtrace_list;
+ backtrace.function = &Qautomatic_redisplay;
+ backtrace.args = &Qautomatic_redisplay;
+ backtrace.nargs = 0;
+ backtrace.debug_on_exit = 0;
+ backtrace_list = &backtrace;
+
{
Lisp_Object tail, frame;
@@ -13668,6 +13678,7 @@
#endif /* HAVE_WINDOW_SYSTEM */
end_of_redisplay:
+ backtrace_list = backtrace.next;
unbind_to (count, Qnil);
RESUME_POLLING;
}
@@ -28683,6 +28694,7 @@
staticpro (&Vmessage_stack);
DEFSYM (Qinhibit_redisplay, "inhibit-redisplay");
+ DEFSYM (Qautomatic_redisplay, "Automatic Redisplay");
message_dolog_marker1 = Fmake_marker ();
staticpro (&message_dolog_marker1);
@@ -29349,7 +29361,7 @@
the following three functions in w32fns.c. */
#ifndef WINDOWSNT
-/* Platform-independent portion of hourglass implementation. */
+/* Platform-independent portion of hourglass implementation. */
/* Cancel a currently active hourglass timer, and start a new one. */
void
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] /srv/bzr/emacs/trunk r110206: Merge profiler branch,
Stefan Monnier <=