From 3d80c99f3817bf5eccd6acc6a79498a4fde979a4 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 24 Sep 2012 10:38:10 -0400 Subject: [PATCH] Rewrite sampler to use Elisp hash-tables. * src/profiler.c: Remove filtering functionality. (is_in_trace, Qgc): Remove vars. (make_log, record_backtrace, Fsample_profiler_log): Rewrite, using Elisp hash-tables. (approximate_median, evict_lower_half): New functions. (cpu_log): Rename from sample_log. (cpu_gc_count): New var. (Fsample_profiler_reset, Fmemory_profiler_reset): Remove. (sigprof_handler): Add count to cpu_gc_count during GC, detected via backtrace_list. (block_sigprof, unblock_sigprof): Remove. (gc_probe, mark_profiler): Remove functions. (syms_of_profiler): Staticpro cpu_log and memory_log. * lisp/profiler.el (profiler-sample-interval): Move before first use. Change default to 1ms. (profiler-entry=, profiler-backtrace-reverse, profiler-log-fixup-slot) (profiler-calltree-elapsed<, profiler-calltree-elapsed>): Remove functions. (profiler-entry-format): Don't use type-of. (profiler-slot, profiler-log): Remove structs. (profiler-log-timestamp, profiler-log-type, profiler-log-diff-p): Redefine for new log representation. (profiler-log-diff, profiler-log-fixup, profiler-calltree-build-1): Rewrite for new log representation. (profiler-calltree): Remove `elapsed' fields. (profiler-calltree-count<, profiler-report-make-entry-part): Remove gc special case. (profiler-calltree-find): Use equal. (profiler-calltree-walk): Remove `args'; rely on closures instead. (profiler-calltree-compute-percentages-1): Remove; inlined. (profiler-calltree-compute-percentages): Simplify. (profiler-report-log, profiler-report-reversed) (profiler-report-order): Use defvar-local. (profiler-report-line-format): Remove `elapsed', do a bit of CSE. (profiler-report-mode-map): Remove up/down bindings. (profiler-report-make-buffer-name): Simplify by CSE. (profiler-report-mode): Remove redundant code. (profiler-report-expand-entry, profiler-report-collapse-entry): Use inhibit-read-only. (profiler-report-render-calltree-1): Simplify by CSE. (profiler-reset): Rewrite for new subroutines. (profiler--report-cpu): Rename from sample-profiler-report. (profiler--report-memory): Rename from memory-profiler-report. * src/alloc.c (Fgarbage_collect): Record itself in backtrace_list. Don't set is_in_trace any more. Don't call mark_profiler. Only call gc_probe for the memory profiler. (syms_of_alloc): Define Qautomatic_gc. * src/lisp.h (SXHASH_COMBINE): Move back to... * src/fns.c (SXHASH_COMBINE): ...here. * src/xdisp.c (Qautomatic_redisplay): New constant. (redisplay_internal): Record itself in backtrace_list. (syms_of_xdisp): Define Qautomatic_redisplay. * .dir-locals.el (indent-tabs-mode): Remove personal preference. --- .dir-locals.el | 1 - ChangeLog | 4 + lisp/ChangeLog | 48 +- lisp/profiler.el | 366 ++++++------- src/ChangeLog | 28 + src/alloc.c | 26 +- src/fns.c | 7 + src/lisp.h | 11 +- src/profiler.c | 1504 +++++++++++++++--------------------------------------- src/xdisp.c | 18 +- 10 files changed, 659 insertions(+), 1354 deletions(-) rewrite src/profiler.c (76%) diff --git a/.dir-locals.el b/.dir-locals.el index b92f848d3eb..5bee88267c8 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,5 +1,4 @@ ((nil . ((tab-width . 8) - (indent-tabs-mode . t) (sentence-end-double-space . t) (fill-column . 70))) (c-mode . ((c-file-style . "GNU"))) diff --git a/ChangeLog b/ChangeLog index 4f339482a98..f4426fa36da 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2012-09-24 Stefan Monnier + + * .dir-locals.el (indent-tabs-mode): Remove personal preference. + 2012-08-21 Paul Eggert Merge from gnulib, incorporating: diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d8134f2c046..64fb7e2ffc7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,35 @@ +2012-09-24 Stefan Monnier + + * profiler.el (profiler-sample-interval): Move before first use. + Change default to 1ms. + (profiler-entry=, profiler-backtrace-reverse, profiler-log-fixup-slot) + (profiler-calltree-elapsed<, profiler-calltree-elapsed>): Remove functions. + (profiler-entry-format): Don't use type-of. + (profiler-slot, profiler-log): Remove structs. + (profiler-log-timestamp, profiler-log-type, profiler-log-diff-p): + Redefine for new log representation. + (profiler-log-diff, profiler-log-fixup, profiler-calltree-build-1): + Rewrite for new log representation. + (profiler-calltree): Remove `elapsed' fields. + (profiler-calltree-count<, profiler-report-make-entry-part): + Remove gc special case. + (profiler-calltree-find): Use equal. + (profiler-calltree-walk): Remove `args'; rely on closures instead. + (profiler-calltree-compute-percentages-1): Remove; inlined. + (profiler-calltree-compute-percentages): Simplify. + (profiler-report-log, profiler-report-reversed) + (profiler-report-order): Use defvar-local. + (profiler-report-line-format): Remove `elapsed', do a bit of CSE. + (profiler-report-mode-map): Remove up/down bindings. + (profiler-report-make-buffer-name): Simplify by CSE. + (profiler-report-mode): Remove redundant code. + (profiler-report-expand-entry, profiler-report-collapse-entry): + Use inhibit-read-only. + (profiler-report-render-calltree-1): Simplify by CSE. + (profiler-reset): Rewrite for new subroutines. + (profiler--report-cpu): Rename from sample-profiler-report. + (profiler--report-memory): Rename from memory-profiler-report. + 2012-08-22 Tomohiro Matsuyama * profiler.el: Switch to cl-lib. @@ -35,8 +67,8 @@ * window.el (window-point-1, set-window-point-1): Remove. (window-in-direction, record-window-buffer) (set-window-buffer-start-and-point, split-window-below) - (window--state-get-1, display-buffer-record-window): Replace - calls to window-point-1 and set-window-point-1 by calls to + (window--state-get-1, display-buffer-record-window): + Replace calls to window-point-1 and set-window-point-1 by calls to window-point and set-window-point respectively. 2012-08-21 Glenn Morris @@ -154,8 +186,8 @@ (yank-excluded-properties): Add font-lock-face and category. (yank): Doc fix. - * subr.el (remove-yank-excluded-properties): Obey - yank-handled-properties. The special handling of font-lock-face + * subr.el (remove-yank-excluded-properties): + Obey yank-handled-properties. The special handling of font-lock-face and category is now done this way, instead of being hard-coded. (insert-for-yank-1): Remove font-lock-face handling. (yank-handle-font-lock-face-property) @@ -169,8 +201,8 @@ 2012-08-17 Michael Albinus - * net/tramp-sh.el (tramp-sh-handle-start-file-process): Eliminate - superfluous prompt. (Bug#12203) + * net/tramp-sh.el (tramp-sh-handle-start-file-process): + Eliminate superfluous prompt. (Bug#12203) 2012-08-17 Chong Yidong @@ -197,8 +229,8 @@ (next-buffer, previous-buffer, split-window, balance-windows-2) (set-window-text-height, window-buffer-height) (fit-window-to-buffer, shrink-window-if-larger-than-buffer) - (truncated-partial-width-window-p): Minor code adjustments. In - doc-strings state whether the argument window has to denote a + (truncated-partial-width-window-p): Minor code adjustments. + In doc-strings state whether the argument window has to denote a live, valid or any window. 2012-08-16 Phil Sainty (tiny change) diff --git a/lisp/profiler.el b/lisp/profiler.el index 1777fc00bde..00ee99a6132 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -32,7 +32,11 @@ :group 'lisp :prefix "profiler-") - +(defcustom profiler-sample-interval 1 + "Default sample interval in millisecond." + :type 'integer + :group 'profiler) + ;;; Utilities (defun profiler-ensure-string (object) @@ -90,55 +94,34 @@ ;;; Entries -(defun profiler-entry= (entry1 entry2) - "Return t if ENTRY1 and ENTRY2 are same." - (or (eq entry1 entry2) - (and (stringp entry1) - (stringp entry2) - (string= entry1 entry2)))) - (defun profiler-entry-format (entry) "Format ENTRY in human readable string. ENTRY would be a function name of a function itself." - (cond ((and (consp entry) - (or (eq (car entry) 'lambda) - (eq (car entry) 'closure))) - (format "#" (sxhash entry))) - ((eq (type-of entry) 'compiled-function) + (cond ((memq (car-safe entry) '(closure lambda)) + (format "#" (sxhash entry))) + ((byte-code-function-p entry) (format "#" (sxhash entry))) - ((subrp entry) - (subr-name entry)) - ((symbolp entry) - (symbol-name entry)) - ((stringp entry) - entry) + ((or (subrp entry) (symbolp entry) (stringp entry)) + (format "%s" entry)) (t (format "#" (sxhash entry))))) - -;;; Backtrace data structure - -(defun profiler-backtrace-reverse (backtrace) - (cl-case (car backtrace) - ((t gc) - ;; Make sure Others node and GC node always be at top. - (cons (car backtrace) - (reverse (cdr backtrace)))) - (t (reverse backtrace)))) - - -;;; Slot data structure - -(cl-defstruct (profiler-slot (:type list) - (:constructor profiler-make-slot)) - backtrace count elapsed) - - ;;; Log data structure -(cl-defstruct (profiler-log (:type list) - (:constructor profiler-make-log)) - type diff-p timestamp slots) +;; 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 @@ -146,16 +129,17 @@ be same type." (unless (eq (profiler-log-type log1) (profiler-log-type log2)) (error "Can't compare different type of logs")) - (let ((slots (profiler-log-slots log2))) - (dolist (slot (profiler-log-slots log1)) - (push (profiler-make-slot :backtrace (profiler-slot-backtrace slot) - :count (- (profiler-slot-count slot)) - :elapsed (- (profiler-slot-elapsed slot))) - slots)) - (profiler-make-log :type (profiler-log-type log1) - :diff-p t - :timestamp (current-time) - :slots slots))) + (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) @@ -165,21 +149,16 @@ be same type." (defun profiler-log-fixup-backtrace (backtrace) (mapcar 'profiler-log-fixup-entry backtrace)) -(defun profiler-log-fixup-slot (slot) - (let ((backtrace (profiler-slot-backtrace slot))) - (profiler-make-slot :backtrace (profiler-log-fixup-backtrace backtrace) - :count (profiler-slot-count slot) - :elapsed (profiler-slot-elapsed slot)))) - (defun profiler-log-fixup (log) "Fixup LOG so that the log could be serialized into file." - (cl-loop for slot in (profiler-log-slots log) - collect (profiler-log-fixup-slot slot) into slots - finally return - (profiler-make-log :type (profiler-log-type log) - :diff-p (profiler-log-diff-p log) - :timestamp (profiler-log-timestamp log) - :slots slots))) + (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." @@ -201,7 +180,6 @@ be same type." (cl-defstruct (profiler-calltree (:constructor profiler-make-calltree)) entry (count 0) (count-percent "") - (elapsed 0) (elapsed-percent "") parent children) (defun profiler-calltree-leaf-p (tree) @@ -210,25 +188,12 @@ be same type." (defun profiler-calltree-count< (a b) (cond ((eq (profiler-calltree-entry a) t) t) ((eq (profiler-calltree-entry b) t) nil) - ((eq (profiler-calltree-entry a) 'gc) t) - ((eq (profiler-calltree-entry b) 'gc) 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-elapsed< (a b) - (cond ((eq (profiler-calltree-entry a) t) t) - ((eq (profiler-calltree-entry b) t) nil) - ((eq (profiler-calltree-entry a) 'gc) t) - ((eq (profiler-calltree-entry b) 'gc) nil) - (t (< (profiler-calltree-elapsed a) - (profiler-calltree-elapsed b))))) - -(defun profiler-calltree-elapsed> (a b) - (not (profiler-calltree-elapsed< a b))) - (defun profiler-calltree-depth (tree) (let ((parent (profiler-calltree-parent tree))) (if (null parent) @@ -239,58 +204,47 @@ be same type." "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 (profiler-entry= (profiler-calltree-entry child) entry) + (when (equal (profiler-calltree-entry child) entry) (setq result child)) (setq children (cdr children)))) result)) -(defun profiler-calltree-walk (calltree function &rest args) - (apply function calltree args) +(defun profiler-calltree-walk (calltree function) + (funcall function calltree) (dolist (child (profiler-calltree-children calltree)) - (apply 'profiler-calltree-walk child function args))) + (profiler-calltree-walk child function))) (defun profiler-calltree-build-1 (tree log &optional reverse) - (dolist (slot (profiler-log-slots log)) - (let ((backtrace (profiler-slot-backtrace slot)) - (count (profiler-slot-count slot)) - (elapsed (profiler-slot-elapsed slot)) - (node tree)) - (dolist (entry (if reverse - backtrace - (profiler-backtrace-reverse backtrace))) - (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) - (cl-incf (profiler-calltree-elapsed child) elapsed) - (setq node child)))))) - -(defun profiler-calltree-compute-percentages-1 (node total-count total-elapsed) - (unless (zerop total-count) - (setf (profiler-calltree-count-percent node) - (profiler-format-percent (profiler-calltree-count node) - total-count))) - (unless (zerop total-elapsed) - (setf (profiler-calltree-elapsed-percent node) - (profiler-format-percent (profiler-calltree-elapsed node) - total-elapsed)))) + (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) - (total-elapsed 0)) + (let ((total-count 0)) (dolist (child (profiler-calltree-children tree)) - (if (eq (profiler-calltree-entry child) 'gc) - (profiler-calltree-compute-percentages child) - (cl-incf total-count (profiler-calltree-count child)) - (cl-incf total-elapsed (profiler-calltree-elapsed child)))) - (dolist (child (profiler-calltree-children tree)) - (unless (eq (profiler-calltree-entry child) 'gc) - (profiler-calltree-walk - child 'profiler-calltree-compute-percentages-1 - total-count total-elapsed))))) + (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))) @@ -332,14 +286,14 @@ be same type." (19 right ((14 right profiler-format-nbytes) (5 right))))) -(defvar profiler-report-log nil +(defvar-local profiler-report-log nil "The current profiler log.") -(defvar profiler-report-reversed nil +(defvar-local profiler-report-reversed nil "True if calltree is rendered in bottom-up. Do not touch this variable directly.") -(defvar profiler-report-order nil +(defvar-local profiler-report-order nil "The value can be `ascending' or `descending'. Do not touch this variable directly.") @@ -347,8 +301,6 @@ this variable directly.") (let ((string (cond ((eq entry t) "Others") - ((eq entry 'gc) - "Garbage Collection") ((and (symbolp entry) (fboundp entry)) (propertize (symbol-name entry) @@ -357,7 +309,7 @@ this variable directly.") 'help-echo "mouse-2 or RET jumps to definition")) (t (profiler-entry-format entry))))) - (propertize string 'entry entry))) + (propertize string 'profiler-entry entry))) (defun profiler-report-make-name-part (tree) (let* ((entry (profiler-calltree-entry tree)) @@ -377,31 +329,18 @@ this variable directly.") (defun profiler-report-line-format (tree) (let ((diff-p (profiler-log-diff-p profiler-report-log)) (name-part (profiler-report-make-name-part tree)) - (elapsed (profiler-calltree-elapsed tree)) - (elapsed-percent (profiler-calltree-elapsed-percent tree)) (count (profiler-calltree-count tree)) (count-percent (profiler-calltree-count-percent tree))) - (cl-ecase (profiler-log-type profiler-report-log) - (sample - (if diff-p - (profiler-format profiler-report-sample-line-format - name-part - (list (if (> elapsed 0) - (format "+%s" elapsed) - elapsed) - "")) - (profiler-format profiler-report-sample-line-format - name-part (list elapsed elapsed-percent)))) - (memory - (if diff-p - (profiler-format profiler-report-memory-line-format - name-part - (list (if (> count 0) - (format "+%s" count) - count) - "")) - (profiler-format profiler-report-memory-line-format - name-part (list count count-percent))))))) + (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))) @@ -416,10 +355,13 @@ this variable directly.") (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) - (define-key map [down] 'profiler-report-next-entry) - (define-key map [up] '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) @@ -437,10 +379,9 @@ this variable directly.") map)) (defun profiler-report-make-buffer-name (log) - (let ((time (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log)))) - (cl-ecase (profiler-log-type log) - (sample (format "*CPU-Profiler-Report %s*" time)) - (memory (format "*Memory-Profiler-Report %s*" time))))) + (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." @@ -455,10 +396,6 @@ this variable directly.") (define-derived-mode profiler-report-mode special-mode "Profiler-Report" "Profiler Report Mode." - (make-local-variable 'profiler-report-log) - (make-local-variable 'profiler-report-reversed) - (make-local-variable 'profiler-report-order) - (use-local-map profiler-report-mode-map) (setq buffer-read-only t buffer-undo-list t truncate-lines t)) @@ -470,7 +407,8 @@ this variable directly.") (get-text-property (point) 'calltree)) (defun profiler-report-move-to-entry () - (let ((point (next-single-property-change (line-beginning-position) 'entry))) + (let ((point (next-single-property-change (line-beginning-position) + 'profiler-entry))) (if point (goto-char point) (back-to-indentation)))) @@ -496,7 +434,7 @@ this variable directly.") (line-end-position) t) (let ((tree (profiler-report-calltree-at-point))) (when tree - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (replace-match (concat profiler-report-open-mark " ")) (forward-line) (profiler-report-insert-calltree-children tree) @@ -514,7 +452,7 @@ this variable directly.") (start (line-beginning-position 2)) d) (when tree - (let ((buffer-read-only nil)) + (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))) @@ -549,29 +487,25 @@ otherwise collapse." (require 'help-fns) (describe-function entry))))) -(cl-defun profiler-report-render-calltree-1 (log &key reverse (order 'descending)) +(cl-defun profiler-report-render-calltree-1 + (log &key reverse (order 'descending)) (let ((calltree (profiler-calltree-build profiler-report-log :reverse reverse))) - (cl-ecase (profiler-log-type log) - (sample - (setq header-line-format + (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)" "%"))) - (let ((predicate (cl-ecase order - (ascending 'profiler-calltree-elapsed<) - (descending 'profiler-calltree-elapsed>)))) - (profiler-calltree-sort calltree predicate))) - (memory - (setq header-line-format + (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 ((buffer-read-only nil)) + "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)) @@ -632,19 +566,15 @@ otherwise collapse." ;;; Profiler commands -(defcustom profiler-sample-interval 10 - "Default sample interval in millisecond." - :type 'integer - :group 'profiler) - ;;;###autoload (defun profiler-start (mode) - "Start/restart profilers. MODE can be one of `cpu', `mem', -and `cpu+mem'. If MODE is `cpu' or `cpu+mem', sample profiler -will be started. Also, if MODE is `mem' or `cpu+mem', then -memory profiler will be started." + "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 (intern (completing-read "Mode: " '("cpu" "mem" "cpu+mem") + (list (intern (completing-read "Mode (default cpu): " + '("cpu" "mem" "cpu+mem") nil t nil nil "cpu")))) (cl-ecase mode (cpu @@ -679,25 +609,29 @@ memory profiler will be started." (defun profiler-reset () "Reset profiler log." (interactive) - (sample-profiler-reset) - (memory-profiler-reset) + (ignore (sample-profiler-log)) + (ignore (memory-profiler-log)) t) -(defun sample-profiler-report () - (let ((sample-log (sample-profiler-log))) - (when sample-log - (profiler-report-log sample-log)))) +(defun profiler--report-cpu () + (let ((log (sample-profiler-log))) + (when log + (puthash 'type 'cpu log) + (puthash 'timestamp (current-time) log) + (profiler-report-log log)))) -(defun memory-profiler-report () - (let ((memory-log (memory-profiler-log))) - (when memory-log - (profiler-report-log memory-log)))) +(defun profiler--report-memory () + (let ((log (memory-profiler-log))) + (when log + (puthash 'type 'memory log) + (puthash 'timestamp (current-time) log) + (profiler-report-log log)))) (defun profiler-report () "Report profiling results." (interactive) - (sample-profiler-report) - (memory-profiler-report)) + (profiler--report-cpu) + (profiler--report-memory)) ;;;###autoload (defun profiler-find-log (filename) @@ -709,25 +643,23 @@ memory profiler will be started." ;;; Profiling helpers -(cl-defmacro with-sample-profiling ((&key (interval profiler-sample-interval)) &rest body) - `(progn - (sample-profiler-start ,interval) - (sample-profiler-reset) - (unwind-protect - (progn ,@body) - (sample-profiler-stop) - (sample-profiler-report) - (sample-profiler-reset)))) - -(cl-defmacro with-memory-profiling (() &rest body) - `(progn - (memory-profiler-start) - (memory-profiler-reset) - (unwind-protect - (progn ,@body) - (memory-profiler-stop) - (memory-profiler-report) - (memory-profiler-reset)))) +(cl-defmacro with-sample-profiling ((&key interval) &rest body) + `(unwind-protect + (progn + (ignore (sample-profiler-log)) + (sample-profiler-start ,interval) + ,@body) + (sample-profiler-stop) + (profiler--report-cpu))) + +(defmacro with-memory-profiling (&rest body) + `(unwind-protect + (progn + (ignore (memory-profiler-log)) + (memory-profiler-start) + ,@body) + (memory-profiler-stop) + (profiler--report-memory))) (provide 'profiler) ;;; profiler.el ends here diff --git a/src/ChangeLog b/src/ChangeLog index feb9c6219fb..1b90ae8b976 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,31 @@ +2012-09-24 Stefan Monnier + + * xdisp.c (Qautomatic_redisplay): New constant. + (redisplay_internal): Record itself in backtrace_list. + (syms_of_xdisp): Define Qautomatic_redisplay. + + * profiler.c: Remove filtering functionality. + (is_in_trace, Qgc): Remove vars. + (make_log, record_backtrace, Fsample_profiler_log): + Rewrite, using Elisp hash-tables. + (approximate_median, evict_lower_half): New functions. + (cpu_log): Rename from sample_log. + (cpu_gc_count): New var. + (Fsample_profiler_reset, Fmemory_profiler_reset): Remove. + (sigprof_handler): Add count to cpu_gc_count during GC, detected via + backtrace_list. + (block_sigprof, unblock_sigprof): Remove. + (gc_probe, mark_profiler): Remove functions. + (syms_of_profiler): Staticpro cpu_log and memory_log. + + * lisp.h (SXHASH_COMBINE): Move back to... + * fns.c (SXHASH_COMBINE): ...here. + + * alloc.c (Fgarbage_collect): Record itself in backtrace_list. + Don't set is_in_trace any more. Don't call mark_profiler. + Only call gc_probe for the memory profiler. + (syms_of_alloc): Define Qautomatic_gc. + 2012-09-15 Tomohiro Matsuyama * alloc.c (emacs_blocked_malloc): Remove redundant MALLOC_PROBE. diff --git a/src/alloc.c b/src/alloc.c index 36adb49f835..2fc93f825d1 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -264,6 +264,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. */ @@ -5421,6 +5422,7 @@ See Info node `(elisp)Garbage Collection'. */) EMACS_TIME start; Lisp_Object retval = Qnil; size_t tot_before = 0; + struct backtrace backtrace; if (abort_on_gc) abort (); @@ -5430,6 +5432,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. @@ -5486,7 +5496,6 @@ See Info node `(elisp)Garbage Collection'. */) shrink_regexp_cache (); gc_in_progress = 1; - is_in_trace = 1; /* Mark all the special slots that serve as the roots of accessibility. */ @@ -5538,8 +5547,6 @@ See Info node `(elisp)Garbage Collection'. */) mark_backtrace (); #endif - mark_profiler (); - #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif @@ -5607,7 +5614,6 @@ See Info node `(elisp)Garbage Collection'. */) check_cons_list (); gc_in_progress = 0; - is_in_trace = 0; consing_since_gc = 0; if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10) @@ -5720,24 +5726,19 @@ See Info node `(elisp)Garbage Collection'. */) gcs_done++; /* Collect profiling data. */ - if (sample_profiler_running || memory_profiler_running) + if (memory_profiler_running) { size_t swept = 0; - size_t elapsed = 0; if (memory_profiler_running) { size_t tot_after = total_bytes_of_live_objects (); if (tot_before > tot_after) swept = tot_before - tot_after; } - if (sample_profiler_running) - { - EMACS_TIME since_start = sub_emacs_time (current_emacs_time (), start); - elapsed = EMACS_TIME_TO_DOUBLE (since_start) * 1000; - } - gc_probe (swept, elapsed); + malloc_probe (swept); } + backtrace_list = backtrace.next; return retval; } @@ -6867,6 +6868,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/fns.c b/src/fns.c index 3cb66534e0c..3225fefc5e3 100644 --- a/src/fns.c +++ b/src/fns.c @@ -4096,6 +4096,13 @@ sweep_weak_hash_tables (void) #define SXHASH_MAX_LEN 7 +/* Combine two integers X and Y for hashing. The result might not fit + into a Lisp integer. */ + +#define SXHASH_COMBINE(X, Y) \ + ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \ + + (EMACS_UINT) (Y)) + /* Hash X, returning a value that fits into a Lisp integer. */ #define SXHASH_REDUCE(X) \ ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK) diff --git a/src/lisp.h b/src/lisp.h index 894b18c838c..09a812829a3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2679,11 +2679,6 @@ extern void init_syntax_once (void); extern void syms_of_syntax (void); /* Defined in fns.c */ -/* Combine two integers X and Y for hashing. The result might not fit - into a Lisp integer. */ -#define SXHASH_COMBINE(X, Y) \ - ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \ - + (EMACS_UINT) (Y)) extern Lisp_Object QCrehash_size, QCrehash_threshold; enum { NEXT_ALMOST_PRIME_LIMIT = 11 }; EXFUN (Fidentity, 1) ATTRIBUTE_CONST; @@ -2921,6 +2916,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); @@ -3532,19 +3528,14 @@ void syms_of_dbusbind (void); /* Defined in profiler.c */ extern bool sample_profiler_running; extern bool memory_profiler_running; -extern bool is_in_trace; -extern Lisp_Object Qgc; extern void malloc_probe (size_t); extern void gc_probe (size_t, size_t); -#define ENTER_TRACE (is_in_trace = 1) -#define LEAVE_TRACE (is_in_trace = 0) #define MALLOC_PROBE(size) \ do { \ if (memory_profiler_running) \ malloc_probe (size); \ } while (0) -extern void mark_profiler (void); extern void syms_of_profiler (void); #ifdef DOS_NT diff --git a/src/profiler.c b/src/profiler.c dissimilarity index 76% index 0ef20a9a70c..5eaaaf3330f 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -1,1103 +1,401 @@ -/* 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 . */ - -#include -#include -#include -#include -#include -#include -#include "lisp.h" - -/* True if sampling profiler is running. */ - -bool sample_profiler_running; - -/* True if memory profiler is running. */ - -bool memory_profiler_running; - -/* True during tracing. */ - -bool is_in_trace; - -/* Tag for GC entry. */ - -Lisp_Object Qgc; - -static void sigprof_handler (int, siginfo_t *, void *); -static void block_sigprof (void); -static void unblock_sigprof (void); - - -/* Pattern matching. */ - -enum pattern_type -{ - pattern_exact, /* foo */ - pattern_body_exact, /* *foo* */ - pattern_pre_any, /* *foo */ - pattern_post_any, /* foo* */ - pattern_body_any /* foo*bar */ -}; - -struct pattern -{ - enum pattern_type type; - char *exact; - char *extra; - int exact_length; - int extra_length; -}; - -static struct pattern * -parse_pattern (const char *pattern) -{ - int length = strlen (pattern); - enum pattern_type type; - char *exact; - char *extra = 0; - struct pattern *pat = - (struct pattern *) xmalloc (sizeof (struct pattern)); - - if (length > 1 - && *pattern == '*' - && pattern[length - 1] == '*') - { - type = pattern_body_exact; - exact = xstrdup (pattern + 1); - exact[length - 2] = 0; - } - else if (*pattern == '*') - { - type = pattern_pre_any; - exact = xstrdup (pattern + 1); - } - else if (pattern[length - 1] == '*') - { - type = pattern_post_any; - exact = xstrdup (pattern); - exact[length - 1] = 0; - } - else if (strchr (pattern, '*')) - { - type = pattern_body_any; - exact = xstrdup (pattern); - extra = strchr (exact, '*'); - *extra++ = 0; - } - else - { - type = pattern_exact; - exact = xstrdup (pattern); - } - - pat->type = type; - pat->exact = exact; - pat->extra = extra; - pat->exact_length = strlen (exact); - pat->extra_length = extra ? strlen (extra) : 0; - - return pat; -} - -static void -free_pattern (struct pattern *pattern) -{ - xfree (pattern->exact); - xfree (pattern); -} - -static int -pattern_match_1 (enum pattern_type type, - const char *exact, - int exact_length, - const char *string, - int length) -{ - if (exact_length > length) - return 0; - switch (type) - { - case pattern_exact: - return exact_length == length && !strncmp (exact, string, length); - case pattern_body_exact: - return strstr (string, exact) != 0; - case pattern_pre_any: - return !strncmp (exact, string + (length - exact_length), exact_length); - case pattern_post_any: - return !strncmp (exact, string, exact_length); - case pattern_body_any: - return 0; - } -} - -static int -pattern_match (struct pattern *pattern, const char *string) -{ - int length = strlen (string); - switch (pattern->type) - { - case pattern_body_any: - if (pattern->exact_length + pattern->extra_length > length) - return 0; - return pattern_match_1 (pattern_post_any, - pattern->exact, - pattern->exact_length, - string, length) - && pattern_match_1 (pattern_pre_any, - pattern->extra, - pattern->extra_length, - string, length); - default: - return pattern_match_1 (pattern->type, - pattern->exact, - pattern->exact_length, - string, length); - } -} - -#if 0 -static int -match (const char *pattern, const char *string) -{ - int res; - struct pattern *pat = parse_pattern (pattern); - res = pattern_match (pat, string); - free_pattern (pat); - return res; -} - -static void -should_match (const char *pattern, const char *string) -{ - putchar (match (pattern, string) ? '.' : 'F'); -} - -static void -should_not_match (const char *pattern, const char *string) -{ - putchar (match (pattern, string) ? 'F' : '.'); -} - -static void -pattern_match_tests (void) -{ - should_match ("", ""); - should_not_match ("", "a"); - should_match ("a", "a"); - should_not_match ("a", "ab"); - should_not_match ("ab", "a"); - should_match ("*a*", "a"); - should_match ("*a*", "ab"); - should_match ("*a*", "ba"); - should_match ("*a*", "bac"); - should_not_match ("*a*", ""); - should_not_match ("*a*", "b"); - should_match ("*", ""); - should_match ("*", "a"); - should_match ("a*", "a"); - should_match ("a*", "ab"); - should_not_match ("a*", ""); - should_not_match ("a*", "ba"); - should_match ("*a", "a"); - should_match ("*a", "ba"); - should_not_match ("*a", ""); - should_not_match ("*a", "ab"); - should_match ("a*b", "ab"); - should_match ("a*b", "acb"); - should_match ("a*b", "aab"); - should_match ("a*b", "abb"); - should_not_match ("a*b", ""); - should_not_match ("a*b", ""); - should_not_match ("a*b", "abc"); - puts (""); -} -#endif - - -/* Filters. */ - -static struct pattern *filter_pattern; - -/* Set the current filter pattern. If PATTERN is null, unset the - current filter pattern instead. */ - -static void -set_filter_pattern (const char *pattern) -{ - if (sample_profiler_running) - block_sigprof (); - - if (filter_pattern) - { - free_pattern (filter_pattern); - filter_pattern = 0; - } - if (pattern) - filter_pattern = parse_pattern (pattern); - - if (sample_profiler_running) - unblock_sigprof (); -} - -/* Return true if the current filter pattern is matched with FUNCTION. - FUNCTION should be a symbol or a subroutine, otherwise return - false. */ - -static int -apply_filter_1 (Lisp_Object function) -{ - const char *name; - - if (!filter_pattern) - return 1; - - if (SYMBOLP (function)) - name = SDATA (SYMBOL_NAME (function)); - else if (SUBRP (function)) - name = XSUBR (function)->symbol_name; - else - return 0; - - return pattern_match (filter_pattern, name); -} - -/* Return true if the current filter pattern is matched with at least - one entry in BACKLIST. */ - -static int -apply_filter (struct backtrace *backlist) -{ - while (backlist) - { - if (apply_filter_1 (*backlist->function)) - return 1; - backlist = backlist->next; - } - return 0; -} - -DEFUN ("profiler-set-filter-pattern", - Fprofiler_set_filter_pattern, Sprofiler_set_filter_pattern, - 1, 1, "sPattern: ", - doc: /* Set the current filter pattern. PATTERN can contain -one or two wildcards (*) as follows: - -- foo -- *foo -- foo* -- *foo* -- foo*bar - -If PATTERN is nil or an empty string, then unset the current filter -pattern. */) - (Lisp_Object pattern) -{ - if (NILP (pattern) - || (STRINGP (pattern) && !SREF (pattern, 0))) - { - set_filter_pattern (0); - message ("Profiler filter pattern unset"); - return Qt; - } - else if (!STRINGP (pattern)) - error ("Invalid type of profiler filter pattern"); - - set_filter_pattern (SDATA (pattern)); - - return Qt; -} - - -/* Backtraces. */ - - -static Lisp_Object -make_backtrace (int size) -{ - return Fmake_vector (make_number (size), Qnil); -} - -static EMACS_UINT -backtrace_hash (Lisp_Object backtrace) -{ - int i; - EMACS_UINT hash = 0; - for (i = 0; i < ASIZE (backtrace); i++) - /* FIXME */ - hash = SXHASH_COMBINE (XUINT (AREF (backtrace, i)), hash); - return hash; -} - -static int -backtrace_equal (Lisp_Object a, Lisp_Object b) -{ - int i, j; - - for (i = 0, j = 0;; i++, j++) - { - Lisp_Object x = i < ASIZE (a) ? AREF (a, i) : Qnil; - Lisp_Object y = j < ASIZE (b) ? AREF (b, j) : Qnil; - if (NILP (x) && NILP (y)) - break; - else if (!EQ (x, y)) - return 0; - } - - return 1; -} - -static Lisp_Object -backtrace_object_1 (Lisp_Object backtrace, int i) -{ - if (i >= ASIZE (backtrace) || NILP (AREF (backtrace, i))) - return Qnil; - else - return Fcons (AREF (backtrace, i), backtrace_object_1 (backtrace, i + 1)); -} - -/* Convert BACKTRACE to a list. */ - -static Lisp_Object -backtrace_object (Lisp_Object backtrace) -{ - backtrace_object_1 (backtrace, 0); -} - - -/* Slots. */ - -/* Slot data structure. */ - -struct slot -{ - /* Point to next free slot or next hash table link. */ - struct slot *next; - /* Point to previous hash table link. */ - struct slot *prev; - /* Backtrace object with fixed size. */ - Lisp_Object backtrace; - /* How many times a profiler sees the slot, or how much resouce - allocated during profiling. */ - size_t count; - /* How long the slot takes to execute. */ - size_t elapsed; - /* True in used. */ - unsigned char used : 1; -}; - -static void -mark_slot (struct slot *slot) -{ - mark_object (slot->backtrace); -} - -/* Convert SLOT to a list. */ - -static Lisp_Object -slot_object (struct slot *slot) -{ - return list3 (backtrace_object (slot->backtrace), - make_number (slot->count), - make_number (slot->elapsed)); -} - - - -/* Slot heaps. */ - -struct slot_heap -{ - /* Number of slots allocated to the heap. */ - unsigned int size; - /* Actual data area. */ - struct slot *data; - /* Free list. */ - struct slot *free_list; -}; - -static void -clear_slot_heap (struct slot_heap *heap) -{ - int i; - struct slot *data; - struct slot *free_list; - - data = heap->data; - - /* Mark all slots unsused. */ - for (i = 0; i < heap->size; i++) - data[i].used = 0; - - /* Rebuild a free list. */ - free_list = heap->free_list = heap->data; - for (i = 1; i < heap->size; i++) - { - free_list->next = &data[i]; - free_list = free_list->next; - } - free_list->next = 0; -} - -/* Make a slot heap with SIZE. MAX_STACK_DEPTH is a fixed size of - allocated slots. */ - -static struct slot_heap * -make_slot_heap (unsigned int size, int max_stack_depth) -{ - int i; - struct slot_heap *heap; - struct slot *data; - - data = (struct slot *) xmalloc (sizeof (struct slot) * size); - for (i = 0; i < size; i++) - data[i].backtrace = make_backtrace (max_stack_depth); - - heap = (struct slot_heap *) xmalloc (sizeof (struct slot_heap)); - heap->size = size; - heap->data = data; - clear_slot_heap (heap); - - return heap; -} - -static void -free_slot_heap (struct slot_heap *heap) -{ - int i; - struct slot *data = heap->data; - for (i = 0; i < heap->size; i++) - data[i].backtrace = Qnil; - xfree (data); - xfree (heap); -} - -static void -mark_slot_heap (struct slot_heap *heap) -{ - int i; - for (i = 0; i < heap->size; i++) - mark_slot (&heap->data[i]); -} - -/* Allocate one slot from HEAP. Return 0 if no free slot in HEAP. */ - -static struct slot * -allocate_slot (struct slot_heap *heap) -{ - struct slot *slot; - if (!heap->free_list) - return 0; - slot = heap->free_list; - slot->count = 0; - slot->elapsed = 0; - slot->used = 1; - heap->free_list = heap->free_list->next; - return slot; -} - -static void -free_slot (struct slot_heap *heap, struct slot *slot) -{ - eassert (slot->used); - slot->used = 0; - slot->next = heap->free_list; - heap->free_list = slot; -} - -/* Return a minimal slot from HEAP. "Minimal" means that such a slot - is meaningless for profiling. */ - -static struct slot * -min_slot (struct slot_heap *heap) -{ - int i; - struct slot *min = 0; - for (i = 0; i < heap->size; i++) - { - struct slot *slot = &heap->data[i]; - if (!min || (slot->used && slot->count < min->count)) - min = slot; - } - return min; -} - - -/* Slot hash tables. */ - -struct slot_table -{ - /* Number of slot buckets. */ - unsigned int size; - /* Buckets data area. */ - struct slot **data; -}; - -static void -clear_slot_table (struct slot_table *table) -{ - int i; - for (i = 0; i < table->size; i++) - table->data[i] = 0; -} - -static struct slot_table * -make_slot_table (int size) -{ - struct slot_table *table - = (struct slot_table *) xmalloc (sizeof (struct slot_table)); - table->size = size; - table->data = (struct slot **) xmalloc (sizeof (struct slot *) * size); - clear_slot_table (table); - return table; -} - -static void -free_slot_table (struct slot_table *table) -{ - xfree (table->data); - xfree (table); -} - -static void -remove_slot (struct slot_table *table, struct slot *slot) -{ - if (slot->prev) - slot->prev->next = slot->next; - else - { - EMACS_UINT hash = backtrace_hash (slot->backtrace); - table->data[hash % table->size] = slot->next; - } - if (slot->next) - slot->next->prev = slot->prev; -} - - -/* Logs. */ - -struct log -{ - /* Type of log in symbol. `sample' or `memory'. */ - Lisp_Object type; - /* Backtrace for working. */ - Lisp_Object backtrace; - struct slot_heap *slot_heap; - struct slot_table *slot_table; - size_t others_count; - size_t others_elapsed; -}; - -static struct log * -make_log (const char *type, int heap_size, int max_stack_depth) -{ - struct log *log = - (struct log *) xmalloc (sizeof (struct log)); - log->type = intern (type); - log->backtrace = make_backtrace (max_stack_depth); - log->slot_heap = make_slot_heap (heap_size, max_stack_depth); - /* Number of buckets of hash table will be 10% of HEAP_SIZE. */ - log->slot_table = make_slot_table (max (256, heap_size) / 10); - log->others_count = 0; - log->others_elapsed = 0; - return log; -} - -static void -free_log (struct log *log) -{ - log->backtrace = Qnil; - free_slot_heap (log->slot_heap); - free_slot_table (log->slot_table); -} - -static void -mark_log (struct log *log) -{ - mark_object (log->type); - mark_object (log->backtrace); - mark_slot_heap (log->slot_heap); -} - -static void -clear_log (struct log *log) -{ - clear_slot_heap (log->slot_heap); - clear_slot_table (log->slot_table); - log->others_count = 0; - log->others_elapsed = 0; -} - -/* Evint SLOT from LOG and accumulate the slot counts into others - counts. */ - -static void -evict_slot (struct log *log, struct slot *slot) -{ - log->others_count += slot->count; - log->others_elapsed += slot->elapsed; - remove_slot (log->slot_table, slot); - free_slot (log->slot_heap, slot); -} - -/* Evict a minimal slot from LOG. */ - -static void -evict_min_slot (struct log *log) -{ - struct slot *min = min_slot (log->slot_heap); - if (min) - evict_slot (log, min); -} - -/* Allocate a new slot for BACKTRACE from LOG. The returen value must - be a valid pointer to the slot. */ - -static struct slot * -new_slot (struct log *log, Lisp_Object backtrace) -{ - int i; - struct slot *slot = allocate_slot (log->slot_heap); - - /* If failed to allocate a slot, free some slots to make a room in - heap. */ - if (!slot) - { - evict_min_slot (log); - slot = allocate_slot (log->slot_heap); - /* Must be allocated. */ - eassert (slot); - } - - slot->prev = 0; - slot->next = 0; - - /* Assign BACKTRACE to the slot. */ - for (i = 0; i < ASIZE (backtrace); i++) - ASET (slot->backtrace, i, AREF (backtrace, i)); - - return slot; -} - -/* Make sure that a slot for BACKTRACE is in LOG and return the - slot. The return value must be a valid pointer to the slot. */ - -static struct slot * -ensure_slot (struct log *log, Lisp_Object backtrace) -{ - EMACS_UINT hash = backtrace_hash (backtrace); - int index = hash % log->slot_table->size; - struct slot *slot = log->slot_table->data[index]; - struct slot *prev = slot; - - /* Looking up in hash table bucket. */ - while (slot) - { - if (backtrace_equal (backtrace, slot->backtrace)) - goto found; - prev = slot; - slot = slot->next; - } - - /* If not found, allocate a new slot for BACKTRACE from LOG and link - it with bucket chain. */ - slot = new_slot (log, backtrace); - if (prev) - { - slot->prev = prev; - prev->next = slot; - } - else - log->slot_table->data[index] = slot; - - found: - return slot; -} - -/* 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_under (struct log *log, Lisp_Object base, - size_t count, size_t elapsed) -{ - int i = 0; - Lisp_Object backtrace = log->backtrace; - struct backtrace *backlist = backtrace_list; - - /* First of all, apply filter on the bactkrace. */ - if (!apply_filter (backlist)) return; - - /* Record BASE if necessary. */ - if (!NILP (base) && ASIZE (backtrace) > 0) - ASET (backtrace, i++, base); - - /* Copy the backtrace contents into working memory. */ - for (; i < ASIZE (backtrace) && backlist; backlist = backlist->next) - { - Lisp_Object function = *backlist->function; - if (FUNCTIONP (function)) - ASET (backtrace, i++, function); - } - /* Make sure that unused space of working memory is filled with - nil. */ - for (; i < ASIZE (backtrace); i++) - ASET (backtrace, i, Qnil); - - /* If the backtrace is not empty, */ - if (!NILP (AREF (backtrace, 0))) - { - /* then record counts. */ - struct slot *slot = ensure_slot (log, backtrace); - slot->count += count; - slot->elapsed += elapsed; - } -} - -static void -record_backtrace (struct log *log, size_t count, size_t elapsed) -{ - record_backtrace_under (log, Qnil, count, elapsed); -} - -/* Convert LOG to a list. */ - -static Lisp_Object -log_object (struct log *log) -{ - int i; - Lisp_Object slots = Qnil; - - if (log->others_count != 0 || log->others_elapsed != 0) - { - /* Add others slot. */ - Lisp_Object others_slot - = list3 (list1 (Qt), - make_number (log->others_count), - make_number (log->others_elapsed)); - slots = list1 (others_slot); - } - - for (i = 0; i < log->slot_heap->size; i++) - { - struct slot *s = &log->slot_heap->data[i]; - if (s->used) - { - Lisp_Object slot = slot_object (s); - slots = Fcons (slot, slots); - } - } - - return list4 (log->type, Qnil, Fcurrent_time (), slots); -} - - -/* Sample profiler. */ - -static struct log *sample_log; - -/* The current sample interval in millisecond. */ - -static int current_sample_interval; - -DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start, - 1, 1, 0, - doc: /* Start or restart sample profiler. Sample profiler will -take samples each SAMPLE-INTERVAL in millisecond. See also -`profiler-slot-heap-size' and `profiler-max-stack-depth'. */) - (Lisp_Object sample_interval) -{ - struct sigaction sa; - struct itimerval timer; - - if (sample_profiler_running) - error ("Sample profiler is already running"); - - if (!sample_log) - sample_log = make_log ("sample", - profiler_slot_heap_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); - - sample_profiler_running = 1; - - return Qt; -} - -DEFUN ("sample-profiler-stop", Fsample_profiler_stop, Ssample_profiler_stop, - 0, 0, 0, - doc: /* Stop sample profiler. Profiler log will be kept. */) - (void) -{ - if (!sample_profiler_running) - error ("Sample profiler is not running"); - sample_profiler_running = 0; - - setitimer (ITIMER_PROF, 0, 0); - - return Qt; -} - -DEFUN ("sample-profiler-reset", Fsample_profiler_reset, Ssample_profiler_reset, - 0, 0, 0, - doc: /* Clear sample profiler log. */) - (void) -{ - if (sample_log) - { - if (sample_profiler_running) - { - block_sigprof (); - clear_log (sample_log); - unblock_sigprof (); - } - else - { - free_log (sample_log); - sample_log = 0; - } - } -} - -DEFUN ("sample-profiler-running-p", - Fsample_profiler_running_p, Ssample_profiler_running_p, - 0, 0, 0, - doc: /* Return t if sample profiler is running. */) - (void) -{ - return sample_profiler_running ? Qt : Qnil; -} - -DEFUN ("sample-profiler-log", - Fsample_profiler_log, Ssample_profiler_log, - 0, 0, 0, - doc: /* Return sample profiler log. The data is a list of -(sample nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the -log is collected and SLOTS is a list of slots. */) - (void) -{ - int i; - Lisp_Object result = Qnil; - - if (sample_log) - { - if (sample_profiler_running) - { - block_sigprof (); - result = log_object (sample_log); - unblock_sigprof (); - } - else - result = log_object (sample_log); - } - - return result; -} - - -/* Memory profiler. */ - -static struct log *memory_log; - -DEFUN ("memory-profiler-start", Fmemory_profiler_start, Smemory_profiler_start, - 0, 0, 0, - doc: /* Start/restart memory profiler. See also -`profiler-slot-heap-size' and `profiler-max-stack-depth'. */) - (void) -{ - if (memory_profiler_running) - error ("Memory profiler is already running"); - - if (!memory_log) - memory_log = make_log ("memory", - profiler_slot_heap_size, - profiler_max_stack_depth); - - memory_profiler_running = 1; - - return Qt; -} - -DEFUN ("memory-profiler-stop", - Fmemory_profiler_stop, Smemory_profiler_stop, - 0, 0, 0, - doc: /* Stop memory profiler. Profiler log will be kept. */) - (void) -{ - if (!memory_profiler_running) - error ("Memory profiler is not running"); - memory_profiler_running = 0; - - return Qt; -} - -DEFUN ("memory-profiler-reset", - Fmemory_profiler_reset, Smemory_profiler_reset, - 0, 0, 0, - doc: /* Clear memory profiler log. */) - (void) -{ - if (memory_log) - { - if (memory_profiler_running) - clear_log (memory_log); - else - { - free_log (memory_log); - memory_log = 0; - } - } -} - -DEFUN ("memory-profiler-running-p", - Fmemory_profiler_running_p, Smemory_profiler_running_p, - 0, 0, 0, - doc: /* Return t if memory profiler is running. */) - (void) -{ - return memory_profiler_running ? Qt : Qnil; -} - -DEFUN ("memory-profiler-log", - Fmemory_profiler_log, Smemory_profiler_log, - 0, 0, 0, - doc: /* Return memory profiler log. The data is a list of -(memory nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the -log is collected and SLOTS is a list of slots. */) - (void) -{ - Lisp_Object result = Qnil; - - if (memory_log) - result = log_object (memory_log); - - return result; -} - - -/* Signals and probes. */ - -/* Signal handler for sample profiler. */ - -static void -sigprof_handler (int signal, siginfo_t *info, void *ctx) -{ - if (!is_in_trace && sample_log) - record_backtrace (sample_log, 1, current_sample_interval); -} - -static void -block_sigprof (void) -{ - sigset_t sigset; - sigemptyset (&sigset); - sigaddset (&sigset, SIGPROF); - sigprocmask (SIG_BLOCK, &sigset, 0); -} - -static void -unblock_sigprof (void) -{ - sigset_t sigset; - sigemptyset (&sigset); - sigaddset (&sigset, SIGPROF); - sigprocmask (SIG_UNBLOCK, &sigset, 0); -} - -/* Record that the current backtrace allocated SIZE bytes. */ - -void -malloc_probe (size_t size) -{ - if (memory_log) - record_backtrace (memory_log, size, 0); -} - -/* Record that GC happened in the current backtrace. */ - -void -gc_probe (size_t size, size_t elapsed) -{ - if (sample_log) - record_backtrace_under (sample_log, Qgc, 1, elapsed); - if (memory_log) - record_backtrace_under (memory_log, Qgc, size, elapsed); -} - - - -void -mark_profiler (void) -{ - if (sample_log) - { - if (sample_profiler_running) - { - block_sigprof (); - mark_log (sample_log); - unblock_sigprof (); - } - else - mark_log (sample_log); - } - if (memory_log) - mark_log (memory_log); -} - -void -syms_of_profiler (void) -{ - DEFSYM (Qgc, "gc"); - - DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth, - doc: /* FIXME */); - profiler_max_stack_depth = 16; - DEFVAR_INT ("profiler-slot-heap-size", profiler_slot_heap_size, - doc: /* FIXME */); - profiler_slot_heap_size = 10000; - - defsubr (&Sprofiler_set_filter_pattern); - - defsubr (&Ssample_profiler_start); - defsubr (&Ssample_profiler_stop); - defsubr (&Ssample_profiler_reset); - defsubr (&Ssample_profiler_running_p); - defsubr (&Ssample_profiler_log); - - defsubr (&Smemory_profiler_start); - defsubr (&Smemory_profiler_stop); - defsubr (&Smemory_profiler_reset); - defsubr (&Smemory_profiler_running_p); - defsubr (&Smemory_profiler_log); -} +/* 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 . */ + +#include +#include +#include +#include +#include +#include +#include "lisp.h" + +/* True if sampling profiler is running. */ + +bool sample_profiler_running; + +/* True if memory profiler is running. */ + +bool memory_profiler_running; + +static void sigprof_handler (int, siginfo_t *, void *); + + +/* 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, i, 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)) + 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) + 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. */ + } + } +} + +/* Sample profiler. */ + +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; + +DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start, + 1, 1, 0, + doc: /* Start or restart sample profiler. Sample profiler will +take samples each SAMPLE-INTERVAL in millisecond. See also +`profiler-slot-heap-size' and `profiler-max-stack-depth'. */) + (Lisp_Object sample_interval) +{ + struct sigaction sa; + struct itimerval timer; + + if (sample_profiler_running) + error ("Sample profiler is already running"); + + if (NILP (cpu_log)) + { + cpu_gc_count = 0; + cpu_log = make_log (profiler_slot_heap_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); + + sample_profiler_running = 1; + + return Qt; +} + +DEFUN ("sample-profiler-stop", Fsample_profiler_stop, Ssample_profiler_stop, + 0, 0, 0, + doc: /* Stop sample profiler. Profiler log will be kept. */) + (void) +{ + if (!sample_profiler_running) + error ("Sample profiler is not running"); + sample_profiler_running = 0; + + setitimer (ITIMER_PROF, 0, 0); + + return Qt; +} + +DEFUN ("sample-profiler-running-p", + Fsample_profiler_running_p, Ssample_profiler_running_p, + 0, 0, 0, + doc: /* Return t if sample profiler is running. */) + (void) +{ + return sample_profiler_running ? Qt : Qnil; +} + +DEFUN ("sample-profiler-log", + Fsample_profiler_log, Ssample_profiler_log, + 0, 0, 0, + doc: /* Return sample profiler log. The data is a list of +(sample nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the +log is collected and SLOTS is a list of slots. */) + (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 = (sample_profiler_running + ? make_log (profiler_slot_heap_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; +} + + +/* Memory profiler. */ + +static Lisp_Object memory_log; + +DEFUN ("memory-profiler-start", Fmemory_profiler_start, Smemory_profiler_start, + 0, 0, 0, + doc: /* Start/restart memory profiler. See also +`profiler-slot-heap-size' and `profiler-max-stack-depth'. */) + (void) +{ + if (memory_profiler_running) + error ("Memory profiler is already running"); + + if (NILP (memory_log)) + memory_log = make_log (profiler_slot_heap_size, + profiler_max_stack_depth); + + memory_profiler_running = 1; + + return Qt; +} + +DEFUN ("memory-profiler-stop", + Fmemory_profiler_stop, Smemory_profiler_stop, + 0, 0, 0, + doc: /* Stop memory profiler. Profiler log will be kept. */) + (void) +{ + if (!memory_profiler_running) + error ("Memory profiler is not running"); + memory_profiler_running = 0; + + return Qt; +} + +DEFUN ("memory-profiler-running-p", + Fmemory_profiler_running_p, Smemory_profiler_running_p, + 0, 0, 0, + doc: /* Return t if memory profiler is running. */) + (void) +{ + return memory_profiler_running ? Qt : Qnil; +} + +DEFUN ("memory-profiler-log", + Fmemory_profiler_log, Smemory_profiler_log, + 0, 0, 0, + doc: /* Return memory profiler log. The data is a list of +(memory nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the +log is collected and SLOTS is a list of slots. */) + (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 = (memory_profiler_running + ? make_log (profiler_slot_heap_size, profiler_max_stack_depth) + : Qnil); + return result; +} + + +/* Signals and probes. */ + +/* 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); +} + +/* Record that the current backtrace allocated SIZE bytes. */ +/* FIXME: Inline it everywhere! */ +void +malloc_probe (size_t size) +{ + if (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: /* FIXME */); + profiler_max_stack_depth = 16; + DEFVAR_INT ("profiler-slot-heap-size", profiler_slot_heap_size, + doc: /* FIXME */); + profiler_slot_heap_size = 10000; + + cpu_log = memory_log = Qnil; + staticpro (&cpu_log); + staticpro (&memory_log); + + /* FIXME: Rename things to start with "profiler-", to use "cpu" instead of + "sample", and to make them sound like they're internal or something. */ + defsubr (&Ssample_profiler_start); + defsubr (&Ssample_profiler_stop); + defsubr (&Ssample_profiler_running_p); + defsubr (&Ssample_profiler_log); + + defsubr (&Smemory_profiler_start); + defsubr (&Smemory_profiler_stop); + defsubr (&Smemory_profiler_running_p); + defsubr (&Smemory_profiler_log); +} diff --git a/src/xdisp.c b/src/xdisp.c index f5edb4b16f8..ccfa251fd1c 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. */ @@ -12931,12 +12932,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)); @@ -12974,6 +12976,14 @@ redisplay_internal (void) ++redisplaying_p; 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; @@ -13671,6 +13681,7 @@ redisplay_internal (void) #endif /* HAVE_WINDOW_SYSTEM */ end_of_redisplay: + backtrace_list = backtrace.next; unbind_to (count, Qnil); RESUME_POLLING; } @@ -28696,6 +28707,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); -- 2.11.4.GIT