procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge profiler branch

Browse source
This commit is contained in:
Stefan Monnier 2012-09-26 11:19:10 -04:00
commit 3a880af4a7
12 changed files with 1252 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
etc/NEWS
View file

@ -678,6 +678,11 @@ are deprecated and will be removed eventually.
* Lisp changes in Emacs 24.3
** New sampling-based Elisp profiler.
Try M-x profiler-start ... M-x profiler-stop; and then M-x profiler-report.
The sampling rate can be based on CPU time (only supported on some
systems), or based on memory allocations.
** CL-style generalized variables are now in core Elisp.
`setf' is autoloaded; `push' and `pop' accept generalized variables.

5
lisp/ChangeLog
View file

@ -1,3 +1,8 @@
2012-09-26 Tomohiro Matsuyama <tomo@cx4a.org>
Stefan Monnier <monnier@iro.umontreal.ca>
* profiler.el: New file.
2012-09-26 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/testcover.el (testcover-after): Add gv-expander.

665
lisp/profiler.el Normal file
View file

@ -0,0 +1,665 @@
;;; profiler.el --- UI and helper functions for Emacs's native profiler -*- lexical-binding: t -*-
;; Copyright (C) 2012 Free Software Foundation, Inc.
;; Author: Tomohiro Matsuyama <tomo@cx4a.org>
;; Keywords: lisp
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
(eval-when-compile
(require 'cl-lib))
(defgroup profiler nil
"Emacs profiler."
:group 'lisp
:prefix "profiler-")
(defcustom profiler-sample-interval 1
"Default sample interval in millisecond."
:type 'integer
:group 'profiler)
;;; Utilities
(defun profiler-ensure-string (object)
(cond ((stringp object)
object)
((symbolp object)
(symbol-name object))
((numberp object)
(number-to-string object))
(t
(format "%s" object))))
(defun profiler-format (fmt &rest args)
(cl-loop for (width align subfmt) in fmt
for arg in args
for str = (cond
((consp subfmt)
(apply 'profiler-format subfmt arg))
((stringp subfmt)
(format subfmt arg))
((and (symbolp subfmt)
(fboundp subfmt))
(funcall subfmt arg))
(t
(profiler-ensure-string arg)))
for len = (length str)
if (< width len)
collect (substring str 0 width) into frags
else
collect
(let ((padding (make-string (- width len) ?\s)))
(cl-ecase align
(left (concat str padding))
(right (concat padding str))))
into frags
finally return (apply #'concat frags)))
(defun profiler-format-percent (number divisor)
(concat (number-to-string (/ (* number 100) divisor)) "%"))
(defun profiler-format-nbytes (nbytes)
"Format NBYTES in humarn readable string."
(if (and (integerp nbytes) (> nbytes 0))
(cl-loop with i = (% (1+ (floor (log10 nbytes))) 3)
for c in (append (number-to-string nbytes) nil)
if (= i 0)
collect ?, into s
and do (setq i 3)
collect c into s
do (cl-decf i)
finally return
(apply 'string (if (eq (car s) ?,) (cdr s) s)))
(profiler-ensure-string nbytes)))
;;; Entries
(defun profiler-entry-format (entry)
"Format ENTRY in human readable string. ENTRY would be a
function name of a function itself."
(cond ((memq (car-safe entry) '(closure lambda))
(format "#<lambda 0x%x>" (sxhash entry)))
((byte-code-function-p entry)
(format "#<compiled 0x%x>" (sxhash entry)))
((or (subrp entry) (symbolp entry) (stringp entry))
(format "%s" entry))
(t
(format "#<unknown 0x%x>" (sxhash entry)))))
;;; Log data structure
;; The C code returns the log in the form of a hash-table where the keys are
;; vectors (of size profiler-max-stack-depth, holding truncated
;; backtraces, where the first element is the top of the stack) and
;; the values are integers (which count how many times this backtrace
;; has been seen, multiplied by a "weight factor" which is either the
;; sample-interval or the memory being allocated).
;; We extend it by adding a few other entries to the hash-table, most notably:
;; - Key `type' has a value indicating the kind of log (`memory' or `cpu').
;; - Key `timestamp' has a value giving the time when the log was obtained.
;; - Key `diff-p' indicates if this log represents a diff between two logs.
(defun profiler-log-timestamp (log) (gethash 'timestamp log))
(defun profiler-log-type (log) (gethash 'type log))
(defun profiler-log-diff-p (log) (gethash 'diff-p log))
(defun profiler-log-diff (log1 log2)
"Compare LOG1 with LOG2 and return a diff log. Both logs must
be same type."
(unless (eq (profiler-log-type log1)
(profiler-log-type log2))
(error "Can't compare different type of logs"))
(let ((newlog (make-hash-table :test 'equal)))
;; Make a copy of `log1' into `newlog'.
(maphash (lambda (backtrace count) (puthash backtrace count newlog))
log1)
(puthash 'diff-p t newlog)
(maphash (lambda (backtrace count)
(when (vectorp backtrace)
(puthash backtrace (- (gethash backtrace log1 0) count)
newlog)))
log2)
newlog))
(defun profiler-log-fixup-entry (entry)
(if (symbolp entry)
entry
(profiler-entry-format entry)))
(defun profiler-log-fixup-backtrace (backtrace)
(mapcar 'profiler-log-fixup-entry backtrace))
(defun profiler-log-fixup (log)
"Fixup LOG so that the log could be serialized into file."
(let ((newlog (make-hash-table :test 'equal)))
(maphash (lambda (backtrace count)
(puthash (if (not (vectorp backtrace))
backtrace
(profiler-log-fixup-backtrace backtrace))
count newlog))
log)
newlog))
(defun profiler-log-write-file (log filename &optional confirm)
"Write LOG into FILENAME."
(with-temp-buffer
(let (print-level print-length)
(print (profiler-log-fixup log) (current-buffer)))
(write-file filename confirm)))
(defun profiler-log-read-file (filename)
"Read log from FILENAME."
(with-temp-buffer
(insert-file-contents filename)
(goto-char (point-min))
(read (current-buffer))))
;;; Calltree data structure
(cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
entry
(count 0) (count-percent "")
parent children)
(defun profiler-calltree-leaf-p (tree)
(null (profiler-calltree-children tree)))
(defun profiler-calltree-count< (a b)
(cond ((eq (profiler-calltree-entry a) t) t)
((eq (profiler-calltree-entry b) t) nil)
(t (< (profiler-calltree-count a)
(profiler-calltree-count b)))))
(defun profiler-calltree-count> (a b)
(not (profiler-calltree-count< a b)))
(defun profiler-calltree-depth (tree)
(let ((parent (profiler-calltree-parent tree)))
(if (null parent)
0
(1+ (profiler-calltree-depth parent)))))
(defun profiler-calltree-find (tree entry)
"Return a child tree of ENTRY under TREE."
;; OPTIMIZED
(let (result (children (profiler-calltree-children tree)))
;; FIXME: Use `assoc'.
(while (and children (null result))
(let ((child (car children)))
(when (equal (profiler-calltree-entry child) entry)
(setq result child))
(setq children (cdr children))))
result))
(defun profiler-calltree-walk (calltree function)
(funcall function calltree)
(dolist (child (profiler-calltree-children calltree))
(profiler-calltree-walk child function)))
(defun profiler-calltree-build-1 (tree log &optional reverse)
;; FIXME: Do a better job of reconstructing a complete call-tree
;; when the backtraces have been truncated. Ideally, we should be
;; able to reduce profiler-max-stack-depth to 3 or 4 and still
;; get a meaningful call-tree.
(maphash
(lambda (backtrace count)
(when (vectorp backtrace)
(let ((node tree)
(max (length backtrace)))
(dotimes (i max)
(let ((entry (aref backtrace (if reverse i (- max i 1)))))
(when entry
(let ((child (profiler-calltree-find node entry)))
(unless child
(setq child (profiler-make-calltree
:entry entry :parent node))
(push child (profiler-calltree-children node)))
(cl-incf (profiler-calltree-count child) count)
(setq node child))))))))
log))
(defun profiler-calltree-compute-percentages (tree)
(let ((total-count 0))
;; FIXME: the memory profiler's total wraps around all too easily!
(dolist (child (profiler-calltree-children tree))
(cl-incf total-count (profiler-calltree-count child)))
(unless (zerop total-count)
(profiler-calltree-walk
tree (lambda (node)
(setf (profiler-calltree-count-percent node)
(profiler-format-percent (profiler-calltree-count node)
total-count)))))))
(cl-defun profiler-calltree-build (log &key reverse)
(let ((tree (profiler-make-calltree)))
(profiler-calltree-build-1 tree log reverse)
(profiler-calltree-compute-percentages tree)
tree))
(defun profiler-calltree-sort (tree predicate)
(let ((children (profiler-calltree-children tree)))
(setf (profiler-calltree-children tree) (sort children predicate))
(dolist (child (profiler-calltree-children tree))
(profiler-calltree-sort child predicate))))
;;; Report rendering
(defcustom profiler-report-closed-mark "+"
"An indicator of closed calltrees."
:type 'string
:group 'profiler)
(defcustom profiler-report-open-mark "-"
"An indicator of open calltrees."
:type 'string
:group 'profiler)
(defcustom profiler-report-leaf-mark " "
"An indicator of calltree leaves."
:type 'string
:group 'profiler)
(defvar profiler-report-sample-line-format
'((60 left)
(14 right ((9 right)
(5 right)))))
(defvar profiler-report-memory-line-format
'((55 left)
(19 right ((14 right profiler-format-nbytes)
(5 right)))))
(defvar-local profiler-report-log nil
"The current profiler log.")
(defvar-local profiler-report-reversed nil
"True if calltree is rendered in bottom-up. Do not touch this
variable directly.")
(defvar-local profiler-report-order nil
"The value can be `ascending' or `descending'. Do not touch
this variable directly.")
(defun profiler-report-make-entry-part (entry)
(let ((string (cond
((eq entry t)
"Others")
((and (symbolp entry)
(fboundp entry))
(propertize (symbol-name entry)
'face 'link
'mouse-face 'highlight
'help-echo "mouse-2 or RET jumps to definition"))
(t
(profiler-entry-format entry)))))
(propertize string 'profiler-entry entry)))
(defun profiler-report-make-name-part (tree)
(let* ((entry (profiler-calltree-entry tree))
(depth (profiler-calltree-depth tree))
(indent (make-string (* (1- depth) 2) ?\s))
(mark (if (profiler-calltree-leaf-p tree)
profiler-report-leaf-mark
profiler-report-closed-mark))
(entry (profiler-report-make-entry-part entry)))
(format "%s%s %s" indent mark entry)))
(defun profiler-report-header-line-format (fmt &rest args)
(let* ((header (apply 'profiler-format fmt args))
(escaped (replace-regexp-in-string "%" "%%" header)))
(concat " " escaped)))
(defun profiler-report-line-format (tree)
(let ((diff-p (profiler-log-diff-p profiler-report-log))
(name-part (profiler-report-make-name-part tree))
(count (profiler-calltree-count tree))
(count-percent (profiler-calltree-count-percent tree)))
(profiler-format (cl-ecase (profiler-log-type profiler-report-log)
(cpu profiler-report-sample-line-format)
(memory profiler-report-memory-line-format))
name-part
(if diff-p
(list (if (> count 0)
(format "+%s" count)
count)
"")
(list count count-percent)))))
(defun profiler-report-insert-calltree (tree)
(let ((line (profiler-report-line-format tree)))
(insert (propertize (concat line "\n") 'calltree tree))))
(defun profiler-report-insert-calltree-children (tree)
(mapc 'profiler-report-insert-calltree
(profiler-calltree-children tree)))
;;; Report mode
(defvar profiler-report-mode-map
(let ((map (make-sparse-keymap)))
;; FIXME: Add menu.
(define-key map "n" 'profiler-report-next-entry)
(define-key map "p" 'profiler-report-previous-entry)
;; I find it annoying more than helpful to not be able to navigate
;; normally with the cursor keys. --Stef
;; (define-key map [down] 'profiler-report-next-entry)
;; (define-key map [up] 'profiler-report-previous-entry)
(define-key map "\r" 'profiler-report-toggle-entry)
(define-key map "\t" 'profiler-report-toggle-entry)
(define-key map "i" 'profiler-report-toggle-entry)
(define-key map "f" 'profiler-report-find-entry)
(define-key map "j" 'profiler-report-find-entry)
(define-key map [mouse-2] 'profiler-report-find-entry)
(define-key map "d" 'profiler-report-describe-entry)
(define-key map "C" 'profiler-report-render-calltree)
(define-key map "B" 'profiler-report-render-reversed-calltree)
(define-key map "A" 'profiler-report-ascending-sort)
(define-key map "D" 'profiler-report-descending-sort)
(define-key map "=" 'profiler-report-compare-log)
(define-key map (kbd "C-x C-w") 'profiler-report-write-log)
(define-key map "q" 'quit-window)
map))
(defun profiler-report-make-buffer-name (log)
(format "*%s-Profiler-Report %s*"
(cl-ecase (profiler-log-type log) (cpu 'CPU) (memory 'Memory))
(format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log))))
(defun profiler-report-setup-buffer (log)
"Make a buffer for LOG and return it."
(let* ((buf-name (profiler-report-make-buffer-name log))
(buffer (get-buffer-create buf-name)))
(with-current-buffer buffer
(profiler-report-mode)
(setq profiler-report-log log
profiler-report-reversed nil
profiler-report-order 'descending))
buffer))
(define-derived-mode profiler-report-mode special-mode "Profiler-Report"
"Profiler Report Mode."
(setq buffer-read-only t
buffer-undo-list t
truncate-lines t))
;;; Report commands
(defun profiler-report-calltree-at-point ()
(get-text-property (point) 'calltree))
(defun profiler-report-move-to-entry ()
(let ((point (next-single-property-change (line-beginning-position)
'profiler-entry)))
(if point
(goto-char point)
(back-to-indentation))))
(defun profiler-report-next-entry ()
"Move cursor to next entry."
(interactive)
(forward-line)
(profiler-report-move-to-entry))
(defun profiler-report-previous-entry ()
"Move cursor to previous entry."
(interactive)
(forward-line -1)
(profiler-report-move-to-entry))
(defun profiler-report-expand-entry ()
"Expand entry at point."
(interactive)
(save-excursion
(beginning-of-line)
(when (search-forward (concat profiler-report-closed-mark " ")
(line-end-position) t)
(let ((tree (profiler-report-calltree-at-point)))
(when tree
(let ((inhibit-read-only t))
(replace-match (concat profiler-report-open-mark " "))
(forward-line)
(profiler-report-insert-calltree-children tree)
t))))))
(defun profiler-report-collapse-entry ()
"Collpase entry at point."
(interactive)
(save-excursion
(beginning-of-line)
(when (search-forward (concat profiler-report-open-mark " ")
(line-end-position) t)
(let* ((tree (profiler-report-calltree-at-point))
(depth (profiler-calltree-depth tree))
(start (line-beginning-position 2))
d)
(when tree
(let ((inhibit-read-only t))
(replace-match (concat profiler-report-closed-mark " "))
(while (and (eq (forward-line) 0)
(let ((child (get-text-property (point) 'calltree)))
(and child
(numberp (setq d (profiler-calltree-depth child)))))
(> d depth)))
(delete-region start (line-beginning-position)))))
t)))
(defun profiler-report-toggle-entry ()
"Expand entry at point if the tree is collapsed,
otherwise collapse."
(interactive)
(or (profiler-report-expand-entry)
(profiler-report-collapse-entry)))
(defun profiler-report-find-entry (&optional event)
"Find entry at point."
(interactive (list last-nonmenu-event))
(if event (posn-set-point (event-end event)))
(let ((tree (profiler-report-calltree-at-point)))
(when tree
(let ((entry (profiler-calltree-entry tree)))
(find-function entry)))))
(defun profiler-report-describe-entry ()
"Describe entry at point."
(interactive)
(let ((tree (profiler-report-calltree-at-point)))
(when tree
(let ((entry (profiler-calltree-entry tree)))
(require 'help-fns)
(describe-function entry)))))
(cl-defun profiler-report-render-calltree-1
(log &key reverse (order 'descending))
(let ((calltree (profiler-calltree-build profiler-report-log
:reverse reverse)))
(setq header-line-format
(cl-ecase (profiler-log-type log)
(cpu
(profiler-report-header-line-format
profiler-report-sample-line-format
"Function" (list "Time (ms)" "%")))
(memory
(profiler-report-header-line-format
profiler-report-memory-line-format
"Function" (list "Bytes" "%")))))
(let ((predicate (cl-ecase order
(ascending #'profiler-calltree-count<)
(descending #'profiler-calltree-count>))))
(profiler-calltree-sort calltree predicate))
(let ((inhibit-read-only t))
(erase-buffer)
(profiler-report-insert-calltree-children calltree)
(goto-char (point-min))
(profiler-report-move-to-entry))))
(defun profiler-report-rerender-calltree ()
(profiler-report-render-calltree-1 profiler-report-log
:reverse profiler-report-reversed
:order profiler-report-order))
(defun profiler-report-render-calltree ()
"Render calltree view."
(interactive)
(setq profiler-report-reversed nil)
(profiler-report-rerender-calltree))
(defun profiler-report-render-reversed-calltree ()
"Render reversed calltree view."
(interactive)
(setq profiler-report-reversed t)
(profiler-report-rerender-calltree))
(defun profiler-report-ascending-sort ()
"Sort calltree view in ascending order."
(interactive)
(setq profiler-report-order 'ascending)
(profiler-report-rerender-calltree))
(defun profiler-report-descending-sort ()
"Sort calltree view in descending order."
(interactive)
(setq profiler-report-order 'descending)
(profiler-report-rerender-calltree))
(defun profiler-report-log (log)
(let ((buffer (profiler-report-setup-buffer log)))
(with-current-buffer buffer
(profiler-report-render-calltree))
(pop-to-buffer buffer)))
(defun profiler-report-compare-log (buffer)
"Compare the current profiler log with another."
(interactive (list (read-buffer "Compare to: ")))
(let* ((log1 (with-current-buffer buffer profiler-report-log))
(log2 profiler-report-log)
(diff-log (profiler-log-diff log1 log2)))
(profiler-report-log diff-log)))
(defun profiler-report-write-log (filename &optional confirm)
"Write the current profiler log into FILENAME."
(interactive
(list (read-file-name "Write log: " default-directory)
(not current-prefix-arg)))
(profiler-log-write-file profiler-report-log
filename
confirm))
;;; Profiler commands
;;;###autoload
(defun profiler-start (mode)
"Start/restart profilers.
MODE can be one of `cpu', `mem', or `cpu+mem'.
If MODE is `cpu' or `cpu+mem', time-based profiler will be started.
Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started."
(interactive
(list (if (not (fboundp 'profiler-cpu-start)) 'mem
(intern (completing-read "Mode (default cpu): "
'("cpu" "mem" "cpu+mem")
nil t nil nil "cpu")))))
(cl-ecase mode
(cpu
(profiler-cpu-start profiler-sample-interval)
(message "CPU profiler started"))
(mem
(profiler-memory-start)
(message "Memory profiler started"))
(cpu+mem
(profiler-cpu-start profiler-sample-interval)
(profiler-memory-start)
(message "CPU and memory profiler started"))))
(defun profiler-stop ()
"Stop started profilers. Profiler logs will be kept."
(interactive)
(let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop)))
(mem (profiler-memory-stop)))
(message "%s profiler stopped"
(cond ((and mem cpu) "CPU and memory")
(mem "Memory")
(cpu "CPU")
(t "No")))))
(defun profiler-reset ()
"Reset profiler log."
(interactive)
(when (fboundp 'profiler-cpu-log)
(ignore (profiler-cpu-log)))
(ignore (profiler-memory-log))
t)
(defun profiler--report-cpu ()
(let ((log (if (fboundp 'profiler-cpu-log) (profiler-cpu-log))))
(when log
(puthash 'type 'cpu log)
(puthash 'timestamp (current-time) log)
(profiler-report-log log))))
(defun profiler--report-memory ()
(let ((log (profiler-memory-log)))
(when log
(puthash 'type 'memory log)
(puthash 'timestamp (current-time) log)
(profiler-report-log log))))
(defun profiler-report ()
"Report profiling results."
(interactive)
(profiler--report-cpu)
(profiler--report-memory))
;;;###autoload
(defun profiler-find-log (filename)
"Read a profiler log from FILENAME and report it."
(interactive
(list (read-file-name "Find log: " default-directory)))
(profiler-report-log (profiler-log-read-file filename)))
;;; Profiling helpers
;; (cl-defmacro with-sample-profiling ((&key interval) &rest body)
;; `(unwind-protect
;; (progn
;; (ignore (profiler-cpu-log))
;; (profiler-cpu-start ,interval)
;; ,@body)
;; (profiler-cpu-stop)
;; (profiler--report-cpu)))
;; (defmacro with-memory-profiling (&rest body)
;; `(unwind-protect
;; (progn
;; (ignore (profiler-memory-log))
;; (profiler-memory-start)
;; ,@body)
;; (profiler-memory-stop)
;; (profiler--report-memory)))
(provide 'profiler)
;;; profiler.el ends here

64
src/ChangeLog
View file

@ -1,3 +1,29 @@
2012-09-26 Tomohiro Matsuyama <tomo@cx4a.org>
Stefan Monnier <monnier@iro.umontreal.ca>
Juanma Barranquero <lekktu@gmail.com>
* profiler.c: New file.
* Makefile.in (base_obj): Add profiler.o.
* makefile.w32-in (OBJ2, GLOBAL_SOURCES): Add profiler.c.
($(BLD)/profiler.$(O)): New target.
* emacs.c (main): Call syms_of_profiler.
* alloc.c (Qautomatic_gc): New constant.
(MALLOC_PROBE): New macro.
(xmalloc, xzalloc, xrealloc, lisp_malloc, lisp_align_malloc): Use it.
(total_bytes_of_live_objects): New function.
(Fgarbage_collect): Use it. Record itself in backtrace_list.
Call malloc_probe for the memory profiler.
(syms_of_alloc): Define Qautomatic_gc.
* eval.c (eval_sub, Ffuncall): Reorder assignments to avoid
race condition.
(struct backtrace): Move definition...
* lisp.h (struct backtrace): ..here.
(Qautomatic_gc, profiler_memory_running): Declare vars.
(malloc_probe, syms_of_profiler): Declare functions.
* xdisp.c (Qautomatic_redisplay): New constant.
(redisplay_internal): Record itself in backtrace_list.
(syms_of_xdisp): Define Qautomatic_redisplay.
2012-09-25 Juanma Barranquero <lekktu@gmail.com>
* makefile.w32-in ($(BLD)/callproc.$(O)): Update dependencies.
@ -291,8 +317,8 @@
(reinvoke_input_signal): Remove. All uses replaced by
handle_async_input.
(quit_count): Now volatile, since a signal handler uses it.
(handle_interrupt): Now takes bool IN_SIGNAL_HANDLER as arg. All
callers changed. Block SIGINT only if not already blocked.
(handle_interrupt): Now takes bool IN_SIGNAL_HANDLER as arg.
All callers changed. Block SIGINT only if not already blocked.
Clear sigmask reliably, even if Fsignal returns, which it can.
Omit unnecessary accesses to volatile var.
(quit_throw_to_read_char): No need to restore sigmask.
@ -392,8 +418,8 @@
if it is defined. Arguments and return value changed.
(valid_image_p, make_image): Callers changed.
(xbm_type, xpm_type, pbm_type, png_type, jpeg_type, tiff_type)
(gif_type, imagemagick_type, svg_type, gs_type): Add
initialization functions.
(gif_type, imagemagick_type, svg_type, gs_type):
Add initialization functions.
(Finit_image_library): Call lookup_image_type.
(CHECK_LIB_AVAILABLE): Macro deleted.
(lookup_image_type): Call define_image_type here, rather than via
@ -415,8 +441,8 @@
* window.c (Fsplit_window_internal): Handle only Qt value of
Vwindow_combination_limit separately.
(Qtemp_buffer_resize): New symbol.
(Vwindow_combination_limit): New default value. Rewrite
doc-string.
(Vwindow_combination_limit): New default value.
Rewrite doc-string.
2012-09-22 Eli Zaretskii <eliz@gnu.org>
@ -515,7 +541,7 @@
(Fx_create_frame): Call x_set_offset to correctly interpret
top_pos in geometry.
* frame.c (read_integer, XParseGeometry): Moved from w32xfns.c.
* frame.c (read_integer, XParseGeometry): Move from w32xfns.c.
(Fx_parse_geometry): If there is a space in string, call
Qns_parse_geometry, otherwise do as on other terms (Bug#12368).
@ -616,8 +642,8 @@
2012-09-16 Martin Rudalics <rudalics@gmx.at>
* window.c (Fwindow_parameter, Fset_window_parameter): Accept
any window as argument (Bug#12452).
* window.c (Fwindow_parameter, Fset_window_parameter):
Accept any window as argument (Bug#12452).
2012-09-16 Jan Djärv <jan.h.d@swipnet.se>
@ -692,8 +718,8 @@
2012-09-14 Dmitry Antipov <dmantipov@yandex.ru>
Avoid out-of-range marker position (Bug#12426).
* insdel.c (replace_range, replace_range_2): Adjust
markers before overlays, as suggested by comments.
* insdel.c (replace_range, replace_range_2):
Adjust markers before overlays, as suggested by comments.
(insert_1_both, insert_from_buffer_1, adjust_after_replace):
Remove redundant check before calling offset_intervals.
@ -992,8 +1018,8 @@
in the internal border.
(x_set_window_size): Remove static variables and their usage.
(ns_redraw_scroll_bars): Fix NSTRACE arg.
(ns_after_update_window_line, ns_draw_fringe_bitmap): Remove
fringe/internal border adjustment (Bug#11052).
(ns_after_update_window_line, ns_draw_fringe_bitmap):
Remove fringe/internal border adjustment (Bug#11052).
(ns_draw_fringe_bitmap): Make code more like other terms (xterm.c).
(ns_draw_window_cursor): Remove fringe/internal border adjustment.
(ns_fix_rect_ibw): Remove.
@ -1210,8 +1236,8 @@
(init_signals) [FORWARD_SIGNAL_TO_MAIN_THREAD]: Initialize it;
code moved here from emacs.c's main function.
* sysdep.c, syssignal.h (handle_on_main_thread): New function,
replacing the old SIGNAL_THREAD_CHECK. All uses changed. This
lets callers save and restore errno properly.
replacing the old SIGNAL_THREAD_CHECK. All uses changed.
This lets callers save and restore errno properly.
2012-09-05 Dmitry Antipov <dmantipov@yandex.ru>
@ -1520,8 +1546,8 @@
* process.c: Include TERM_HEADER instead of listing all possible
window-system headers.
* nsterm.h: Remove declarations now in frame.h. Define
FRAME_X_SCREEN, FRAME_X_VISUAL.
* nsterm.h: Remove declarations now in frame.h.
Define FRAME_X_SCREEN, FRAME_X_VISUAL.
* menu.c: Include TERM_HEADER instead of listing all possible
window-system headers.
@ -1717,8 +1743,8 @@
* nsterm.h (NSPanel): New class variable dialog_return.
* nsmenu.m (initWithContentRect:styleMask:backing:defer:): Initialize
dialog_return.
* nsmenu.m (initWithContentRect:styleMask:backing:defer:):
Initialize dialog_return.
(windowShouldClose:): Use stop instead of stopModalWithCode.
(clicked:): Ditto, and also set dialog_return (Bug#12258).
(timeout_handler:): Use stop instead of abortModal. Send a dummy

1
src/Makefile.in
View file

@ -339,6 +339,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
process.o gnutls.o callproc.o \
region-cache.o sound.o atimer.o \
doprnt.o intervals.o textprop.o composite.o xml.o \
profiler.o \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
$(WINDOW_SYSTEM_OBJ)
obj = $(base_obj) $(NS_OBJC_OBJ)

67
src/alloc.c
View file

@ -205,6 +205,7 @@ static Lisp_Object Qintervals;
static Lisp_Object Qbuffers;
static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
static Lisp_Object Qgc_cons_threshold;
Lisp_Object Qautomatic_gc;
Lisp_Object Qchar_table_extra_slots;
/* Hook run after GC has finished. */
@ -648,6 +649,13 @@ malloc_unblock_input (void)
# define MALLOC_UNBLOCK_INPUT ((void) 0)
#endif
#define MALLOC_PROBE(size) \
do { \
if (profiler_memory_running) \
malloc_probe (size); \
} while (0)
/* Like malloc but check for no memory and block interrupt input.. */
void *
@ -661,6 +669,7 @@ xmalloc (size_t size)
if (!val && size)
memory_full (size);
MALLOC_PROBE (size);
return val;
}
@ -678,6 +687,7 @@ xzalloc (size_t size)
if (!val && size)
memory_full (size);
memset (val, 0, size);
MALLOC_PROBE (size);
return val;
}
@ -699,6 +709,7 @@ xrealloc (void *block, size_t size)
if (!val && size)
memory_full (size);
MALLOC_PROBE (size);
return val;
}
@ -888,6 +899,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
MALLOC_UNBLOCK_INPUT;
if (!val && nbytes)
memory_full (nbytes);
MALLOC_PROBE (nbytes);
return val;
}
@ -1093,6 +1105,8 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
MALLOC_UNBLOCK_INPUT;
MALLOC_PROBE (nbytes);
eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
return val;
}
@ -5043,6 +5057,23 @@ bounded_number (EMACS_INT number)
return make_number (min (MOST_POSITIVE_FIXNUM, number));
}
/* Calculate total bytes of live objects. */
static size_t
total_bytes_of_live_objects (void)
{
size_t tot = 0;
tot += total_conses * sizeof (struct Lisp_Cons);
tot += total_symbols * sizeof (struct Lisp_Symbol);
tot += total_markers * sizeof (union Lisp_Misc);
tot += total_string_bytes;
tot += total_vector_slots * word_size;
tot += total_floats * sizeof (struct Lisp_Float);
tot += total_intervals * sizeof (struct interval);
tot += total_strings * sizeof (struct Lisp_String);
return tot;
}
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: /* Reclaim storage for Lisp objects no longer needed.
Garbage collection happens automatically if you cons more than
@ -5068,6 +5099,8 @@ See Info node `(elisp)Garbage Collection'. */)
ptrdiff_t count = SPECPDL_INDEX ();
EMACS_TIME start;
Lisp_Object retval = Qnil;
size_t tot_before = 0;
struct backtrace backtrace;
if (abort_on_gc)
emacs_abort ();
@ -5077,6 +5110,14 @@ See Info node `(elisp)Garbage Collection'. */)
if (pure_bytes_used_before_overflow)
return Qnil;
/* Record this function, so it appears on the profiler's backtraces. */
backtrace.next = backtrace_list;
backtrace.function = &Qautomatic_gc;
backtrace.args = &Qautomatic_gc;
backtrace.nargs = 0;
backtrace.debug_on_exit = 0;
backtrace_list = &backtrace;
check_cons_list ();
/* Don't keep undo information around forever.
@ -5084,6 +5125,9 @@ See Info node `(elisp)Garbage Collection'. */)
FOR_EACH_BUFFER (nextb)
compact_buffer (nextb);
if (profiler_memory_running)
tot_before = total_bytes_of_live_objects ();
start = current_emacs_time ();
/* In case user calls debug_print during GC,
@ -5255,16 +5299,7 @@ See Info node `(elisp)Garbage Collection'. */)
gc_relative_threshold = 0;
if (FLOATP (Vgc_cons_percentage))
{ /* Set gc_cons_combined_threshold. */
double tot = 0;
tot += total_conses * sizeof (struct Lisp_Cons);
tot += total_symbols * sizeof (struct Lisp_Symbol);
tot += total_markers * sizeof (union Lisp_Misc);
tot += total_string_bytes;
tot += total_vector_slots * word_size;
tot += total_floats * sizeof (struct Lisp_Float);
tot += total_intervals * sizeof (struct interval);
tot += total_strings * sizeof (struct Lisp_String);
double tot = total_bytes_of_live_objects ();
tot *= XFLOAT_DATA (Vgc_cons_percentage);
if (0 < tot)
@ -5367,6 +5402,17 @@ See Info node `(elisp)Garbage Collection'. */)
gcs_done++;
/* Collect profiling data. */
if (profiler_memory_running)
{
size_t swept = 0;
size_t tot_after = total_bytes_of_live_objects ();
if (tot_before > tot_after)
swept = tot_before - tot_after;
malloc_probe (swept);
}
backtrace_list = backtrace.next;
return retval;
}
@ -6527,6 +6573,7 @@ do hash-consing of the objects allocated to pure space. */);
DEFSYM (Qstring_bytes, "string-bytes");
DEFSYM (Qvector_slots, "vector-slots");
DEFSYM (Qheap, "heap");
DEFSYM (Qautomatic_gc, "Automatic GC");
DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");

2
src/emacs.c
View file

@ -1419,6 +1419,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_ntterm ();
#endif /* WINDOWSNT */
syms_of_profiler ();
keys_of_casefiddle ();
keys_of_cmds ();
keys_of_buffer ();

16
src/eval.c
View file

@ -31,17 +31,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#include "xterm.h"
#endif
struct backtrace
{
struct backtrace *next;
Lisp_Object *function;
Lisp_Object *args; /* Points to vector of args. */
ptrdiff_t nargs; /* Length of vector. */
/* Nonzero means call value of debugger when done with this operation. */
unsigned int debug_on_exit : 1;
};
static struct backtrace *backtrace_list;
struct backtrace *backtrace_list;
#if !BYTE_MARK_STACK
static
@ -2055,11 +2045,11 @@ eval_sub (Lisp_Object form)
original_args = XCDR (form);
backtrace.next = backtrace_list;
backtrace_list = &backtrace;
backtrace.function = &original_fun; /* This also protects them from gc. */
backtrace.args = &original_args;
backtrace.nargs = UNEVALLED;
backtrace.debug_on_exit = 0;
backtrace_list = &backtrace;
if (debug_on_next_call)
do_debug_on_call (Qt);
@ -2730,11 +2720,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
}
backtrace.next = backtrace_list;
backtrace_list = &backtrace;
backtrace.function = &args[0];
backtrace.args = &args[1]; /* This also GCPROs them. */
backtrace.nargs = nargs - 1;
backtrace.debug_on_exit = 0;
backtrace_list = &backtrace;
/* Call GC after setting up the backtrace, so the latter GCPROs the args. */
maybe_gc ();

20
src/lisp.h
View file

@ -2031,6 +2031,18 @@ extern ptrdiff_t specpdl_size;
#define SPECPDL_INDEX() (specpdl_ptr - specpdl)
struct backtrace
{
struct backtrace *next;
Lisp_Object *function;
Lisp_Object *args; /* Points to vector of args. */
ptrdiff_t nargs; /* Length of vector. */
/* Nonzero means call value of debugger when done with this operation. */
unsigned int debug_on_exit : 1;
};
extern struct backtrace *backtrace_list;
/* Everything needed to describe an active condition case.
Members are volatile if their values need to survive _longjmp when
@ -2916,6 +2928,7 @@ build_string (const char *str)
extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
extern void make_byte_code (struct Lisp_Vector *);
extern Lisp_Object Qautomatic_gc;
extern Lisp_Object Qchar_table_extra_slots;
extern struct Lisp_Vector *allocate_vector (EMACS_INT);
extern struct Lisp_Vector *allocate_pseudovector (int memlen, int lisplen, int tag);
@ -3534,6 +3547,13 @@ extern int have_menus_p (void);
void syms_of_dbusbind (void);
#endif
/* Defined in profiler.c. */
extern bool profiler_memory_running;
extern void malloc_probe (size_t);
extern void syms_of_profiler (void);
#ifdef DOS_NT
/* Defined in msdos.c, w32.c. */
extern char *emacs_root_dir (void);

8
src/makefile.w32-in
View file

@ -125,6 +125,7 @@ OBJ2 = $(BLD)/sysdep.$(O) \
$(BLD)/terminal.$(O) \
$(BLD)/menu.$(O) \
$(BLD)/xml.$(O) \
$(BLD)/profiler.$(O) \
$(BLD)/w32term.$(O) \
$(BLD)/w32xfns.$(O) \
$(BLD)/w32fns.$(O) \
@ -222,7 +223,7 @@ GLOBAL_SOURCES = dosfns.c msdos.c \
process.c callproc.c unexw32.c \
region-cache.c sound.c atimer.c \
doprnt.c intervals.c textprop.c composite.c \
gnutls.c xml.c
gnutls.c xml.c profiler.c
SOME_MACHINE_OBJECTS = dosfns.o msdos.o \
xterm.o xfns.o xmenu.o xselect.o xrdb.o xsmfns.o dbusbind.o
obj = $(GLOBAL_SOURCES:.c=.o)
@ -973,6 +974,11 @@ $(BLD)/xml.$(O) : \
$(CONFIG_H) \
$(LISP_H)
$(BLD)/profiler.$(O) : \
$(SRC)/profiler.c \
$(CONFIG_H) \
$(LISP_H)
$(BLD)/image.$(O) : \
$(SRC)/image.c \
$(SRC)/blockinput.h \

426
src/profiler.c Normal file
View file

@ -0,0 +1,426 @@
/* Profiler implementation.
Copyright (C) 2012 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
#include <stdio.h>
#include <limits.h>
#include <sys/time.h>
#include <signal.h>
#include <setjmp.h>
#include "lisp.h"
/* Logs. */
typedef struct Lisp_Hash_Table log_t;
static Lisp_Object
make_log (int heap_size, int max_stack_depth)
{
/* We use a standard Elisp hash-table object, but we use it in
a special way. This is OK as long as the object is not exposed
to Elisp, i.e. until it is returned by *-profiler-log, after which
it can't be used any more. */
Lisp_Object log = make_hash_table (Qequal, make_number (heap_size),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
Qnil, Qnil, Qnil);
struct Lisp_Hash_Table *h = XHASH_TABLE (log);
/* What is special about our hash-tables is that the keys are pre-filled
with the vectors we'll put in them. */
int i = ASIZE (h->key_and_value) / 2;
while (0 < i)
set_hash_key_slot (h, --i,
Fmake_vector (make_number (max_stack_depth), Qnil));
return log;
}
/* Evict the least used half of the hash_table.
When the table is full, we have to evict someone.
The easiest and most efficient is to evict the value we're about to add
(i.e. once the table is full, stop sampling).
We could also pick the element with the lowest count and evict it,
but finding it is O(N) and for that amount of work we get very
little in return: for the next sample, this latest sample will have
count==1 and will hence be a prime candidate for eviction :-(
So instead, we take O(N) time to eliminate more or less half of the
entries (the half with the lowest counts). So we get an amortized
cost of O(1) and we get O(N) time for a new entry to grow larger
than the other least counts before a new round of eviction. */
static EMACS_INT approximate_median (log_t *log,
ptrdiff_t start, ptrdiff_t size)
{
eassert (size > 0);
if (size < 2)
return XINT (HASH_VALUE (log, start));
if (size < 3)
/* Not an actual median, but better for our application than
choosing either of the two numbers. */
return ((XINT (HASH_VALUE (log, start))
+ XINT (HASH_VALUE (log, start + 1)))
/ 2);
else
{
ptrdiff_t newsize = size / 3;
ptrdiff_t start2 = start + newsize;
EMACS_INT i1 = approximate_median (log, start, newsize);
EMACS_INT i2 = approximate_median (log, start2, newsize);
EMACS_INT i3 = approximate_median (log, start2 + newsize,
size - 2 * newsize);
return (i1 < i2
? (i2 < i3 ? i2 : (i1 < i3 ? i3 : i1))
: (i1 < i3 ? i1 : (i2 < i3 ? i3 : i2)));
}
}
static void evict_lower_half (log_t *log)
{
ptrdiff_t size = ASIZE (log->key_and_value) / 2;
EMACS_INT median = approximate_median (log, 0, size);
ptrdiff_t i;
for (i = 0; i < size; i++)
/* Evict not only values smaller but also values equal to the median,
so as to make sure we evict something no matter what. */
if (XINT (HASH_VALUE (log, i)) <= median)
{
Lisp_Object key = HASH_KEY (log, i);
{ /* FIXME: we could make this more efficient. */
Lisp_Object tmp;
XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */
Fremhash (key, tmp);
}
eassert (EQ (log->next_free, make_number (i)));
{
int j;
eassert (VECTORP (key));
for (j = 0; j < ASIZE (key); j++)
ASET (key, j, Qnil);
}
set_hash_key_slot (log, i, key);
}
}
/* Record the current backtrace in LOG. BASE is a special name for
describing which the backtrace come from. BASE can be nil. COUNT is
a number how many times the profiler sees the backtrace at the
time. ELAPSED is a elapsed time in millisecond that the backtrace
took. */
static void
record_backtrace (log_t *log, size_t count)
{
struct backtrace *backlist = backtrace_list;
Lisp_Object backtrace;
ptrdiff_t index, i = 0;
ptrdiff_t asize;
if (!INTEGERP (log->next_free))
/* FIXME: transfer the evicted counts to a special entry rather
than dropping them on the floor. */
evict_lower_half (log);
index = XINT (log->next_free);
/* Get a "working memory" vector. */
backtrace = HASH_KEY (log, index);
asize = ASIZE (backtrace);
/* Copy the backtrace contents into working memory. */
for (; i < asize && backlist; i++, backlist = backlist->next)
/* FIXME: For closures we should ignore the environment. */
ASET (backtrace, i, *backlist->function);
/* Make sure that unused space of working memory is filled with nil. */
for (; i < asize; i++)
ASET (backtrace, i, Qnil);
{ /* We basically do a `gethash+puthash' here, except that we have to be
careful to avoid memory allocation since we're in a signal
handler, and we optimize the code to try and avoid computing the
hash+lookup twice. See fns.c:Fputhash for reference. */
EMACS_UINT hash;
ptrdiff_t j = hash_lookup (log, backtrace, &hash);
if (j >= 0)
set_hash_value_slot (log, j,
make_number (count + XINT (HASH_VALUE (log, j))));
else
{ /* BEWARE! hash_put in general can allocate memory.
But currently it only does that if log->next_free is nil. */
int j;
eassert (!NILP (log->next_free));
j = hash_put (log, backtrace, make_number (count), hash);
/* Let's make sure we've put `backtrace' right where it
already was to start with. */
eassert (index == j);
/* FIXME: If the hash-table is almost full, we should set
some global flag so that some Elisp code can offload its
data elsewhere, so as to avoid the eviction code.
There are 2 ways to do that, AFAICT:
- Set a flag checked in QUIT, such that QUIT can then call
Fprofiler_cpu_log and stash the full log for later use.
- Set a flag check in post-gc-hook, so that Elisp code can call
profiler-cpu-log. That gives us more flexibility since that
Elisp code can then do all kinds of fun stuff like write
the log to disk. Or turn it right away into a call tree.
Of course, using Elisp is generally preferable, but it may
take longer until we get a chance to run the Elisp code, so
there's more risk that the table will get full before we
get there. */
}
}
}
/* Sample profiler. */
/* FIXME: Add support for the CPU profiler in W32. */
/* FIXME: the sigprof_handler suffers from race-conditions if the signal
is delivered to a thread other than the main Emacs thread. */
#if defined SIGPROF && defined HAVE_SETITIMER
#define PROFILER_CPU_SUPPORT
/* True if sampling profiler is running. */
static bool profiler_cpu_running;
static Lisp_Object cpu_log;
/* Separate counter for the time spent in the GC. */
static EMACS_INT cpu_gc_count;
/* The current sample interval in millisecond. */
static int current_sample_interval;
/* Signal handler for sample profiler. */
static void
sigprof_handler (int signal, siginfo_t *info, void *ctx)
{
eassert (HASH_TABLE_P (cpu_log));
if (backtrace_list && EQ (*backtrace_list->function, Qautomatic_gc))
/* Special case the time-count inside GC because the hash-table
code is not prepared to be used while the GC is running.
More specifically it uses ASIZE at many places where it does
not expect the ARRAY_MARK_FLAG to be set. We could try and
harden the hash-table code, but it doesn't seem worth the
effort. */
cpu_gc_count += current_sample_interval;
else
record_backtrace (XHASH_TABLE (cpu_log), current_sample_interval);
}
DEFUN ("profiler-cpu-start", Fprofiler_cpu_start, Sprofiler_cpu_start,
1, 1, 0,
doc: /* Start or restart the cpu profiler.
The cpu profiler will take call-stack samples each SAMPLE-INTERVAL (expressed in milliseconds).
See also `profiler-log-size' and `profiler-max-stack-depth'. */)
(Lisp_Object sample_interval)
{
struct sigaction sa;
struct itimerval timer;
if (profiler_cpu_running)
error ("Sample profiler is already running");
if (NILP (cpu_log))
{
cpu_gc_count = 0;
cpu_log = make_log (profiler_log_size,
profiler_max_stack_depth);
}
current_sample_interval = XINT (sample_interval);
sa.sa_sigaction = sigprof_handler;
sa.sa_flags = SA_RESTART | SA_SIGINFO;
sigemptyset (&sa.sa_mask);
sigaction (SIGPROF, &sa, 0);
timer.it_interval.tv_sec = 0;
timer.it_interval.tv_usec = current_sample_interval * 1000;
timer.it_value = timer.it_interval;
setitimer (ITIMER_PROF, &timer, 0);
profiler_cpu_running = true;
return Qt;
}
DEFUN ("profiler-cpu-stop", Fprofiler_cpu_stop, Sprofiler_cpu_stop,
0, 0, 0,
doc: /* Stop the cpu profiler. The profiler log is not affected.
Return non-nil if the profiler was running. */)
(void)
{
if (!profiler_cpu_running)
return Qnil;
profiler_cpu_running = false;
setitimer (ITIMER_PROF, 0, 0);
return Qt;
}
DEFUN ("profiler-cpu-running-p",
Fprofiler_cpu_running_p, Sprofiler_cpu_running_p,
0, 0, 0,
doc: /* Return non-nil iff cpu profiler is running. */)
(void)
{
return profiler_cpu_running ? Qt : Qnil;
}
DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_log,
0, 0, 0,
doc: /* Return the current cpu profiler log.
The log is a hash-table mapping backtraces to counters which represent
the amount of time spent at those points. Every backtrace is a vector
of functions, where the last few elements may be nil.
Before returning, a new log is allocated for future samples. */)
(void)
{
Lisp_Object result = cpu_log;
/* Here we're making the log visible to Elisp , so it's not safe any
more for our use afterwards since we can't rely on its special
pre-allocated keys anymore. So we have to allocate a new one. */
cpu_log = (profiler_cpu_running
? make_log (profiler_log_size, profiler_max_stack_depth)
: Qnil);
Fputhash (Fmake_vector (make_number (1), Qautomatic_gc),
make_number (cpu_gc_count),
result);
cpu_gc_count = 0;
return result;
}
#endif /* not defined PROFILER_CPU_SUPPORT */
/* Memory profiler. */
/* True if memory profiler is running. */
bool profiler_memory_running;
static Lisp_Object memory_log;
DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start,
0, 0, 0,
doc: /* Start/restart the memory profiler.
The memory profiler will take samples of the call-stack whenever a new
allocation takes place. Note that most small allocations only trigger
the profiler occasionally.
See also `profiler-log-size' and `profiler-max-stack-depth'. */)
(void)
{
if (profiler_memory_running)
error ("Memory profiler is already running");
if (NILP (memory_log))
memory_log = make_log (profiler_log_size,
profiler_max_stack_depth);
profiler_memory_running = true;
return Qt;
}
DEFUN ("profiler-memory-stop",
Fprofiler_memory_stop, Sprofiler_memory_stop,
0, 0, 0,
doc: /* Stop the memory profiler. The profiler log is not affected.
Return non-nil if the profiler was running. */)
(void)
{
if (!profiler_memory_running)
return Qnil;
profiler_memory_running = false;
return Qt;
}
DEFUN ("profiler-memory-running-p",
Fprofiler_memory_running_p, Sprofiler_memory_running_p,
0, 0, 0,
doc: /* Return non-nil if memory profiler is running. */)
(void)
{
return profiler_memory_running ? Qt : Qnil;
}
DEFUN ("profiler-memory-log",
Fprofiler_memory_log, Sprofiler_memory_log,
0, 0, 0,
doc: /* Return the current memory profiler log.
The log is a hash-table mapping backtraces to counters which represent
the amount of memory allocated at those points. Every backtrace is a vector
of functions, where the last few elements may be nil.
Before returning, a new log is allocated for future samples. */)
(void)
{
Lisp_Object result = memory_log;
/* Here we're making the log visible to Elisp , so it's not safe any
more for our use afterwards since we can't rely on its special
pre-allocated keys anymore. So we have to allocate a new one. */
memory_log = (profiler_memory_running
? make_log (profiler_log_size, profiler_max_stack_depth)
: Qnil);
return result;
}
/* Signals and probes. */
/* Record that the current backtrace allocated SIZE bytes. */
void
malloc_probe (size_t size)
{
eassert (HASH_TABLE_P (memory_log));
record_backtrace (XHASH_TABLE (memory_log), size);
}
void
syms_of_profiler (void)
{
DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
doc: /* Number of elements from the call-stack recorded in the log. */);
profiler_max_stack_depth = 16;
DEFVAR_INT ("profiler-log-size", profiler_log_size,
doc: /* Number of distinct call-stacks that can be recorded in a profiler log.
If the log gets full, some of the least-seen call-stacks will be evicted
to make room for new entries. */);
profiler_log_size = 10000;
#ifdef PROFILER_CPU_SUPPORT
profiler_cpu_running = false;
cpu_log = Qnil;
staticpro (&cpu_log);
defsubr (&Sprofiler_cpu_start);
defsubr (&Sprofiler_cpu_stop);
defsubr (&Sprofiler_cpu_running_p);
defsubr (&Sprofiler_cpu_log);
#endif
profiler_memory_running = false;
memory_log = Qnil;
staticpro (&memory_log);
defsubr (&Sprofiler_memory_start);
defsubr (&Sprofiler_memory_stop);
defsubr (&Sprofiler_memory_running_p);
defsubr (&Sprofiler_memory_log);
}

20
src/xdisp.c
View file

@ -333,10 +333,10 @@ static Lisp_Object Qinhibit_eval_during_redisplay;
static Lisp_Object Qbuffer_position, Qposition, Qobject;
static Lisp_Object Qright_to_left, Qleft_to_right;
/* Cursor shapes */
/* Cursor shapes. */
Lisp_Object Qbar, Qhbar, Qbox, Qhollow;
/* Pointer shapes */
/* Pointer shapes. */
static Lisp_Object Qarrow, Qhand;
Lisp_Object Qtext;
@ -347,6 +347,7 @@ static Lisp_Object Qfontification_functions;
static Lisp_Object Qwrap_prefix;
static Lisp_Object Qline_prefix;
static Lisp_Object Qautomatic_redisplay;
/* Non-nil means don't actually do any redisplay. */
@ -12929,12 +12930,13 @@ redisplay_internal (void)
struct frame *sf;
int polling_stopped_here = 0;
Lisp_Object old_frame = selected_frame;
struct backtrace backtrace;
/* Non-zero means redisplay has to consider all windows on all
frames. Zero means, only selected_window is considered. */
int consider_all_windows_p;
/* Non-zero means redisplay has to redisplay the miniwindow */
/* Non-zero means redisplay has to redisplay the miniwindow. */
int update_miniwindow_p = 0;
TRACE ((stderr, "redisplay_internal %d\n", redisplaying_p));
@ -12971,6 +12973,14 @@ redisplay_internal (void)
redisplaying_p = 1;
specbind (Qinhibit_free_realized_faces, Qnil);
/* Record this function, so it appears on the profiler's backtraces. */
backtrace.next = backtrace_list;
backtrace.function = &Qautomatic_redisplay;
backtrace.args = &Qautomatic_redisplay;
backtrace.nargs = 0;
backtrace.debug_on_exit = 0;
backtrace_list = &backtrace;
{
Lisp_Object tail, frame;
@ -13668,6 +13678,7 @@ redisplay_internal (void)
#endif /* HAVE_WINDOW_SYSTEM */
end_of_redisplay:
backtrace_list = backtrace.next;
unbind_to (count, Qnil);
RESUME_POLLING;
}
@ -28683,6 +28694,7 @@ syms_of_xdisp (void)
staticpro (&Vmessage_stack);
DEFSYM (Qinhibit_redisplay, "inhibit-redisplay");
DEFSYM (Qautomatic_redisplay, "Automatic Redisplay");
message_dolog_marker1 = Fmake_marker ();
staticpro (&message_dolog_marker1);
@ -29349,7 +29361,7 @@ init_xdisp (void)
the following three functions in w32fns.c. */
#ifndef WINDOWSNT
/* Platform-independent portion of hourglass implementation. */
/* Platform-independent portion of hourglass implementation. */
/* Cancel a currently active hourglass timer, and start a new one. */
void