Merge profiler branch

12 files changed, 1252 insertions, 47 deletions

diff --git a/etc/NEWS b/etc/NEWS
index 8c206f049d3..123ca4de93c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -678,6 +678,11 @@ are deprecated and will be removed eventually.
 
 * Lisp changes in Emacs 24.3
 
+** New sampling-based Elisp profiler.
+Try M-x profiler-start ... M-x profiler-stop; and then M-x profiler-report.
+The sampling rate can be based on CPU time (only supported on some
+systems), or based on memory allocations.
+
 ** CL-style generalized variables are now in core Elisp.
 `setf' is autoloaded; `push' and `pop' accept generalized variables.
 
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 4599855e28d..349d74aa7d7 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2012-09-26  Tomohiro Matsuyama  <tomo@cx4a.org>
+            Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	* profiler.el: New file.
+
 2012-09-26  Stefan Monnier  <monnier@iro.umontreal.ca>
 
 	* emacs-lisp/testcover.el (testcover-after): Add gv-expander.
diff --git a/lisp/profiler.el b/lisp/profiler.el
new file mode 100644
index 00000000000..5fc74573262
--- /dev/null
+++ b/lisp/profiler.el
@@ -0,0 +1,665 @@
+;;; profiler.el --- UI and helper functions for Emacs's native profiler -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012 Free Software Foundation, Inc.
+
+;; Author: Tomohiro Matsuyama <tomo@cx4a.org>
+;; Keywords: lisp
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl-lib))
+
+(defgroup profiler nil
+  "Emacs profiler."
+  :group 'lisp
+  :prefix "profiler-")
+
+(defcustom profiler-sample-interval 1
+  "Default sample interval in millisecond."
+  :type 'integer
+  :group 'profiler)
+
+;;; Utilities
+
+(defun profiler-ensure-string (object)
+  (cond ((stringp object)
+	 object)
+	((symbolp object)
+	 (symbol-name object))
+	((numberp object)
+	 (number-to-string object))
+	(t
+	 (format "%s" object))))
+
+(defun profiler-format (fmt &rest args)
+  (cl-loop for (width align subfmt) in fmt
+	   for arg in args
+	   for str = (cond
+		      ((consp subfmt)
+		       (apply 'profiler-format subfmt arg))
+		      ((stringp subfmt)
+		       (format subfmt arg))
+		      ((and (symbolp subfmt)
+			    (fboundp subfmt))
+		       (funcall subfmt arg))
+		      (t
+		       (profiler-ensure-string arg)))
+	   for len = (length str)
+	   if (< width len)
+	   collect (substring str 0 width) into frags
+	   else
+	   collect
+	   (let ((padding (make-string (- width len) ?\s)))
+	     (cl-ecase align
+	       (left (concat str padding))
+	       (right (concat padding str))))
+	   into frags
+	   finally return (apply #'concat frags)))
+
+(defun profiler-format-percent (number divisor)
+  (concat (number-to-string (/ (* number 100) divisor)) "%"))
+
+(defun profiler-format-nbytes (nbytes)
+  "Format NBYTES in humarn readable string."
+  (if (and (integerp nbytes) (> nbytes 0))
+      (cl-loop with i = (% (1+ (floor (log10 nbytes))) 3)
+	       for c in (append (number-to-string nbytes) nil)
+	       if (= i 0)
+	       collect ?, into s
+	       and do (setq i 3)
+	       collect c into s
+	       do (cl-decf i)
+	       finally return
+	       (apply 'string (if (eq (car s) ?,) (cdr s) s)))
+    (profiler-ensure-string nbytes)))
+
+
+;;; Entries
+
+(defun profiler-entry-format (entry)
+  "Format ENTRY in human readable string.  ENTRY would be a
+function name of a function itself."
+  (cond ((memq (car-safe entry) '(closure lambda))
+	 (format "#<lambda 0x%x>" (sxhash entry)))
+	((byte-code-function-p entry)
+	 (format "#<compiled 0x%x>" (sxhash entry)))
+	((or (subrp entry) (symbolp entry) (stringp entry))
+	 (format "%s" entry))
+	(t
+	 (format "#<unknown 0x%x>" (sxhash entry)))))
+
+;;; Log data structure
+
+;; The C code returns the log in the form of a hash-table where the keys are
+;; vectors (of size profiler-max-stack-depth, holding truncated
+;; backtraces, where the first element is the top of the stack) and
+;; the values are integers (which count how many times this backtrace
+;; has been seen, multiplied by a "weight factor" which is either the
+;; sample-interval or the memory being allocated).
+;; We extend it by adding a few other entries to the hash-table, most notably:
+;; - Key `type' has a value indicating the kind of log (`memory' or `cpu').
+;; - Key `timestamp' has a value giving the time when the log was obtained.
+;; - Key `diff-p' indicates if this log represents a diff between two logs.
+
+(defun profiler-log-timestamp (log) (gethash 'timestamp log))
+(defun profiler-log-type (log) (gethash 'type log))
+(defun profiler-log-diff-p (log) (gethash 'diff-p log))
+
+(defun profiler-log-diff (log1 log2)
+  "Compare LOG1 with LOG2 and return a diff log.  Both logs must
+be same type."
+  (unless (eq (profiler-log-type log1)
+	      (profiler-log-type log2))
+    (error "Can't compare different type of logs"))
+  (let ((newlog (make-hash-table :test 'equal)))
+    ;; Make a copy of `log1' into `newlog'.
+    (maphash (lambda (backtrace count) (puthash backtrace count newlog))
+             log1)
+    (puthash 'diff-p t newlog)
+    (maphash (lambda (backtrace count)
+               (when (vectorp backtrace)
+                 (puthash backtrace (- (gethash backtrace log1 0) count)
+                          newlog)))
+             log2)
+    newlog))
+
+(defun profiler-log-fixup-entry (entry)
+  (if (symbolp entry)
+      entry
+    (profiler-entry-format entry)))
+
+(defun profiler-log-fixup-backtrace (backtrace)
+  (mapcar 'profiler-log-fixup-entry backtrace))
+
+(defun profiler-log-fixup (log)
+  "Fixup LOG so that the log could be serialized into file."
+  (let ((newlog (make-hash-table :test 'equal)))
+    (maphash (lambda (backtrace count)
+               (puthash (if (not (vectorp backtrace))
+                            backtrace
+                          (profiler-log-fixup-backtrace backtrace))
+                        count newlog))
+             log)
+    newlog))
+
+(defun profiler-log-write-file (log filename &optional confirm)
+  "Write LOG into FILENAME."
+  (with-temp-buffer
+    (let (print-level print-length)
+      (print (profiler-log-fixup log) (current-buffer)))
+    (write-file filename confirm)))
+
+(defun profiler-log-read-file (filename)
+  "Read log from FILENAME."
+  (with-temp-buffer
+    (insert-file-contents filename)
+    (goto-char (point-min))
+    (read (current-buffer))))
+
+
+;;; Calltree data structure
+
+(cl-defstruct (profiler-calltree (:constructor profiler-make-calltree))
+  entry
+  (count 0) (count-percent "")
+  parent children)
+
+(defun profiler-calltree-leaf-p (tree)
+  (null (profiler-calltree-children tree)))
+
+(defun profiler-calltree-count< (a b)
+  (cond ((eq (profiler-calltree-entry a) t) t)
+	((eq (profiler-calltree-entry b) t) nil)
+	(t (< (profiler-calltree-count a)
+	      (profiler-calltree-count b)))))
+
+(defun profiler-calltree-count> (a b)
+  (not (profiler-calltree-count< a b)))
+
+(defun profiler-calltree-depth (tree)
+  (let ((parent (profiler-calltree-parent tree)))
+    (if (null parent)
+	0
+      (1+ (profiler-calltree-depth parent)))))
+
+(defun profiler-calltree-find (tree entry)
+  "Return a child tree of ENTRY under TREE."
+  ;; OPTIMIZED
+  (let (result (children (profiler-calltree-children tree)))
+    ;; FIXME: Use `assoc'.
+    (while (and children (null result))
+      (let ((child (car children)))
+	(when (equal (profiler-calltree-entry child) entry)
+	  (setq result child))
+	(setq children (cdr children))))
+    result))
+
+(defun profiler-calltree-walk (calltree function)
+  (funcall function calltree)
+  (dolist (child (profiler-calltree-children calltree))
+    (profiler-calltree-walk child function)))
+
+(defun profiler-calltree-build-1 (tree log &optional reverse)
+  ;; FIXME: Do a better job of reconstructing a complete call-tree
+  ;; when the backtraces have been truncated.  Ideally, we should be
+  ;; able to reduce profiler-max-stack-depth to 3 or 4 and still
+  ;; get a meaningful call-tree.
+  (maphash
+   (lambda (backtrace count)
+     (when (vectorp backtrace)
+       (let ((node tree)
+	     (max (length backtrace)))
+	 (dotimes (i max)
+	   (let ((entry (aref backtrace (if reverse i (- max i 1)))))
+	     (when entry
+	       (let ((child (profiler-calltree-find node entry)))
+		 (unless child
+		   (setq child (profiler-make-calltree
+				:entry entry :parent node))
+		   (push child (profiler-calltree-children node)))
+		 (cl-incf (profiler-calltree-count child) count)
+		 (setq node child))))))))
+   log))
+
+(defun profiler-calltree-compute-percentages (tree)
+  (let ((total-count 0))
+    ;; FIXME: the memory profiler's total wraps around all too easily!
+    (dolist (child (profiler-calltree-children tree))
+      (cl-incf total-count (profiler-calltree-count child)))
+    (unless (zerop total-count)
+      (profiler-calltree-walk
+       tree (lambda (node)
+              (setf (profiler-calltree-count-percent node)
+                    (profiler-format-percent (profiler-calltree-count node)
+                                             total-count)))))))
+
+(cl-defun profiler-calltree-build (log &key reverse)
+  (let ((tree (profiler-make-calltree)))
+    (profiler-calltree-build-1 tree log reverse)
+    (profiler-calltree-compute-percentages tree)
+    tree))
+
+(defun profiler-calltree-sort (tree predicate)
+  (let ((children (profiler-calltree-children tree)))
+    (setf (profiler-calltree-children tree) (sort children predicate))
+    (dolist (child (profiler-calltree-children tree))
+      (profiler-calltree-sort child predicate))))
+
+
+;;; Report rendering
+
+(defcustom profiler-report-closed-mark "+"
+  "An indicator of closed calltrees."
+  :type 'string
+  :group 'profiler)
+
+(defcustom profiler-report-open-mark "-"
+  "An indicator of open calltrees."
+  :type 'string
+  :group 'profiler)
+
+(defcustom profiler-report-leaf-mark " "
+  "An indicator of calltree leaves."
+  :type 'string
+  :group 'profiler)
+
+(defvar profiler-report-sample-line-format
+  '((60 left)
+    (14 right ((9 right)
+	       (5 right)))))
+
+(defvar profiler-report-memory-line-format
+  '((55 left)
+    (19 right ((14 right profiler-format-nbytes)
+	       (5 right)))))
+
+(defvar-local profiler-report-log nil
+  "The current profiler log.")
+
+(defvar-local profiler-report-reversed nil
+  "True if calltree is rendered in bottom-up.  Do not touch this
+variable directly.")
+
+(defvar-local profiler-report-order nil
+  "The value can be `ascending' or `descending'.  Do not touch
+this variable directly.")
+
+(defun profiler-report-make-entry-part (entry)
+  (let ((string (cond
+		 ((eq entry t)
+		  "Others")
+		 ((and (symbolp entry)
+		       (fboundp entry))
+		  (propertize (symbol-name entry)
+			      'face 'link
+			      'mouse-face 'highlight
+			      'help-echo "mouse-2 or RET jumps to definition"))
+		 (t
+		  (profiler-entry-format entry)))))
+    (propertize string 'profiler-entry entry)))
+
+(defun profiler-report-make-name-part (tree)
+  (let* ((entry (profiler-calltree-entry tree))
+	 (depth (profiler-calltree-depth tree))
+	 (indent (make-string (* (1- depth) 2) ?\s))
+	 (mark (if (profiler-calltree-leaf-p tree)
+		   profiler-report-leaf-mark
+		 profiler-report-closed-mark))
+	 (entry (profiler-report-make-entry-part entry)))
+    (format "%s%s %s" indent mark entry)))
+
+(defun profiler-report-header-line-format (fmt &rest args)
+  (let* ((header (apply 'profiler-format fmt args))
+	 (escaped (replace-regexp-in-string "%" "%%" header)))
+    (concat " " escaped)))
+
+(defun profiler-report-line-format (tree)
+  (let ((diff-p (profiler-log-diff-p profiler-report-log))
+	(name-part (profiler-report-make-name-part tree))
+	(count (profiler-calltree-count tree))
+	(count-percent (profiler-calltree-count-percent tree)))
+    (profiler-format (cl-ecase (profiler-log-type profiler-report-log)
+		       (cpu profiler-report-sample-line-format)
+		       (memory profiler-report-memory-line-format))
+		     name-part
+		     (if diff-p
+			 (list (if (> count 0)
+				   (format "+%s" count)
+				 count)
+			       "")
+		       (list count count-percent)))))
+
+(defun profiler-report-insert-calltree (tree)
+  (let ((line (profiler-report-line-format tree)))
+    (insert (propertize (concat line "\n") 'calltree tree))))
+
+(defun profiler-report-insert-calltree-children (tree)
+  (mapc 'profiler-report-insert-calltree
+	(profiler-calltree-children tree)))
+
+
+;;; Report mode
+
+(defvar profiler-report-mode-map
+  (let ((map (make-sparse-keymap)))
+    ;; FIXME: Add menu.
+    (define-key map "n"	    'profiler-report-next-entry)
+    (define-key map "p"	    'profiler-report-previous-entry)
+    ;; I find it annoying more than helpful to not be able to navigate
+    ;; normally with the cursor keys.  --Stef
+    ;; (define-key map [down]  'profiler-report-next-entry)
+    ;; (define-key map [up]    'profiler-report-previous-entry)
+    (define-key map "\r"    'profiler-report-toggle-entry)
+    (define-key map "\t"    'profiler-report-toggle-entry)
+    (define-key map "i"     'profiler-report-toggle-entry)
+    (define-key map "f"     'profiler-report-find-entry)
+    (define-key map "j"     'profiler-report-find-entry)
+    (define-key map [mouse-2] 'profiler-report-find-entry)
+    (define-key map "d"	    'profiler-report-describe-entry)
+    (define-key map "C"	    'profiler-report-render-calltree)
+    (define-key map "B"	    'profiler-report-render-reversed-calltree)
+    (define-key map "A"	    'profiler-report-ascending-sort)
+    (define-key map "D"	    'profiler-report-descending-sort)
+    (define-key map "="	    'profiler-report-compare-log)
+    (define-key map (kbd "C-x C-w") 'profiler-report-write-log)
+    (define-key map "q"     'quit-window)
+    map))
+
+(defun profiler-report-make-buffer-name (log)
+  (format "*%s-Profiler-Report %s*"
+          (cl-ecase (profiler-log-type log) (cpu 'CPU) (memory 'Memory))
+          (format-time-string "%Y-%m-%d %T" (profiler-log-timestamp log))))
+
+(defun profiler-report-setup-buffer (log)
+  "Make a buffer for LOG and return it."
+  (let* ((buf-name (profiler-report-make-buffer-name log))
+	 (buffer (get-buffer-create buf-name)))
+    (with-current-buffer buffer
+      (profiler-report-mode)
+      (setq profiler-report-log log
+	    profiler-report-reversed nil
+	    profiler-report-order 'descending))
+    buffer))
+
+(define-derived-mode profiler-report-mode special-mode "Profiler-Report"
+  "Profiler Report Mode."
+  (setq buffer-read-only t
+	buffer-undo-list t
+	truncate-lines t))
+
+
+;;; Report commands
+
+(defun profiler-report-calltree-at-point ()
+  (get-text-property (point) 'calltree))
+
+(defun profiler-report-move-to-entry ()
+  (let ((point (next-single-property-change (line-beginning-position)
+                                            'profiler-entry)))
+    (if point
+	(goto-char point)
+      (back-to-indentation))))
+
+(defun profiler-report-next-entry ()
+  "Move cursor to next entry."
+  (interactive)
+  (forward-line)
+  (profiler-report-move-to-entry))
+
+(defun profiler-report-previous-entry ()
+  "Move cursor to previous entry."
+  (interactive)
+  (forward-line -1)
+  (profiler-report-move-to-entry))
+
+(defun profiler-report-expand-entry ()
+  "Expand entry at point."
+  (interactive)
+  (save-excursion
+    (beginning-of-line)
+    (when (search-forward (concat profiler-report-closed-mark " ")
+			  (line-end-position) t)
+      (let ((tree (profiler-report-calltree-at-point)))
+	(when tree
+	  (let ((inhibit-read-only t))
+	    (replace-match (concat profiler-report-open-mark " "))
+	    (forward-line)
+	    (profiler-report-insert-calltree-children tree)
+	    t))))))
+
+(defun profiler-report-collapse-entry ()
+  "Collpase entry at point."
+  (interactive)
+  (save-excursion
+    (beginning-of-line)
+    (when (search-forward (concat profiler-report-open-mark " ")
+			  (line-end-position) t)
+      (let* ((tree (profiler-report-calltree-at-point))
+	     (depth (profiler-calltree-depth tree))
+	     (start (line-beginning-position 2))
+	     d)
+	(when tree
+	  (let ((inhibit-read-only t))
+	    (replace-match (concat profiler-report-closed-mark " "))
+	    (while (and (eq (forward-line) 0)
+			(let ((child (get-text-property (point) 'calltree)))
+			  (and child
+			       (numberp (setq d (profiler-calltree-depth child)))))
+			(> d depth)))
+	    (delete-region start (line-beginning-position)))))
+      t)))
+
+(defun profiler-report-toggle-entry ()
+  "Expand entry at point if the tree is collapsed,
+otherwise collapse."
+  (interactive)
+  (or (profiler-report-expand-entry)
+      (profiler-report-collapse-entry)))
+
+(defun profiler-report-find-entry (&optional event)
+  "Find entry at point."
+  (interactive (list last-nonmenu-event))
+  (if event (posn-set-point (event-end event)))
+  (let ((tree (profiler-report-calltree-at-point)))
+    (when tree
+      (let ((entry (profiler-calltree-entry tree)))
+	(find-function entry)))))
+
+(defun profiler-report-describe-entry ()
+  "Describe entry at point."
+  (interactive)
+  (let ((tree (profiler-report-calltree-at-point)))
+    (when tree
+      (let ((entry (profiler-calltree-entry tree)))
+	(require 'help-fns)
+	(describe-function entry)))))
+
+(cl-defun profiler-report-render-calltree-1
+    (log &key reverse (order 'descending))
+  (let ((calltree (profiler-calltree-build profiler-report-log
+					   :reverse reverse)))
+    (setq header-line-format
+	  (cl-ecase (profiler-log-type log)
+	    (cpu
+	     (profiler-report-header-line-format
+	      profiler-report-sample-line-format
+	      "Function" (list "Time (ms)" "%")))
+	    (memory
+	     (profiler-report-header-line-format
+	      profiler-report-memory-line-format
+	      "Function" (list "Bytes" "%")))))
+    (let ((predicate (cl-ecase order
+		       (ascending #'profiler-calltree-count<)
+		       (descending #'profiler-calltree-count>))))
+      (profiler-calltree-sort calltree predicate))
+    (let ((inhibit-read-only t))
+      (erase-buffer)
+      (profiler-report-insert-calltree-children calltree)
+      (goto-char (point-min))
+      (profiler-report-move-to-entry))))
+
+(defun profiler-report-rerender-calltree ()
+  (profiler-report-render-calltree-1 profiler-report-log
+				     :reverse profiler-report-reversed
+				     :order profiler-report-order))
+
+(defun profiler-report-render-calltree ()
+  "Render calltree view."
+  (interactive)
+  (setq profiler-report-reversed nil)
+  (profiler-report-rerender-calltree))
+
+(defun profiler-report-render-reversed-calltree ()
+  "Render reversed calltree view."
+  (interactive)
+  (setq profiler-report-reversed t)
+  (profiler-report-rerender-calltree))
+
+(defun profiler-report-ascending-sort ()
+  "Sort calltree view in ascending order."
+  (interactive)
+  (setq profiler-report-order 'ascending)
+  (profiler-report-rerender-calltree))
+
+(defun profiler-report-descending-sort ()
+  "Sort calltree view in descending order."
+  (interactive)
+  (setq profiler-report-order 'descending)
+  (profiler-report-rerender-calltree))
+
+(defun profiler-report-log (log)
+  (let ((buffer (profiler-report-setup-buffer log)))
+    (with-current-buffer buffer
+      (profiler-report-render-calltree))
+    (pop-to-buffer buffer)))
+
+(defun profiler-report-compare-log (buffer)
+  "Compare the current profiler log with another."
+  (interactive (list (read-buffer "Compare to: ")))
+  (let* ((log1 (with-current-buffer buffer profiler-report-log))
+	 (log2 profiler-report-log)
+	 (diff-log (profiler-log-diff log1 log2)))
+    (profiler-report-log diff-log)))
+
+(defun profiler-report-write-log (filename &optional confirm)
+  "Write the current profiler log into FILENAME."
+  (interactive
+   (list (read-file-name "Write log: " default-directory)
+	 (not current-prefix-arg)))
+  (profiler-log-write-file profiler-report-log
+			   filename
+			   confirm))
+
+
+;;; Profiler commands
+
+;;;###autoload
+(defun profiler-start (mode)
+  "Start/restart profilers.
+MODE can be one of `cpu', `mem', or `cpu+mem'.
+If MODE is `cpu' or `cpu+mem', time-based profiler will be started.
+Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started."
+  (interactive
+   (list (if (not (fboundp 'profiler-cpu-start)) 'mem
+           (intern (completing-read "Mode (default cpu): "
+                                    '("cpu" "mem" "cpu+mem")
+                                    nil t nil nil "cpu")))))
+  (cl-ecase mode
+    (cpu
+     (profiler-cpu-start profiler-sample-interval)
+     (message "CPU profiler started"))
+    (mem
+     (profiler-memory-start)
+     (message "Memory profiler started"))
+    (cpu+mem
+     (profiler-cpu-start profiler-sample-interval)
+     (profiler-memory-start)
+     (message "CPU and memory profiler started"))))
+
+(defun profiler-stop ()
+  "Stop started profilers.  Profiler logs will be kept."
+  (interactive)
+  (let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop)))
+        (mem (profiler-memory-stop)))
+    (message "%s profiler stopped"
+             (cond ((and mem cpu) "CPU and memory")
+                   (mem "Memory")
+                   (cpu "CPU")
+                   (t "No")))))
+
+(defun profiler-reset ()
+  "Reset profiler log."
+  (interactive)
+  (when (fboundp 'profiler-cpu-log)
+    (ignore (profiler-cpu-log)))
+  (ignore (profiler-memory-log))
+  t)
+
+(defun profiler--report-cpu ()
+  (let ((log (if (fboundp 'profiler-cpu-log) (profiler-cpu-log))))
+    (when log
+      (puthash 'type 'cpu log)
+      (puthash 'timestamp (current-time) log)
+      (profiler-report-log log))))
+
+(defun profiler--report-memory ()
+  (let ((log (profiler-memory-log)))
+    (when log
+      (puthash 'type 'memory log)
+      (puthash 'timestamp (current-time) log)
+      (profiler-report-log log))))
+
+(defun profiler-report ()
+  "Report profiling results."
+  (interactive)
+  (profiler--report-cpu)
+  (profiler--report-memory))
+
+;;;###autoload
+(defun profiler-find-log (filename)
+  "Read a profiler log from FILENAME and report it."
+  (interactive
+   (list (read-file-name "Find log: " default-directory)))
+  (profiler-report-log (profiler-log-read-file filename)))
+
+
+;;; Profiling helpers
+
+;; (cl-defmacro with-sample-profiling ((&key interval) &rest body)
+;;   `(unwind-protect
+;;        (progn
+;;          (ignore (profiler-cpu-log))
+;;          (profiler-cpu-start ,interval)
+;;          ,@body)
+;;      (profiler-cpu-stop)
+;;      (profiler--report-cpu)))
+
+;; (defmacro with-memory-profiling (&rest body)
+;;   `(unwind-protect
+;;        (progn
+;;          (ignore (profiler-memory-log))
+;;          (profiler-memory-start)
+;;          ,@body)
+;;      (profiler-memory-stop)
+;;      (profiler--report-memory)))
+
+(provide 'profiler)
+;;; profiler.el ends here
diff --git a/src/ChangeLog b/src/ChangeLog
index 3e999f3f699..47e2b7a7fea 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,29 @@
+2012-09-26  Tomohiro Matsuyama  <tomo@cx4a.org>
+            Stefan Monnier  <monnier@iro.umontreal.ca>
+            Juanma Barranquero  <lekktu@gmail.com>
+
+	* profiler.c: New file.
+	* Makefile.in (base_obj): Add profiler.o.
+	* makefile.w32-in (OBJ2, GLOBAL_SOURCES): Add profiler.c.
+	($(BLD)/profiler.$(O)): New target.
+	* emacs.c (main): Call syms_of_profiler.
+	* alloc.c (Qautomatic_gc): New constant.
+	(MALLOC_PROBE): New macro.
+	(xmalloc, xzalloc, xrealloc, lisp_malloc, lisp_align_malloc): Use it.
+	(total_bytes_of_live_objects): New function.
+	(Fgarbage_collect): Use it.  Record itself in backtrace_list.
+	Call malloc_probe for the memory profiler.
+	(syms_of_alloc): Define Qautomatic_gc.
+	* eval.c (eval_sub, Ffuncall): Reorder assignments to avoid
+	race condition.
+	(struct backtrace): Move definition...
+	* lisp.h (struct backtrace): ..here.
+	(Qautomatic_gc, profiler_memory_running): Declare vars.
+	(malloc_probe, syms_of_profiler): Declare functions.
+	* xdisp.c (Qautomatic_redisplay): New constant.
+	(redisplay_internal): Record itself in backtrace_list.
+	(syms_of_xdisp): Define Qautomatic_redisplay.
+
 2012-09-25  Juanma Barranquero  <lekktu@gmail.com>
 
 	* makefile.w32-in ($(BLD)/callproc.$(O)): Update dependencies.
@@ -291,8 +317,8 @@
 	(reinvoke_input_signal): Remove.  All uses replaced by
 	handle_async_input.
 	(quit_count): Now volatile, since a signal handler uses it.
-	(handle_interrupt): Now takes bool IN_SIGNAL_HANDLER as arg.  All
-	callers changed.  Block SIGINT only if not already blocked.
+	(handle_interrupt): Now takes bool IN_SIGNAL_HANDLER as arg.
+	All callers changed.  Block SIGINT only if not already blocked.
 	Clear sigmask reliably, even if Fsignal returns, which it can.
 	Omit unnecessary accesses to volatile var.
 	(quit_throw_to_read_char): No need to restore sigmask.
@@ -392,8 +418,8 @@
 	if it is defined.  Arguments and return value changed.
 	(valid_image_p, make_image): Callers changed.
 	(xbm_type, xpm_type, pbm_type, png_type, jpeg_type, tiff_type)
-	(gif_type, imagemagick_type, svg_type, gs_type): Add
-	initialization functions.
+	(gif_type, imagemagick_type, svg_type, gs_type):
+	Add initialization functions.
 	(Finit_image_library): Call lookup_image_type.
 	(CHECK_LIB_AVAILABLE): Macro deleted.
 	(lookup_image_type): Call define_image_type here, rather than via
@@ -415,8 +441,8 @@
 	* window.c (Fsplit_window_internal): Handle only Qt value of
 	Vwindow_combination_limit separately.
 	(Qtemp_buffer_resize): New symbol.
-	(Vwindow_combination_limit): New default value.  Rewrite
-	doc-string.
+	(Vwindow_combination_limit): New default value.
+	Rewrite doc-string.
 
 2012-09-22  Eli Zaretskii  <eliz@gnu.org>
 
@@ -515,7 +541,7 @@
 	(Fx_create_frame): Call x_set_offset to correctly interpret
 	top_pos in geometry.
 
-	* frame.c (read_integer, XParseGeometry): Moved from w32xfns.c.
+	* frame.c (read_integer, XParseGeometry): Move from w32xfns.c.
 	(Fx_parse_geometry): If there is a space in string, call
 	Qns_parse_geometry, otherwise do as on other terms (Bug#12368).
 
@@ -616,8 +642,8 @@
 
 2012-09-16  Martin Rudalics  <rudalics@gmx.at>
 
-	* window.c (Fwindow_parameter, Fset_window_parameter): Accept
-	any window as argument (Bug#12452).
+	* window.c (Fwindow_parameter, Fset_window_parameter):
+	Accept any window as argument (Bug#12452).
 
 2012-09-16  Jan Djärv  <jan.h.d@swipnet.se>
 
@@ -692,8 +718,8 @@
 2012-09-14  Dmitry Antipov  <dmantipov@yandex.ru>
 
 	Avoid out-of-range marker position (Bug#12426).
-	* insdel.c (replace_range, replace_range_2): Adjust
-	markers before overlays, as suggested by comments.
+	* insdel.c (replace_range, replace_range_2):
+	Adjust markers before overlays, as suggested by comments.
 	(insert_1_both, insert_from_buffer_1, adjust_after_replace):
 	Remove redundant check before calling offset_intervals.
 
@@ -992,8 +1018,8 @@
 	in the internal border.
 	(x_set_window_size): Remove static variables and their usage.
 	(ns_redraw_scroll_bars): Fix NSTRACE arg.
-	(ns_after_update_window_line, ns_draw_fringe_bitmap): Remove
-	fringe/internal border adjustment (Bug#11052).
+	(ns_after_update_window_line, ns_draw_fringe_bitmap):
+	Remove fringe/internal border adjustment (Bug#11052).
 	(ns_draw_fringe_bitmap): Make code more like other terms (xterm.c).
 	(ns_draw_window_cursor): Remove fringe/internal border adjustment.
 	(ns_fix_rect_ibw): Remove.
@@ -1210,8 +1236,8 @@
 	(init_signals) [FORWARD_SIGNAL_TO_MAIN_THREAD]: Initialize it;
 	code moved here from emacs.c's main function.
 	* sysdep.c, syssignal.h (handle_on_main_thread): New function,
-	replacing the old SIGNAL_THREAD_CHECK.  All uses changed.  This
-	lets callers save and restore errno properly.
+	replacing the old SIGNAL_THREAD_CHECK.  All uses changed.
+	This lets callers save and restore errno properly.
 
 2012-09-05  Dmitry Antipov  <dmantipov@yandex.ru>
 
@@ -1520,8 +1546,8 @@
 	* process.c: Include TERM_HEADER instead of listing all possible
 	window-system headers.
 
-	* nsterm.h: Remove declarations now in frame.h.  Define
-	FRAME_X_SCREEN, FRAME_X_VISUAL.
+	* nsterm.h: Remove declarations now in frame.h.
+	Define FRAME_X_SCREEN, FRAME_X_VISUAL.
 
 	* menu.c: Include TERM_HEADER instead of listing all possible
 	window-system headers.
@@ -1717,8 +1743,8 @@
 
 	* nsterm.h (NSPanel): New class variable dialog_return.
 
-	* nsmenu.m (initWithContentRect:styleMask:backing:defer:): Initialize
-	dialog_return.
+	* nsmenu.m (initWithContentRect:styleMask:backing:defer:):
+	Initialize dialog_return.
 	(windowShouldClose:): Use stop instead of stopModalWithCode.
 	(clicked:): Ditto, and also set dialog_return (Bug#12258).
 	(timeout_handler:): Use stop instead of abortModal.  Send a dummy
diff --git a/src/Makefile.in b/src/Makefile.in
index 37da170edbd..e43f83e1172 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -339,6 +339,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
 	process.o gnutls.o callproc.o \
 	region-cache.o sound.o atimer.o \
 	doprnt.o intervals.o textprop.o composite.o xml.o \
+	profiler.o \
 	$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
 	$(WINDOW_SYSTEM_OBJ)
 obj = $(base_obj) $(NS_OBJC_OBJ)
diff --git a/src/alloc.c b/src/alloc.c
index 923e8736a86..46c9a10c725 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -205,6 +205,7 @@ static Lisp_Object Qintervals;
 static Lisp_Object Qbuffers;
 static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
 static Lisp_Object Qgc_cons_threshold;
+Lisp_Object Qautomatic_gc;
 Lisp_Object Qchar_table_extra_slots;
 
 /* Hook run after GC has finished.  */
@@ -648,6 +649,13 @@ malloc_unblock_input (void)
 # define MALLOC_UNBLOCK_INPUT ((void) 0)
 #endif
 
+#define MALLOC_PROBE(size)			\
+  do {						\
+    if (profiler_memory_running)		\
+      malloc_probe (size);			\
+  } while (0)
+
+
 /* Like malloc but check for no memory and block interrupt input..  */
 
 void *
@@ -661,6 +669,7 @@ xmalloc (size_t size)
 
   if (!val && size)
     memory_full (size);
+  MALLOC_PROBE (size);
   return val;
 }
 
@@ -678,6 +687,7 @@ xzalloc (size_t size)
   if (!val && size)
     memory_full (size);
   memset (val, 0, size);
+  MALLOC_PROBE (size);
   return val;
 }
 
@@ -699,6 +709,7 @@ xrealloc (void *block, size_t size)
 
   if (!val && size)
     memory_full (size);
+  MALLOC_PROBE (size);
   return val;
 }
 
@@ -888,6 +899,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
   MALLOC_UNBLOCK_INPUT;
   if (!val && nbytes)
     memory_full (nbytes);
+  MALLOC_PROBE (nbytes);
   return val;
 }
 
@@ -1093,6 +1105,8 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
 
   MALLOC_UNBLOCK_INPUT;
 
+  MALLOC_PROBE (nbytes);
+
   eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
   return val;
 }
@@ -5043,6 +5057,23 @@ bounded_number (EMACS_INT number)
   return make_number (min (MOST_POSITIVE_FIXNUM, number));
 }
 
+/* Calculate total bytes of live objects.  */
+
+static size_t
+total_bytes_of_live_objects (void)
+{
+  size_t tot = 0;
+  tot += total_conses  * sizeof (struct Lisp_Cons);
+  tot += total_symbols * sizeof (struct Lisp_Symbol);
+  tot += total_markers * sizeof (union Lisp_Misc);
+  tot += total_string_bytes;
+  tot += total_vector_slots * word_size;
+  tot += total_floats  * sizeof (struct Lisp_Float);
+  tot += total_intervals * sizeof (struct interval);
+  tot += total_strings * sizeof (struct Lisp_String);
+  return tot;
+}
+
 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
        doc: /* Reclaim storage for Lisp objects no longer needed.
 Garbage collection happens automatically if you cons more than
@@ -5068,6 +5099,8 @@ See Info node `(elisp)Garbage Collection'.  */)
   ptrdiff_t count = SPECPDL_INDEX ();
   EMACS_TIME start;
   Lisp_Object retval = Qnil;
+  size_t tot_before = 0;
+  struct backtrace backtrace;
 
   if (abort_on_gc)
     emacs_abort ();
@@ -5077,6 +5110,14 @@ See Info node `(elisp)Garbage Collection'.  */)
   if (pure_bytes_used_before_overflow)
     return Qnil;
 
+  /* Record this function, so it appears on the profiler's backtraces.  */
+  backtrace.next = backtrace_list;
+  backtrace.function = &Qautomatic_gc;
+  backtrace.args = &Qautomatic_gc;
+  backtrace.nargs = 0;
+  backtrace.debug_on_exit = 0;
+  backtrace_list = &backtrace;
+
   check_cons_list ();
 
   /* Don't keep undo information around forever.
@@ -5084,6 +5125,9 @@ See Info node `(elisp)Garbage Collection'.  */)
   FOR_EACH_BUFFER (nextb)
     compact_buffer (nextb);
 
+  if (profiler_memory_running)
+    tot_before = total_bytes_of_live_objects ();
+
   start = current_emacs_time ();
 
   /* In case user calls debug_print during GC,
@@ -5255,16 +5299,7 @@ See Info node `(elisp)Garbage Collection'.  */)
   gc_relative_threshold = 0;
   if (FLOATP (Vgc_cons_percentage))
     { /* Set gc_cons_combined_threshold.  */
-      double tot = 0;
-
-      tot += total_conses  * sizeof (struct Lisp_Cons);
-      tot += total_symbols * sizeof (struct Lisp_Symbol);
-      tot += total_markers * sizeof (union Lisp_Misc);
-      tot += total_string_bytes;
-      tot += total_vector_slots * word_size;
-      tot += total_floats  * sizeof (struct Lisp_Float);
-      tot += total_intervals * sizeof (struct interval);
-      tot += total_strings * sizeof (struct Lisp_String);
+      double tot = total_bytes_of_live_objects ();
 
       tot *= XFLOAT_DATA (Vgc_cons_percentage);
       if (0 < tot)
@@ -5367,6 +5402,17 @@ See Info node `(elisp)Garbage Collection'.  */)
 
   gcs_done++;
 
+  /* Collect profiling data.  */
+  if (profiler_memory_running)
+    {
+      size_t swept = 0;
+      size_t tot_after = total_bytes_of_live_objects ();
+      if (tot_before > tot_after)
+	swept = tot_before - tot_after;
+      malloc_probe (swept);
+    }
+
+  backtrace_list = backtrace.next;
   return retval;
 }
 
@@ -6527,6 +6573,7 @@ do hash-consing of the objects allocated to pure space.  */);
   DEFSYM (Qstring_bytes, "string-bytes");
   DEFSYM (Qvector_slots, "vector-slots");
   DEFSYM (Qheap, "heap");
+  DEFSYM (Qautomatic_gc, "Automatic GC");
 
   DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
   DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
diff --git a/src/emacs.c b/src/emacs.c
index 5aae812b869..05affeefde7 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1419,6 +1419,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
       syms_of_ntterm ();
 #endif /* WINDOWSNT */
 
+      syms_of_profiler ();
+
       keys_of_casefiddle ();
       keys_of_cmds ();
       keys_of_buffer ();
diff --git a/src/eval.c b/src/eval.c
index 25a41486279..d984331ec41 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -31,17 +31,7 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #include "xterm.h"
 #endif
 
-struct backtrace
-{
-  struct backtrace *next;
-  Lisp_Object *function;
-  Lisp_Object *args;	/* Points to vector of args.  */
-  ptrdiff_t nargs;	/* Length of vector.  */
-  /* Nonzero means call value of debugger when done with this operation.  */
-  unsigned int debug_on_exit : 1;
-};
-
-static struct backtrace *backtrace_list;
+struct backtrace *backtrace_list;
 
 #if !BYTE_MARK_STACK
 static
@@ -2055,11 +2045,11 @@ eval_sub (Lisp_Object form)
   original_args = XCDR (form);
 
   backtrace.next = backtrace_list;
-  backtrace_list = &backtrace;
   backtrace.function = &original_fun; /* This also protects them from gc.  */
   backtrace.args = &original_args;
   backtrace.nargs = UNEVALLED;
   backtrace.debug_on_exit = 0;
+  backtrace_list = &backtrace;
 
   if (debug_on_next_call)
     do_debug_on_call (Qt);
@@ -2730,11 +2720,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS)  */)
     }
 
   backtrace.next = backtrace_list;
-  backtrace_list = &backtrace;
   backtrace.function = &args[0];
   backtrace.args = &args[1];	/* This also GCPROs them.  */
   backtrace.nargs = nargs - 1;
   backtrace.debug_on_exit = 0;
+  backtrace_list = &backtrace;
 
   /* Call GC after setting up the backtrace, so the latter GCPROs the args.  */
   maybe_gc ();
diff --git a/src/lisp.h b/src/lisp.h
index 35efa67e707..21ac55c1063 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2031,6 +2031,18 @@ extern ptrdiff_t specpdl_size;
 
 #define SPECPDL_INDEX()	(specpdl_ptr - specpdl)
 
+struct backtrace
+{
+  struct backtrace *next;
+  Lisp_Object *function;
+  Lisp_Object *args;	/* Points to vector of args.  */
+  ptrdiff_t nargs;	/* Length of vector.  */
+  /* Nonzero means call value of debugger when done with this operation.  */
+  unsigned int debug_on_exit : 1;
+};
+
+extern struct backtrace *backtrace_list;
+
 /* Everything needed to describe an active condition case.
 
    Members are volatile if their values need to survive _longjmp when
@@ -2916,6 +2928,7 @@ build_string (const char *str)
 
 extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
 extern void make_byte_code (struct Lisp_Vector *);
+extern Lisp_Object Qautomatic_gc;
 extern Lisp_Object Qchar_table_extra_slots;
 extern struct Lisp_Vector *allocate_vector (EMACS_INT);
 extern struct Lisp_Vector *allocate_pseudovector (int memlen, int lisplen, int tag);
@@ -3534,6 +3547,13 @@ extern int have_menus_p (void);
 void syms_of_dbusbind (void);
 #endif
 
+
+/* Defined in profiler.c.  */
+extern bool profiler_memory_running;
+extern void malloc_probe (size_t);
+extern void syms_of_profiler (void);
+
+
 #ifdef DOS_NT
 /* Defined in msdos.c, w32.c.  */
 extern char *emacs_root_dir (void);
diff --git a/src/makefile.w32-in b/src/makefile.w32-in
index bed6f215711..6f228ed0bb3 100644
--- a/src/makefile.w32-in
+++ b/src/makefile.w32-in
@@ -125,6 +125,7 @@ OBJ2 =  $(BLD)/sysdep.$(O)		\
 	$(BLD)/terminal.$(O)            \
 	$(BLD)/menu.$(O)		\
 	$(BLD)/xml.$(O)			\
+	$(BLD)/profiler.$(O)		\
 	$(BLD)/w32term.$(O)		\
 	$(BLD)/w32xfns.$(O)		\
 	$(BLD)/w32fns.$(O)		\
@@ -222,7 +223,7 @@ GLOBAL_SOURCES =   dosfns.c msdos.c \
 	process.c callproc.c unexw32.c \
 	region-cache.c sound.c atimer.c \
 	doprnt.c intervals.c textprop.c composite.c \
-	gnutls.c xml.c
+	gnutls.c xml.c profiler.c
 SOME_MACHINE_OBJECTS = dosfns.o msdos.o \
 	xterm.o xfns.o xmenu.o xselect.o xrdb.o xsmfns.o dbusbind.o
 obj = $(GLOBAL_SOURCES:.c=.o)
@@ -973,6 +974,11 @@ $(BLD)/xml.$(O) : \
 	$(CONFIG_H) \
 	$(LISP_H)
 
+$(BLD)/profiler.$(O) : \
+	$(SRC)/profiler.c \
+	$(CONFIG_H) \
+	$(LISP_H)
+
 $(BLD)/image.$(O) : \
 	$(SRC)/image.c \
 	$(SRC)/blockinput.h \
diff --git a/src/profiler.c b/src/profiler.c
new file mode 100644
index 00000000000..f8fa697d79d
--- /dev/null
+++ b/src/profiler.c
@@ -0,0 +1,426 @@
+/* Profiler implementation.
+
+Copyright (C) 2012 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include <config.h>
+#include <stdio.h>
+#include <limits.h>
+#include <sys/time.h>
+#include <signal.h>
+#include <setjmp.h>
+#include "lisp.h"
+
+/* Logs.  */
+
+typedef struct Lisp_Hash_Table log_t;
+
+static Lisp_Object
+make_log (int heap_size, int max_stack_depth)
+{
+  /* We use a standard Elisp hash-table object, but we use it in
+     a special way.  This is OK as long as the object is not exposed
+     to Elisp, i.e. until it is returned by *-profiler-log, after which
+     it can't be used any more.  */
+  Lisp_Object log = make_hash_table (Qequal, make_number (heap_size),
+				     make_float (DEFAULT_REHASH_SIZE),
+				     make_float (DEFAULT_REHASH_THRESHOLD),
+				     Qnil, Qnil, Qnil);
+  struct Lisp_Hash_Table *h = XHASH_TABLE (log);
+
+  /* What is special about our hash-tables is that the keys are pre-filled
+     with the vectors we'll put in them.  */
+  int i = ASIZE (h->key_and_value) / 2;
+  while (0 < i)
+    set_hash_key_slot (h, --i,
+		       Fmake_vector (make_number (max_stack_depth), Qnil));
+  return log;
+}
+
+/* Evict the least used half of the hash_table.
+
+   When the table is full, we have to evict someone.
+   The easiest and most efficient is to evict the value we're about to add
+   (i.e. once the table is full, stop sampling).
+
+   We could also pick the element with the lowest count and evict it,
+   but finding it is O(N) and for that amount of work we get very
+   little in return: for the next sample, this latest sample will have
+   count==1 and will hence be a prime candidate for eviction :-(
+
+   So instead, we take O(N) time to eliminate more or less half of the
+   entries (the half with the lowest counts).  So we get an amortized
+   cost of O(1) and we get O(N) time for a new entry to grow larger
+   than the other least counts before a new round of eviction.  */
+
+static EMACS_INT approximate_median (log_t *log,
+				     ptrdiff_t start, ptrdiff_t size)
+{
+  eassert (size > 0);
+  if (size < 2)
+    return XINT (HASH_VALUE (log, start));
+  if (size < 3)
+    /* Not an actual median, but better for our application than
+       choosing either of the two numbers.  */
+    return ((XINT (HASH_VALUE (log, start))
+	     + XINT (HASH_VALUE (log, start + 1)))
+	    / 2);
+  else
+    {
+      ptrdiff_t newsize = size / 3;
+      ptrdiff_t start2 = start + newsize;
+      EMACS_INT i1 = approximate_median (log, start, newsize);
+      EMACS_INT i2 = approximate_median (log, start2, newsize);
+      EMACS_INT i3 = approximate_median (log, start2 + newsize,
+					 size - 2 * newsize);
+      return (i1 < i2
+	      ? (i2 < i3 ? i2 : (i1 < i3 ? i3 : i1))
+	      : (i1 < i3 ? i1 : (i2 < i3 ? i3 : i2)));
+    }
+}
+
+static void evict_lower_half (log_t *log)
+{
+  ptrdiff_t size = ASIZE (log->key_and_value) / 2;
+  EMACS_INT median = approximate_median (log, 0, size);
+  ptrdiff_t i;
+
+  for (i = 0; i < size; i++)
+    /* Evict not only values smaller but also values equal to the median,
+       so as to make sure we evict something no matter what.  */
+    if (XINT (HASH_VALUE (log, i)) <= median)
+      {
+	Lisp_Object key = HASH_KEY (log, i);
+	{ /* FIXME: we could make this more efficient.  */
+	  Lisp_Object tmp;
+	  XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr.  */
+	  Fremhash (key, tmp);
+	}
+	eassert (EQ (log->next_free, make_number (i)));
+	{
+	  int j;
+	  eassert (VECTORP (key));
+	  for (j = 0; j < ASIZE (key); j++)
+	    ASET (key, j, Qnil);
+	}
+	set_hash_key_slot (log, i, key);
+      }
+}
+
+/* Record the current backtrace in LOG. BASE is a special name for
+   describing which the backtrace come from. BASE can be nil. COUNT is
+   a number how many times the profiler sees the backtrace at the
+   time.  ELAPSED is a elapsed time in millisecond that the backtrace
+   took.  */
+
+static void
+record_backtrace (log_t *log, size_t count)
+{
+  struct backtrace *backlist = backtrace_list;
+  Lisp_Object backtrace;
+  ptrdiff_t index, i = 0;
+  ptrdiff_t asize;
+
+  if (!INTEGERP (log->next_free))
+    /* FIXME: transfer the evicted counts to a special entry rather
+       than dropping them on the floor.  */
+    evict_lower_half (log);
+  index = XINT (log->next_free);
+
+  /* Get a "working memory" vector.  */
+  backtrace = HASH_KEY (log, index);
+  asize = ASIZE (backtrace);
+
+  /* Copy the backtrace contents into working memory.  */
+  for (; i < asize && backlist; i++, backlist = backlist->next)
+    /* FIXME: For closures we should ignore the environment.  */
+    ASET (backtrace, i, *backlist->function);
+
+  /* Make sure that unused space of working memory is filled with nil.  */
+  for (; i < asize; i++)
+    ASET (backtrace, i, Qnil);
+
+  { /* We basically do a `gethash+puthash' here, except that we have to be
+       careful to avoid memory allocation since we're in a signal
+       handler, and we optimize the code to try and avoid computing the
+       hash+lookup twice.  See fns.c:Fputhash for reference.  */
+    EMACS_UINT hash;
+    ptrdiff_t j = hash_lookup (log, backtrace, &hash);
+    if (j >= 0)
+      set_hash_value_slot (log, j,
+			   make_number (count + XINT (HASH_VALUE (log, j))));
+    else
+      { /* BEWARE!  hash_put in general can allocate memory.
+	   But currently it only does that if log->next_free is nil.  */
+	int j;
+	eassert (!NILP (log->next_free));
+	j = hash_put (log, backtrace, make_number (count), hash);
+	/* Let's make sure we've put `backtrace' right where it
+	   already was to start with.  */
+	eassert (index == j);
+
+	/* FIXME: If the hash-table is almost full, we should set
+	   some global flag so that some Elisp code can offload its
+	   data elsewhere, so as to avoid the eviction code.
+	   There are 2 ways to do that, AFAICT:
+	   - Set a flag checked in QUIT, such that QUIT can then call
+	     Fprofiler_cpu_log and stash the full log for later use.
+	   - Set a flag check in post-gc-hook, so that Elisp code can call
+	     profiler-cpu-log.  That gives us more flexibility since that
+	     Elisp code can then do all kinds of fun stuff like write
+	     the log to disk.  Or turn it right away into a call tree.
+	   Of course, using Elisp is generally preferable, but it may
+	   take longer until we get a chance to run the Elisp code, so
+	   there's more risk that the table will get full before we
+	   get there.  */
+      }
+  }
+}
+
+/* Sample profiler.  */
+
+/* FIXME: Add support for the CPU profiler in W32.  */
+/* FIXME: the sigprof_handler suffers from race-conditions if the signal
+   is delivered to a thread other than the main Emacs thread.  */
+
+#if defined SIGPROF && defined HAVE_SETITIMER
+#define PROFILER_CPU_SUPPORT
+
+/* True if sampling profiler is running.  */
+static bool profiler_cpu_running;
+
+static Lisp_Object cpu_log;
+/* Separate counter for the time spent in the GC.  */
+static EMACS_INT cpu_gc_count;
+
+/* The current sample interval in millisecond.  */
+
+static int current_sample_interval;
+
+/* Signal handler for sample profiler.  */
+
+static void
+sigprof_handler (int signal, siginfo_t *info, void *ctx)
+{
+  eassert (HASH_TABLE_P (cpu_log));
+  if (backtrace_list && EQ (*backtrace_list->function, Qautomatic_gc))
+    /* Special case the time-count inside GC because the hash-table
+       code is not prepared to be used while the GC is running.
+       More specifically it uses ASIZE at many places where it does
+       not expect the ARRAY_MARK_FLAG to be set.  We could try and
+       harden the hash-table code, but it doesn't seem worth the
+       effort.  */
+    cpu_gc_count += current_sample_interval;
+  else
+    record_backtrace (XHASH_TABLE (cpu_log), current_sample_interval);
+}
+
+DEFUN ("profiler-cpu-start", Fprofiler_cpu_start, Sprofiler_cpu_start,
+       1, 1, 0,
+       doc: /* Start or restart the cpu profiler.
+The cpu profiler will take call-stack samples each SAMPLE-INTERVAL (expressed in milliseconds).
+See also `profiler-log-size' and `profiler-max-stack-depth'.  */)
+  (Lisp_Object sample_interval)
+{
+  struct sigaction sa;
+  struct itimerval timer;
+
+  if (profiler_cpu_running)
+    error ("Sample profiler is already running");
+
+  if (NILP (cpu_log))
+    {
+      cpu_gc_count = 0;
+      cpu_log = make_log (profiler_log_size,
+			  profiler_max_stack_depth);
+    }
+
+  current_sample_interval = XINT (sample_interval);
+
+  sa.sa_sigaction = sigprof_handler;
+  sa.sa_flags = SA_RESTART | SA_SIGINFO;
+  sigemptyset (&sa.sa_mask);
+  sigaction (SIGPROF, &sa, 0);
+
+  timer.it_interval.tv_sec = 0;
+  timer.it_interval.tv_usec = current_sample_interval * 1000;
+  timer.it_value = timer.it_interval;
+  setitimer (ITIMER_PROF, &timer, 0);
+
+  profiler_cpu_running = true;
+
+  return Qt;
+}
+
+DEFUN ("profiler-cpu-stop", Fprofiler_cpu_stop, Sprofiler_cpu_stop,
+       0, 0, 0,
+       doc: /* Stop the cpu profiler.  The profiler log is not affected.
+Return non-nil if the profiler was running.  */)
+  (void)
+{
+  if (!profiler_cpu_running)
+    return Qnil;
+  profiler_cpu_running = false;
+
+  setitimer (ITIMER_PROF, 0, 0);
+
+  return Qt;
+}
+
+DEFUN ("profiler-cpu-running-p",
+       Fprofiler_cpu_running_p, Sprofiler_cpu_running_p,
+       0, 0, 0,
+       doc: /* Return non-nil iff cpu profiler is running.  */)
+  (void)
+{
+  return profiler_cpu_running ? Qt : Qnil;
+}
+
+DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_log,
+       0, 0, 0,
+       doc: /* Return the current cpu profiler log.
+The log is a hash-table mapping backtraces to counters which represent
+the amount of time spent at those points.  Every backtrace is a vector
+of functions, where the last few elements may be nil.
+Before returning, a new log is allocated for future samples.  */)
+  (void)
+{
+  Lisp_Object result = cpu_log;
+  /* Here we're making the log visible to Elisp , so it's not safe any
+     more for our use afterwards since we can't rely on its special
+     pre-allocated keys anymore.  So we have to allocate a new one.  */
+  cpu_log = (profiler_cpu_running
+	     ? make_log (profiler_log_size, profiler_max_stack_depth)
+	     : Qnil);
+  Fputhash (Fmake_vector (make_number (1), Qautomatic_gc),
+	    make_number (cpu_gc_count),
+	    result);
+  cpu_gc_count = 0;
+  return result;
+}
+#endif	/* not defined PROFILER_CPU_SUPPORT */
+
+/* Memory profiler.  */
+
+/* True if memory profiler is running.  */
+bool profiler_memory_running;
+
+static Lisp_Object memory_log;
+
+DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start,
+       0, 0, 0,
+       doc: /* Start/restart the memory profiler.
+The memory profiler will take samples of the call-stack whenever a new
+allocation takes place.  Note that most small allocations only trigger
+the profiler occasionally.
+See also `profiler-log-size' and `profiler-max-stack-depth'.  */)
+  (void)
+{
+  if (profiler_memory_running)
+    error ("Memory profiler is already running");
+
+  if (NILP (memory_log))
+    memory_log = make_log (profiler_log_size,
+			   profiler_max_stack_depth);
+
+  profiler_memory_running = true;
+
+  return Qt;
+}
+
+DEFUN ("profiler-memory-stop",
+       Fprofiler_memory_stop, Sprofiler_memory_stop,
+       0, 0, 0,
+       doc: /* Stop the memory profiler.  The profiler log is not affected.
+Return non-nil if the profiler was running.  */)
+  (void)
+{
+  if (!profiler_memory_running)
+    return Qnil;
+  profiler_memory_running = false;
+  return Qt;
+}
+
+DEFUN ("profiler-memory-running-p",
+       Fprofiler_memory_running_p, Sprofiler_memory_running_p,
+       0, 0, 0,
+       doc: /* Return non-nil if memory profiler is running.  */)
+  (void)
+{
+  return profiler_memory_running ? Qt : Qnil;
+}
+
+DEFUN ("profiler-memory-log",
+       Fprofiler_memory_log, Sprofiler_memory_log,
+       0, 0, 0,
+       doc: /* Return the current memory profiler log.
+The log is a hash-table mapping backtraces to counters which represent
+the amount of memory allocated at those points.  Every backtrace is a vector
+of functions, where the last few elements may be nil.
+Before returning, a new log is allocated for future samples.  */)
+  (void)
+{
+  Lisp_Object result = memory_log;
+  /* Here we're making the log visible to Elisp , so it's not safe any
+     more for our use afterwards since we can't rely on its special
+     pre-allocated keys anymore.  So we have to allocate a new one.  */
+  memory_log = (profiler_memory_running
+		? make_log (profiler_log_size, profiler_max_stack_depth)
+		: Qnil);
+  return result;
+}
+
+
+/* Signals and probes.  */
+
+/* Record that the current backtrace allocated SIZE bytes.  */
+void
+malloc_probe (size_t size)
+{
+  eassert (HASH_TABLE_P (memory_log));
+  record_backtrace (XHASH_TABLE (memory_log), size);
+}
+
+void
+syms_of_profiler (void)
+{
+  DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
+	      doc: /* Number of elements from the call-stack recorded in the log.  */);
+  profiler_max_stack_depth = 16;
+  DEFVAR_INT ("profiler-log-size", profiler_log_size,
+	      doc: /* Number of distinct call-stacks that can be recorded in a profiler log.
+If the log gets full, some of the least-seen call-stacks will be evicted
+to make room for new entries.  */);
+  profiler_log_size = 10000;
+
+#ifdef PROFILER_CPU_SUPPORT
+  profiler_cpu_running = false;
+  cpu_log = Qnil;
+  staticpro (&cpu_log);
+  defsubr (&Sprofiler_cpu_start);
+  defsubr (&Sprofiler_cpu_stop);
+  defsubr (&Sprofiler_cpu_running_p);
+  defsubr (&Sprofiler_cpu_log);
+#endif
+  profiler_memory_running = false;
+  memory_log = Qnil;
+  staticpro (&memory_log);
+  defsubr (&Sprofiler_memory_start);
+  defsubr (&Sprofiler_memory_stop);
+  defsubr (&Sprofiler_memory_running_p);
+  defsubr (&Sprofiler_memory_log);
+}
diff --git a/src/xdisp.c b/src/xdisp.c
index 0f02997be22..fa6460d7be2 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -333,10 +333,10 @@ static Lisp_Object Qinhibit_eval_during_redisplay;
 static Lisp_Object Qbuffer_position, Qposition, Qobject;
 static Lisp_Object Qright_to_left, Qleft_to_right;
 
-/* Cursor shapes */
+/* Cursor shapes.  */
 Lisp_Object Qbar, Qhbar, Qbox, Qhollow;
 
-/* Pointer shapes */
+/* Pointer shapes.  */
 static Lisp_Object Qarrow, Qhand;
 Lisp_Object Qtext;
 
@@ -347,6 +347,7 @@ static Lisp_Object Qfontification_functions;
 
 static Lisp_Object Qwrap_prefix;
 static Lisp_Object Qline_prefix;
+static Lisp_Object Qautomatic_redisplay;
 
 /* Non-nil means don't actually do any redisplay.  */
 
@@ -12929,12 +12930,13 @@ redisplay_internal (void)
   struct frame *sf;
   int polling_stopped_here = 0;
   Lisp_Object old_frame = selected_frame;
+  struct backtrace backtrace;
 
   /* Non-zero means redisplay has to consider all windows on all
      frames.  Zero means, only selected_window is considered.  */
   int consider_all_windows_p;
 
-  /* Non-zero means redisplay has to redisplay the miniwindow */
+  /* Non-zero means redisplay has to redisplay the miniwindow.  */
   int update_miniwindow_p = 0;
 
   TRACE ((stderr, "redisplay_internal %d\n", redisplaying_p));
@@ -12971,6 +12973,14 @@ redisplay_internal (void)
   redisplaying_p = 1;
   specbind (Qinhibit_free_realized_faces, Qnil);
 
+  /* Record this function, so it appears on the profiler's backtraces.  */
+  backtrace.next = backtrace_list;
+  backtrace.function = &Qautomatic_redisplay;
+  backtrace.args = &Qautomatic_redisplay;
+  backtrace.nargs = 0;
+  backtrace.debug_on_exit = 0;
+  backtrace_list = &backtrace;
+
   {
     Lisp_Object tail, frame;
 
@@ -13668,6 +13678,7 @@ redisplay_internal (void)
 #endif /* HAVE_WINDOW_SYSTEM */
 
  end_of_redisplay:
+  backtrace_list = backtrace.next;
   unbind_to (count, Qnil);
   RESUME_POLLING;
 }
@@ -28683,6 +28694,7 @@ syms_of_xdisp (void)
   staticpro (&Vmessage_stack);
 
   DEFSYM (Qinhibit_redisplay, "inhibit-redisplay");
+  DEFSYM (Qautomatic_redisplay, "Automatic Redisplay");
 
   message_dolog_marker1 = Fmake_marker ();
   staticpro (&message_dolog_marker1);
@@ -29349,7 +29361,7 @@ init_xdisp (void)
    the following three functions in w32fns.c.  */
 #ifndef WINDOWSNT
 
-/* Platform-independent portion of hourglass implementation. */
+/* Platform-independent portion of hourglass implementation.  */
 
 /* Cancel a currently active hourglass timer, and start a new one.  */
 void