diff options
-rw-r--r-- | etc/NEWS | 5 | ||||
-rw-r--r-- | lisp/ChangeLog | 5 | ||||
-rw-r--r-- | lisp/profiler.el | 665 | ||||
-rw-r--r-- | src/ChangeLog | 64 | ||||
-rw-r--r-- | src/Makefile.in | 1 | ||||
-rw-r--r-- | src/alloc.c | 67 | ||||
-rw-r--r-- | src/emacs.c | 2 | ||||
-rw-r--r-- | src/eval.c | 16 | ||||
-rw-r--r-- | src/lisp.h | 20 | ||||
-rw-r--r-- | src/makefile.w32-in | 8 | ||||
-rw-r--r-- | src/profiler.c | 426 | ||||
-rw-r--r-- | src/xdisp.c | 20 |
12 files changed, 1252 insertions, 47 deletions
@@ -678,6 +678,11 @@ are deprecated and will be removed eventually. * 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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 4599855e28d..349d74aa7d7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-09-26 Tomohiro Matsuyama <tomo@cx4a.org> + Stefan Monnier <monnier@iro.umontreal.ca> + + * profiler.el: New file. + 2012-09-26 Stefan Monnier <monnier@iro.umontreal.ca> * emacs-lisp/testcover.el (testcover-after): Add gv-expander. diff --git a/lisp/profiler.el b/lisp/profiler.el new file mode 100644 index 00000000000..5fc74573262 --- /dev/null +++ b/lisp/profiler.el @@ -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 <tomo@cx4a.org> +;; 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 diff --git a/src/ChangeLog b/src/ChangeLog index 3e999f3f699..47e2b7a7fea 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,29 @@ +2012-09-26 Tomohiro Matsuyama <tomo@cx4a.org> + Stefan Monnier <monnier@iro.umontreal.ca> + Juanma Barranquero <lekktu@gmail.com> + + * 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 <lekktu@gmail.com> * 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 <eliz@gnu.org> @@ -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 <rudalics@gmx.at> - * 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 <jan.h.d@swipnet.se> @@ -692,8 +718,8 @@ 2012-09-14 Dmitry Antipov <dmantipov@yandex.ru> 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 <dmantipov@yandex.ru> @@ -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 diff --git a/src/Makefile.in b/src/Makefile.in index 37da170edbd..e43f83e1172 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -339,6 +339,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ 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) diff --git a/src/alloc.c b/src/alloc.c index 923e8736a86..46c9a10c725 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -205,6 +205,7 @@ static Lisp_Object Qintervals; 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 @@ malloc_unblock_input (void) # 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 @@ xmalloc (size_t size) if (!val && size) memory_full (size); + MALLOC_PROBE (size); return val; } @@ -678,6 +687,7 @@ xzalloc (size_t size) if (!val && size) memory_full (size); memset (val, 0, size); + MALLOC_PROBE (size); return val; } @@ -699,6 +709,7 @@ xrealloc (void *block, size_t size) if (!val && size) memory_full (size); + MALLOC_PROBE (size); return val; } @@ -888,6 +899,7 @@ lisp_malloc (size_t nbytes, enum mem_type type) MALLOC_UNBLOCK_INPUT; if (!val && nbytes) memory_full (nbytes); + MALLOC_PROBE (nbytes); return val; } @@ -1093,6 +1105,8 @@ lisp_align_malloc (size_t nbytes, enum mem_type type) MALLOC_UNBLOCK_INPUT; + MALLOC_PROBE (nbytes); + eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN); return val; } @@ -5043,6 +5057,23 @@ bounded_number (EMACS_INT number) 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 @@ See Info node `(elisp)Garbage Collection'. */) 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 @@ See Info node `(elisp)Garbage Collection'. */) 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 @@ See Info node `(elisp)Garbage Collection'. */) 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 @@ See Info node `(elisp)Garbage Collection'. */) 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 @@ See Info node `(elisp)Garbage Collection'. */) 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 @@ do hash-consing of the objects allocated to pure space. */); 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"); diff --git a/src/emacs.c b/src/emacs.c index 5aae812b869..05affeefde7 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1419,6 +1419,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_ntterm (); #endif /* WINDOWSNT */ + syms_of_profiler (); + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); diff --git a/src/eval.c b/src/eval.c index 25a41486279..d984331ec41 100644 --- a/src/eval.c +++ b/src/eval.c @@ -31,17 +31,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #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 @@ eval_sub (Lisp_Object form) 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 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } 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 (); diff --git a/src/lisp.h b/src/lisp.h index 35efa67e707..21ac55c1063 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2031,6 +2031,18 @@ extern ptrdiff_t specpdl_size; #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 @@ build_string (const char *str) 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 @@ extern int have_menus_p (void); 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); diff --git a/src/makefile.w32-in b/src/makefile.w32-in index bed6f215711..6f228ed0bb3 100644 --- a/src/makefile.w32-in +++ b/src/makefile.w32-in @@ -125,6 +125,7 @@ OBJ2 = $(BLD)/sysdep.$(O) \ $(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 @@ GLOBAL_SOURCES = dosfns.c msdos.c \ 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 @@ $(BLD)/xml.$(O) : \ $(CONFIG_H) \ $(LISP_H) +$(BLD)/profiler.$(O) : \ + $(SRC)/profiler.c \ + $(CONFIG_H) \ + $(LISP_H) + $(BLD)/image.$(O) : \ $(SRC)/image.c \ $(SRC)/blockinput.h \ diff --git a/src/profiler.c b/src/profiler.c new file mode 100644 index 00000000000..f8fa697d79d --- /dev/null +++ b/src/profiler.c @@ -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); +} diff --git a/src/xdisp.c b/src/xdisp.c index 0f02997be22..fa6460d7be2 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -333,10 +333,10 @@ static Lisp_Object Qinhibit_eval_during_redisplay; 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 Qfontification_functions; 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 @@ redisplay_internal (void) 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 @@ redisplay_internal (void) 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 @@ redisplay_internal (void) #endif /* HAVE_WINDOW_SYSTEM */ end_of_redisplay: + backtrace_list = backtrace.next; unbind_to (count, Qnil); RESUME_POLLING; } @@ -28683,6 +28694,7 @@ syms_of_xdisp (void) 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 @@ init_xdisp (void) 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 |