Mercurial > hg > xemacs-beta

comparison lisp/prim/profile.el @ 203:850242ba4a81 r20-3b28

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b28
author cvs
date Mon, 13 Aug 2007 10:02:21 +0200
parents eb5470882647
children e45d5e7c476e
comparison
equal deleted inserted replaced
202:61eefc8fc970 203:850242ba4a81
58 ;; followed by `M-x profile-key-sequence RET SPC'. 58 ;; followed by `M-x profile-key-sequence RET SPC'.
59 59
60 60
61 ;;; Code: 61 ;;; Code:
62 62
63 (defun profile-align (form width)
64 ;; Bletch! this is what (format "%-*s" width form) should do.
65 (let ((printed-form (format "%s" form)))
66 (concat printed-form
67 (make-string (max 0 (- width (length printed-form))) ?\ ))))
68
63 ;;;###autoload 69 ;;;###autoload
64 (defun profiling-results (&optional info stream) 70 (defun profile-results (&optional info stream)
65 "Print profiling info INFO to STREAM in a pretty format. 71 "Print profiling info INFO to STREAM in a pretty format.
66 If INFO is omitted, the current profiling info is retrieved using 72 If INFO is omitted, the current profiling info is retrieved using
67 `get-profiling-info'. 73 `get-profiling-info'.
68 If STREAM is omitted, either a *Profiling Results* buffer or standard 74 If STREAM is omitted, either a *Profiling Results* buffer or standard
69 output are used, depending on whether the function was called 75 output are used, depending on whether the function was called
74 (get-profiling-info))) 80 (get-profiling-info)))
75 (when (and (not stream) 81 (when (and (not stream)
76 (interactive-p)) 82 (interactive-p))
77 (pop-to-buffer (get-buffer-create "*Profiling Results*")) 83 (pop-to-buffer (get-buffer-create "*Profiling Results*"))
78 (erase-buffer)) 84 (erase-buffer))
79 (let* ((standard-output (or stream (if (interactive-p) 85 (let ((standard-output (or stream (if (interactive-p)
80 (current-buffer) 86 (current-buffer)
81 standard-output))) 87 standard-output)))
82 (maxfunlen (max (length "Function Name") 88 ;; Calculate the longest function
83 (apply 'max (mapcar (lambda (sym) 89 (maxfunlen (apply #'max
84 (length (symbol-name 90 (length "Function Name")
85 (car sym)))) 91 (mapcar (lambda (el)
86 info)))) 92 ;; Functions longer than 40
87 (formatstr (format "%%-%ds" maxfunlen))) 93 ;; characters don't qualify
88 (setq info (nreverse (sort info #'cdr-less-than-cdr))) 94 (let ((l (length (format "%s" (car el)))))
89 (princ (format (concat formatstr " Ticks %%/Total\n") 95 (if (< l 40)
90 "Function Name")) 96 l 0)))
97 info))))
98 (princ (format "%s Ticks %%/Total\n"
99 (profile-align "Function Name" maxfunlen)))
91 (princ (make-string maxfunlen ?=)) 100 (princ (make-string maxfunlen ?=))
92 (princ " ===== =======\n") 101 (princ " ===== =======\n")
93 (let ((sum 0.0)) 102 (let ((sum (float (apply #'+ (mapcar #'cdr info)))))
94 (dolist (info2 info) 103 (dolist (entry (nreverse (sort info #'cdr-less-than-cdr)))
95 (incf sum (cdr info2))) 104 (princ (format "%s %-5d %-6.3f\n"
96 (while info 105 (profile-align (car entry) maxfunlen)
97 (let ((f (caar info))) 106 (cdr entry) (* 100 (/ (cdr entry) sum)))))
98 (princ (format (concat formatstr " %-5d %-6.3f\n")
99 f (cdar info) (* 100 (/ (cdar info) sum)))))
100 (pop info))
101 (princ (make-string maxfunlen ?-)) 107 (princ (make-string maxfunlen ?-))
102 (princ "--------------------\n") 108 (princ "--------------------\n")
103 (princ (format (concat formatstr " %-5d %-6.2f\n") 109 (princ (format "%s %-5d %-6.2f\n"
104 "Total" sum 100.0)) 110 (profile-align "Total" maxfunlen) sum 100.0))
105 (princ (format "\n\nOne tick = %g ms\n" 111 (princ (format "\n\nOne tick = %g ms\n"
106 (/ default-profiling-interval 1000.0))))) 112 (/ default-profiling-interval 1000.0)))))
107 (when (and (not stream) 113 (when (and (not stream)
108 (interactive-p)) 114 (interactive-p))
109 (goto-char (point-min)))) 115 (goto-char (point-min))))
118 Profiling state here means that if profiling was not in effect when 124 Profiling state here means that if profiling was not in effect when
119 PROFILE was called, it will be turned off after FORMS are evaluated. 125 PROFILE was called, it will be turned off after FORMS are evaluated.
120 Otherwise, profiling will be left running. 126 Otherwise, profiling will be left running.
121 127
122 Returns the profiling info, printable by `profiling-results'." 128 Returns the profiling info, printable by `profiling-results'."
123 `(progn 129 `(let ((was-profiling (profiling-active-p)))
124 (if (profiling-active-p) 130 (unwind-protect
125 (progn 131 (progn
132 (start-profiling)
126 ,@forms) 133 ,@forms)
127 (unwind-protect 134 (unless was-profiling
128 (progn
129 (start-profiling)
130 ,@forms)
131 (stop-profiling))) 135 (stop-profiling)))
132 (get-profiling-info))) 136 (get-profiling-info)))
133 137
134 (put 'profile 'lisp-indent-function 0) 138 (put 'profile 'lisp-indent-function 0)
135 139