((nil . ((tab-width . 8)
+ (indent-tabs-mode . t)
(sentence-end-double-space . t)
(fill-column . 70)))
(c-mode . ((c-file-style . "GNU")))
--- /dev/null
+;;; profiler.el --- UI and helper functions for Emacs's native profiler -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012 Free Software Foundation, Inc.
+
+;; Author: Tomohiro Matsuyama <tomo@cx4a.org>
+;; Keywords: lisp
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(defgroup profiler nil
+ "Emacs profiler."
+ :group 'lisp
+ :prefix "profiler-")
+
+\f
+
+;;; 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)))
+
+\f
+
+;;; Slot data structure
+
+(defstruct (profiler-slot (:type list)
+ (:constructor profiler-make-slot))
+ backtrace count elapsed)
+
+\f
+
+;;; 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 "#<closure 0x%x>" (sxhash entry)))
+ ((eq (type-of entry) 'compiled-function)
+ (format "#<compiled 0x%x>" (sxhash entry)))
+ ((subrp entry)
+ (subr-name entry))
+ ((symbolp entry)
+ entry)
+ (t
+ (format "#<unknown 0x%x>" (sxhash entry)))))))
+ (dolist (slot (profiler-log-slots log))
+ (setf (profiler-slot-backtrace slot)
+ (mapcar fixup-entry (profiler-slot-backtrace slot))))))
+
+\f
+
+;;; 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))))
+
+\f
+
+;;; 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)))
+
+\f
+
+;;; 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))
+
+\f
+
+;;; 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))))
+
+\f
+
+;;; 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
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)
if (!val && size)
memory_full (size);
+ MALLOC_PROBE (size);
return val;
}
if (!val && size)
memory_full (size);
memset (val, 0, size);
+ MALLOC_PROBE (size);
return val;
}
if (!val && size)
memory_full (size);
+ MALLOC_PROBE (size);
return val;
}
MALLOC_UNBLOCK_INPUT;
if (!val && nbytes)
memory_full (nbytes);
+ MALLOC_PROBE (nbytes);
return val;
}
MALLOC_UNBLOCK_INPUT;
+ MALLOC_PROBE (nbytes);
+
eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
return val;
}
__malloc_hook = emacs_blocked_malloc;
UNBLOCK_INPUT_ALLOC;
+ MALLOC_PROBE (size);
+
/* fprintf (stderr, "%p malloc\n", value); */
return value;
}
mark_backtrace ();
#endif
+ mark_profiler ();
+
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
#endif
syms_of_ntterm ();
#endif /* WINDOWSNT */
+ syms_of_profiler ();
+
keys_of_casefiddle ();
keys_of_cmds ();
keys_of_buffer ();
#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
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);
}
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 ();
#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)
#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
{
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;
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);
--- /dev/null
+/* 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 <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <stdio.h>
+#include <limits.h>
+#include <sys/time.h>
+#include <signal.h>
+#include <setjmp.h>
+#include "lisp.h"
+
+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;
+
+\f
+
+/* 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;
+}
+
+\f
+
+/* 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);
+}
+
+\f
+
+/* 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));
+}
+
+\f
+
+/* 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;
+}
+
+\f
+
+/* 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;
+}
+
+\f
+
+/* 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);
+}
+
+\f
+
+/* 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;
+}
+
+\f
+
+/* 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;
+}
+
+\f
+
+/* 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);
+}
+
+\f
+
+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);
+}
HCoop / bpt / emacs.git / commitdiff