From: Tomohiro Matsuyama Date: Wed, 22 Aug 2012 06:38:59 +0000 (+0900) Subject: Add emacs native profiler. X-Git-Tag: emacs-24.2.90~244^2~77^2~11 X-Git-Url: https://code.delx.au/gnu-emacs/commitdiff_plain/c2d7786e1272a10c62de7bd1c2d8810e510b3ab1?hp=37219830c704441dad626b2e555e27a7f4676d87 Add emacs native profiler. --- diff --git a/.dir-locals.el b/.dir-locals.el index 5bee88267c..b92f848d3e 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,4 +1,5 @@ ((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/lisp/profiler.el b/lisp/profiler.el new file mode 100644 index 0000000000..c82aea1118 --- /dev/null +++ b/lisp/profiler.el @@ -0,0 +1,600 @@ +;;; profiler.el --- UI and helper functions for Emacs's native profiler -*- lexical-binding: t -*- + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Tomohiro Matsuyama +;; 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 . + +;;; Commentary: + +;; + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup profiler nil + "Emacs profiler." + :group 'lisp + :prefix "profiler-") + + + +;;; Utilities + +(defun profiler-ensure-string (object) + (if (stringp object) + object + (format "%s" object))) + +(defun profiler-format (fmt &rest args) + (loop for (width align subfmt) in fmt + for arg in args + for str = (typecase subfmt + (cons (apply 'profiler-format subfmt arg)) + (string (format 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))) + (ecase align + (left (concat str padding)) + (right (concat padding str)))) + into frags + finally return (apply #'concat frags))) + + + +;;; Slot data structure + +(defstruct (profiler-slot (:type list) + (:constructor profiler-make-slot)) + backtrace count elapsed) + + + +;;; Log data structure + +(defstruct (profiler-log (:type list) + (:constructor profiler-make-log)) + type diff-p timestamp slots) + +(defun profiler-log-diff (log1 log2) + ;; FIXME zeros + (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))) + +(defun profiler-log-fixup (log) + "Fixup LOG so that the log could be serialized into file." + (let ((fixup-entry + (lambda (entry) + (cond + ((and (consp entry) + (or (eq (car entry) 'lambda) + (eq (car entry) 'closure))) + (format "#" (sxhash entry))) + ((eq (type-of entry) 'compiled-function) + (format "#" (sxhash entry))) + ((subrp entry) + (subr-name entry)) + ((symbolp entry) + entry) + (t + (format "#" (sxhash entry))))))) + (dolist (slot (profiler-log-slots log)) + (setf (profiler-slot-backtrace slot) + (mapcar fixup-entry (profiler-slot-backtrace slot)))))) + + + +;;; Calltree data structure + +(defstruct (profiler-calltree (:constructor profiler-make-calltree)) + entry + (count 0) count-percent + (elapsed 0) elapsed-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-elapsed< (a b) + (cond ((eq (profiler-calltree-entry a) t) t) + ((eq (profiler-calltree-entry b) t) 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) + 0 + (1+ (profiler-calltree-depth parent))))) + +(defun profiler-calltree-find (tree entry) + (dolist (child (profiler-calltree-children tree)) + (when (equal (profiler-calltree-entry child) entry) + (return child)))) + +(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) + (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 (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))) + (incf (profiler-calltree-count child) count) + (incf (profiler-calltree-elapsed child) elapsed) + (setq node child)))))) + +(defun profiler-calltree-compute-percentages (tree) + (let ((total-count 0) + (total-elapsed 0)) + (dolist (child (profiler-calltree-children tree)) + (incf total-count (profiler-calltree-count child)) + (incf total-elapsed (profiler-calltree-elapsed child))) + (profiler-calltree-walk + tree (lambda (node) + (unless (zerop total-count) + (setf (profiler-calltree-count-percent node) + (format "%s%%" + (/ (* (profiler-calltree-count node) 100) + total-count)))) + (unless (zerop total-elapsed) + (setf (profiler-calltree-elapsed-percent node) + (format "%s%%" + (/ (* (profiler-calltree-elapsed node) 100) + total-elapsed)))))))) + +(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 + '((60 left) + (14 right ((9 right) + (5 right))))) + +(defvar profiler-report-log nil) +(defvar profiler-report-reversed nil) +(defvar profiler-report-order nil) + +(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-ensure-string entry))))) + (propertize string '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)) + (elapsed (profiler-calltree-elapsed tree)) + (elapsed-percent (profiler-calltree-elapsed-percent tree)) + (count (profiler-calltree-count tree)) + (count-percent (profiler-calltree-count-percent tree))) + (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))))))) + +(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))) + (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) + (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) + (let ((time (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log)))) + (ecase (profiler-log-type log) + (sample (format "*CPU-Profiler-Report %s*" time)) + (memory (format "*Memory-Profiler-Report %s*" time))))) + +(defun profiler-report-setup-buffer (log) + (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." + (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)) + + + +;;; 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) 'entry))) + (if point + (goto-char point) + (back-to-indentation)))) + +(defun profiler-report-next-entry () + "Move cursor to next profile entry." + (interactive) + (forward-line) + (profiler-report-move-to-entry)) + +(defun profiler-report-previous-entry () + "Move cursor to previous profile entry." + (interactive) + (forward-line -1) + (profiler-report-move-to-entry)) + +(defun profiler-report-expand-entry () + "Expand profile 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 ((buffer-read-only nil)) + (replace-match (concat profiler-report-open-mark " ")) + (forward-line) + (profiler-report-insert-calltree-children tree) + t)))))) + +(defun profiler-report-collapse-entry () + "Collpase profile 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 ((buffer-read-only nil)) + (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 profile entry at point if the tree is collapsed, +otherwise collapse the entry." + (interactive) + (or (profiler-report-expand-entry) + (profiler-report-collapse-entry))) + +(defun profiler-report-find-entry (&optional event) + "Find profile 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 profile 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))))) + +(defun* profiler-report-render-calltree-1 (log &key reverse (order 'descending)) + (let ((calltree (profiler-calltree-build profiler-report-log + :reverse reverse))) + (ecase (profiler-log-type log) + (sample + (setq header-line-format + (profiler-report-header-line-format + profiler-report-sample-line-format + "Function" (list "Time (ms)" "%"))) + (let ((predicate (ecase order + (ascending 'profiler-calltree-elapsed<) + (descending 'profiler-calltree-elapsed>)))) + (profiler-calltree-sort calltree predicate))) + (memory + (setq header-line-format + (profiler-report-header-line-format + profiler-report-memory-line-format + "Function" (list "Alloc" "%"))) + (let ((predicate (ecase order + (ascending 'profiler-calltree-count<) + (descending 'profiler-calltree-count>)))) + (profiler-calltree-sort calltree predicate)))) + (let ((buffer-read-only nil)) + (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 of the current profile." + (interactive) + (setq profiler-report-reversed nil) + (profiler-report-rerender-calltree)) + +(defun profiler-report-render-reversed-calltree () + "Render reversed calltree view of the current profile." + (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 current profiler log with another profiler log." + (interactive (list (read-buffer "Compare to: "))) + (let ((log1 (with-current-buffer buffer profiler-report-log)) + (log2 profiler-report-log)) + (profiler-report-log (profiler-log-diff log1 log2)))) + +(defun profiler-report-write-log (filename &optional confirm) + "Write current profiler log into FILENAME." + (interactive + (list (read-file-name "Write log: " default-directory) + (not current-prefix-arg))) + (let ((log profiler-report-log)) + (with-temp-buffer + (let (print-level print-length) + (print log (current-buffer))) + (write-file filename confirm)))) + + + +;;; Profiler commands + +(defcustom profiler-sample-interval 10 + "Default sample interval in millisecond." + :type 'integer + :group 'profiler) + +;;;###autoload +(defun profiler-start (mode) + (interactive + (list (intern (completing-read "Mode: " '("cpu" "memory" "cpu&memory") + nil t nil nil "cpu")))) + (ecase mode + (cpu + (sample-profiler-start profiler-sample-interval) + (message "CPU profiler started")) + (memory + (memory-profiler-start) + (message "Memory profiler started")) + (cpu&memory + (sample-profiler-start profiler-sample-interval) + (memory-profiler-start) + (message "CPU and memory profiler started")))) + +(defun profiler-stop () + (interactive) + (cond + ((and (sample-profiler-running-p) + (memory-profiler-running-p)) + (sample-profiler-stop) + (memory-profiler-stop) + (message "CPU and memory profiler stopped")) + ((sample-profiler-running-p) + (sample-profiler-stop) + (message "CPU profiler stopped")) + ((memory-profiler-running-p) + (memory-profiler-stop) + (message "Memory profiler stopped")) + (t + (error "No profilers started")))) + +(defun profiler-reset () + (interactive) + (sample-profiler-reset) + (memory-profiler-reset) + t) + +(defun profiler-report () + (interactive) + (let ((sample-log (sample-profiler-log))) + (when sample-log + (profiler-log-fixup sample-log) + (profiler-report-log sample-log))) + (let ((memory-log (memory-profiler-log))) + (when memory-log + (profiler-log-fixup memory-log) + (profiler-report-log memory-log)))) + +;;;###autoload +(defun profiler-find-log (filename) + (interactive + (list (read-file-name "Find log: " default-directory))) + (with-temp-buffer + (insert-file-contents filename) + (goto-char (point-min)) + (let ((log (read (current-buffer)))) + (profiler-report-log log)))) + +(provide 'profiler) +;;; profiler.el ends here diff --git a/src/Makefile.in b/src/Makefile.in index 1d89af3140..02b702bc05 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -338,6 +338,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) obj = $(base_obj) $(NS_OBJC_OBJ) diff --git a/src/alloc.c b/src/alloc.c index f0da9416ec..3a4a8de90f 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -727,6 +727,7 @@ xmalloc (size_t size) if (!val && size) memory_full (size); + MALLOC_PROBE (size); return val; } @@ -744,6 +745,7 @@ xzalloc (size_t size) if (!val && size) memory_full (size); memset (val, 0, size); + MALLOC_PROBE (size); return val; } @@ -765,6 +767,7 @@ xrealloc (void *block, size_t size) if (!val && size) memory_full (size); + MALLOC_PROBE (size); return val; } @@ -955,6 +958,7 @@ lisp_malloc (size_t nbytes, enum mem_type type) MALLOC_UNBLOCK_INPUT; if (!val && nbytes) memory_full (nbytes); + MALLOC_PROBE (nbytes); return val; } @@ -1160,6 +1164,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; } @@ -1340,6 +1346,8 @@ emacs_blocked_malloc (size_t size, const void *ptr) __malloc_hook = emacs_blocked_malloc; UNBLOCK_INPUT_ALLOC; + MALLOC_PROBE (size); + /* fprintf (stderr, "%p malloc\n", value); */ return value; } @@ -5510,6 +5518,8 @@ See Info node `(elisp)Garbage Collection'. */) mark_backtrace (); #endif + mark_profiler (); + #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif diff --git a/src/emacs.c b/src/emacs.c index 9e7efcabbf..19d5f55c9c 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1557,6 +1557,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 c41e3f54d4..b2e49364b5 100644 --- a/src/eval.c +++ b/src/eval.c @@ -32,17 +32,7 @@ along with GNU Emacs. If not, see . */ #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 @@ -2081,11 +2071,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); @@ -2778,11 +2768,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/fns.c b/src/fns.c index 3225fefc5e..3cb66534e0 100644 --- a/src/fns.c +++ b/src/fns.c @@ -4096,13 +4096,6 @@ 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 d9a7c9d0bd..b4cead003c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2015,6 +2015,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. */ struct handler { @@ -2667,6 +2679,11 @@ 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; @@ -3512,6 +3529,18 @@ extern int have_menus_p (void); void syms_of_dbusbind (void); #endif +/* Defined in profiler.c */ +extern int sample_profiler_running; +extern int memory_profiler_running; +extern void malloc_probe (size_t); +#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 /* Defined in msdos.c, w32.c */ extern char *emacs_root_dir (void); diff --git a/src/profiler.c b/src/profiler.c new file mode 100644 index 0000000000..56458c64b8 --- /dev/null +++ b/src/profiler.c @@ -0,0 +1,965 @@ +/* GNU Emacs 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" + +static void sigprof_handler (int, siginfo_t *, void *); +static void block_sigprof (void); +static void unblock_sigprof (void); + +int sample_profiler_running; +int memory_profiler_running; + + + +/* Filters */ + +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); + } +} + +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; +} + +#if 0 +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 + +static struct pattern *filter_pattern; + +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) return; + filter_pattern = parse_pattern (pattern); + + if (sample_profiler_running) + unblock_sigprof (); +} + +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); +} + +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: /* FIXME */) + (Lisp_Object pattern) +{ + if (NILP (pattern)) + { + set_filter_pattern (0); + 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)); +} + +static Lisp_Object +backtrace_object (Lisp_Object backtrace) +{ + backtrace_object_1 (backtrace, 0); +} + + + +/* Slots */ + +struct slot +{ + struct slot *next, *prev; + Lisp_Object backtrace; + unsigned int count; + unsigned int elapsed; + unsigned char used : 1; +}; + +static void +mark_slot (struct slot *slot) +{ + mark_object (slot->backtrace); +} + +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 +{ + unsigned int size; + struct slot *data; + 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; + + for (i = 0; i < heap->size; i++) + data[i].used = 0; + + 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; +} + +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]); +} + +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; +} + +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 tables */ + +struct slot_table +{ + unsigned int size; + 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 +{ + Lisp_Object type; + Lisp_Object backtrace; + struct slot_heap *slot_heap; + struct slot_table *slot_table; + unsigned int others_count; + unsigned int 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); + 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; +} + +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); +} + +static void +evict_min_slot (struct log *log) +{ + struct slot *min = min_slot (log->slot_heap); + if (min) + evict_slot (log, min); +} + +static struct slot * +new_slot (struct log *log, Lisp_Object backtrace) +{ + int i; + struct slot *slot = allocate_slot (log->slot_heap); + + if (!slot) + { + evict_min_slot (log); + slot = allocate_slot (log->slot_heap); + eassert (slot); + } + + slot->prev = 0; + slot->next = 0; + for (i = 0; i < ASIZE (backtrace); i++) + ASET (slot->backtrace, i, AREF (backtrace, i)); + + return 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; + + while (slot) + { + if (backtrace_equal (backtrace, slot->backtrace)) + goto found; + prev = slot; + slot = slot->next; + } + + slot = new_slot (log, backtrace); + if (prev) + { + slot->prev = prev; + prev->next = slot; + } + else + log->slot_table->data[index] = slot; + + found: + return slot; +} + +static void +record_backtrace (struct log *log, unsigned int count, unsigned int elapsed) +{ + int i; + Lisp_Object backtrace = log->backtrace; + struct backtrace *backlist = backtrace_list; + + if (!apply_filter (backlist)) return; + + for (i = 0; i < ASIZE (backtrace) && backlist; backlist = backlist->next) + { + Lisp_Object function = *backlist->function; + if (FUNCTIONP (function)) + { + ASET (backtrace, i, function); + i++; + } + } + for (; i < ASIZE (backtrace); i++) + ASET (backtrace, i, Qnil); + + if (!NILP (AREF (backtrace, 0))) + { + struct slot *slot = ensure_slot (log, backtrace); + slot->count += count; + slot->elapsed += elapsed; + } +} + +static Lisp_Object +log_object (struct log *log) +{ + int i; + Lisp_Object slots = Qnil; + + if (log->others_count != 0 || log->others_elapsed != 0) + slots = list1 (list3 (list1 (Qt), + make_number (log->others_count), + make_number (log->others_elapsed))); + + 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; +static int current_sample_interval; + +DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start, + 1, 1, 0, + doc: /* FIXME */) + (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: /* FIXME */) + (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: /* FIXME */) + (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: /* FIXME */) + (void) +{ + return sample_profiler_running ? Qt : Qnil; +} + +DEFUN ("sample-profiler-log", + Fsample_profiler_log, Ssample_profiler_log, + 0, 0, 0, + doc: /* FIXME */) + (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: /* FIXME */) + (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: /* FIXME */) + (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: /* FIXME */) + (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: /* FIXME */) + (void) +{ + return memory_profiler_running ? Qt : Qnil; +} + +DEFUN ("memory-profiler-log", + Fmemory_profiler_log, Smemory_profiler_log, + 0, 0, 0, + doc: /* FIXME */) + (void) +{ + Lisp_Object result = Qnil; + + if (memory_log) + result = log_object (memory_log); + + return result; +} + + + +/* Signals and probes */ + +static void +sigprof_handler (int signal, siginfo_t *info, void *ctx) +{ + 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); +} + +void +malloc_probe (size_t size) +{ + record_backtrace (memory_log, size, 0); +} + + + +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) +{ + 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); +}