Mercurial > hg > xemacs-beta

comparison lisp/diagnose.el @ 4103:b4f4e0cc90f1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2007-08-07 23:08:47 by aidan] Eliminate byte compiler warnings, give nicer errors in the absence of packages.
author aidan
date Tue, 07 Aug 2007 23:09:22 +0000
parents 099851392ea7
children c8f90d61dcf3
comparison
equal deleted inserted replaced
4102:9856d458deda 4103:b4f4e0cc90f1
123 (incf grandtotal 123 (incf grandtotal
124 (show-foo-stats 'window (mapcan #'(lambda (fr) 124 (show-foo-stats 'window (mapcan #'(lambda (fr)
125 (window-list fr t)) 125 (window-list fr t))
126 (frame-list)) 126 (frame-list))
127 #'window-memory-usage)) 127 #'window-memory-usage))
128 (sort-numeric-fields -1 128 (when-fboundp #'sort-numeric-fields
129 (save-excursion 129 (sort-numeric-fields -1
130 (goto-char begin) 130 (save-excursion
131 (forward-line 3) 131 (goto-char begin)
132 (point)) 132 (forward-line 3)
133 (save-excursion 133 (point))
134 (forward-line -2) 134 (save-excursion
135 (point))) 135 (forward-line -2)
136 (point))))
136 (princ "\n") 137 (princ "\n")
137 (let ((total 0) 138 (let ((total 0)
138 (fmt "%-30s%10s\n")) 139 (fmt "%-30s%10s\n"))
139 (setq begin (point)) 140 (setq begin (point))
140 (princ (format fmt "object" "storage")) 141 (princ (format fmt "object" "storage"))
153 (princ (format fmt stat num)))) 154 (princ (format fmt stat num))))
154 (sixth (garbage-collect))) 155 (sixth (garbage-collect)))
155 (princ "\n") 156 (princ "\n")
156 (princ (format fmt "total" total)) 157 (princ (format fmt "total" total))
157 (incf grandtotal total)) 158 (incf grandtotal total))
158 (sort-numeric-fields -1 159 (when-fboundp #'sort-numeric-fields
159 (save-excursion 160 (sort-numeric-fields -1
160 (goto-char begin) 161 (save-excursion
161 (forward-line 2) 162 (goto-char begin)
162 (point)) 163 (forward-line 2)
163 (save-excursion 164 (point))
164 (forward-line -2) 165 (save-excursion
165 (point))) 166 (forward-line -2)
167 (point))))
166 168
167 (princ (format "\n\ngrand total: %s\n" grandtotal))) 169 (princ (format "\n\ngrand total: %s\n" grandtotal)))
168 grandtotal)))) 170 grandtotal))))
169 171
170 172
221 plist) 223 plist)
222 (princ "\n") 224 (princ "\n")
223 (princ (format fmt "total" 225 (princ (format fmt "total"
224 total-count total-use-overhead)) 226 total-count total-use-overhead))
225 (incf grandtotal total-use-overhead) 227 (incf grandtotal total-use-overhead)
226 (sort-numeric-fields -1 228 (when-fboundp #'sort-numeric-fields
227 (save-excursion 229 (sort-numeric-fields -1
228 (goto-char begin) 230 (save-excursion
229 (forward-line 2) 231 (goto-char begin)
230 (point)) 232 (forward-line 2)
231 (save-excursion 233 (point))
232 (forward-line -2) 234 (save-excursion
233 (point)))))) 235 (forward-line -2)
236 (point)))))))
234 (with-output-to-temp-buffer buffer 237 (with-output-to-temp-buffer buffer
235 (save-excursion 238 (save-excursion
236 (set-buffer buffer) 239 (set-buffer buffer)
237 (setq begin (point)) 240 (setq begin (point))
238 (princ "Allocated with lisp allocator:\n") 241 (princ "Allocated with lisp allocator:\n")
243 246
244 (defun show-mc-alloc-memory-usage () 247 (defun show-mc-alloc-memory-usage ()
245 "Show statistics about memory usage of the new allocator." 248 "Show statistics about memory usage of the new allocator."
246 (interactive) 249 (interactive)
247 (garbage-collect) 250 (garbage-collect)
248 (let* ((stats (mc-alloc-memory-usage)) 251 (if-fboundp #'mc-alloc-memory-usage
249 (page-size (first stats)) 252 (let* ((stats (mc-alloc-memory-usage))
250 (heap-sects (second stats)) 253 (page-size (first stats))
251 (used-plhs (third stats)) 254 (heap-sects (second stats))
252 (free-plhs (fourth stats)) 255 (used-plhs (third stats))
253 (globals (fifth stats)) 256 (free-plhs (fourth stats))
254 (mc-malloced-bytes (sixth stats))) 257 (globals (fifth stats))
255 (with-output-to-temp-buffer "*mc-alloc memory usage*" 258 (mc-malloced-bytes (sixth stats)))
256 (flet ((print-used-plhs (text plhs) 259 (with-output-to-temp-buffer "*mc-alloc memory usage*"
257 (let ((sum-n-pages 0) 260 (flet ((print-used-plhs (text plhs)
258 (sum-used-n-cells 0) 261 (let ((sum-n-pages 0)
259 (sum-used-space 0) 262 (sum-used-n-cells 0)
260 (sum-used-total 0) 263 (sum-used-space 0)
261 (sum-total-n-cells 0) 264 (sum-used-total 0)
262 (sum-total-space 0) 265 (sum-total-n-cells 0)
263 (sum-total-total 0) 266 (sum-total-space 0)
264 (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) 267 (sum-total-total 0)
265 (princ (format "%-14s|%-29s|%-29s|\n" 268 (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n"))
266 text 269 (princ (format "%-14s|%-29s|%-29s|\n"
267 " currently in use" 270 text
268 " total available")) 271 " currently in use"
269 (princ (format fmt "cell-sz" "#pages" 272 " total available"))
270 "#cells" "space" "total" "% " 273 (princ (format fmt "cell-sz" "#pages"
271 "#cells" "space" "total" "% " "% ")) 274 "#cells" "space" "total" "% "
272 (princ (make-string 79 ?-)) 275 "#cells" "space" "total" "% " "% "))
273 (princ "\n") 276 (princ (make-string 79 ?-))
274 (while plhs 277 (princ "\n")
275 (let* ((elem (car plhs)) 278 (while plhs
276 (cell-size (first elem)) 279 (let* ((elem (car plhs))
277 (n-pages (second elem)) 280 (cell-size (first elem))
278 (used-n-cells (third elem)) 281 (n-pages (second elem))
279 (used-space (fourth elem)) 282 (used-n-cells (third elem))
280 (used-total (if (zerop cell-size) 283 (used-space (fourth elem))
281 (sixth elem) 284 (used-total (if (zerop cell-size)
282 (* cell-size used-n-cells))) 285 (sixth elem)
283 (used-eff (floor (if (not (zerop used-total)) 286 (* cell-size used-n-cells)))
284 (* (/ (* used-space 1.0) 287 (used-eff (floor (if (not (zerop used-total))
285 (* used-total 1.0)) 288 (* (/ (* used-space 1.0)
286 100.0) 289 (* used-total 1.0))
287 0))) 290 100.0)
288 (total-n-cells (fifth elem)) 291 0)))
289 (total-space (if (zerop cell-size) 292 (total-n-cells (fifth elem))
290 used-space 293 (total-space (if (zerop cell-size)
291 (* cell-size total-n-cells))) 294 used-space
292 (total-total (sixth elem)) 295 (* cell-size total-n-cells)))
293 (total-eff (floor (if (not (zerop total-total)) 296 (total-total (sixth elem))
294 (* (/ (* total-space 1.0) 297 (total-eff (floor (if (not (zerop total-total))
295 (* total-total 1.0)) 298 (* (/ (* total-space 1.0)
296 100.0) 299 (* total-total 1.0))
297 0))) 300 100.0)
298 (eff (floor (if (not (zerop total-total)) 301 0)))
299 (* (/ (* used-space 1.0) 302 (eff (floor (if (not (zerop total-total))
300 (* total-total 1.0)) 303 (* (/ (* used-space 1.0)
301 100.0) 304 (* total-total 1.0))
302 0)))) 305 100.0)
303 (princ (format fmt 306 0))))
304 cell-size n-pages used-n-cells used-space 307 (princ (format fmt
305 used-total used-eff total-n-cells 308 cell-size n-pages used-n-cells used-space
306 total-space total-total total-eff eff)) 309 used-total used-eff total-n-cells
307 (incf sum-n-pages n-pages) 310 total-space total-total total-eff eff))
308 (incf sum-used-n-cells used-n-cells) 311 (incf sum-n-pages n-pages)
309 (incf sum-used-space used-space) 312 (incf sum-used-n-cells used-n-cells)
310 (incf sum-used-total used-total) 313 (incf sum-used-space used-space)
311 (incf sum-total-n-cells total-n-cells) 314 (incf sum-used-total used-total)
312 (incf sum-total-space total-space) 315 (incf sum-total-n-cells total-n-cells)
313 (incf sum-total-total total-total)) 316 (incf sum-total-space total-space)
314 (setq plhs (cdr plhs))) 317 (incf sum-total-total total-total))
315 (let ((avg-used-eff (floor (if (not (zerop sum-used-total)) 318 (setq plhs (cdr plhs)))
316 (* (/ (* sum-used-space 1.0) 319 (let ((avg-used-eff (floor (if (not (zerop sum-used-total))
317 (* sum-used-total 1.0)) 320 (* (/ (* sum-used-space 1.0)
318 100.0) 321 (* sum-used-total 1.0))
319 0))) 322 100.0)
320 (avg-total-eff (floor (if (not (zerop sum-total-total)) 323 0)))
321 (* (/ (* sum-total-space 1.0) 324 (avg-total-eff (floor (if (not (zerop sum-total-total))
322 (* sum-total-total 1.0)) 325 (* (/ (* sum-total-space 1.0)
323 100.0) 326 (* sum-total-total 1.0))
324 0))) 327 100.0)
325 (avg-eff (floor (if (not (zerop sum-total-total)) 328 0)))
326 (* (/ (* sum-used-space 1.0) 329 (avg-eff (floor (if (not (zerop sum-total-total))
327 (* sum-total-total 1.0)) 330 (* (/ (* sum-used-space 1.0)
328 100.0) 331 (* sum-total-total 1.0))
329 0)))) 332 100.0)
330 (princ (format fmt "sum " sum-n-pages sum-used-n-cells 333 0))))
331 sum-used-space sum-used-total avg-used-eff 334 (princ (format fmt "sum " sum-n-pages sum-used-n-cells
332 sum-total-n-cells sum-total-space 335 sum-used-space sum-used-total avg-used-eff
333 sum-total-total avg-total-eff avg-eff)) 336 sum-total-n-cells sum-total-space
334 (princ "\n")))) 337 sum-total-total avg-total-eff avg-eff))
335 338 (princ "\n"))))
336 339
337 (print-free-plhs (text plhs) 340
338 (let ((sum-n-pages 0) 341 (print-free-plhs (text plhs)
339 (sum-n-sects 0) 342 (let ((sum-n-pages 0)
340 (sum-space 0) 343 (sum-n-sects 0)
341 (sum-total 0) 344 (sum-space 0)
342 (fmt "%6s%10s |%7s%10s\n")) 345 (sum-total 0)
343 (princ (format "%s\n" text)) 346 (fmt "%6s%10s |%7s%10s\n"))
344 (princ (format fmt "#pages" "space" "#sects" "total")) 347 (princ (format "%s\n" text))
345 (princ (make-string 35 ?-)) 348 (princ (format fmt "#pages" "space" "#sects" "total"))
346 (princ "\n") 349 (princ (make-string 35 ?-))
347 (while plhs 350 (princ "\n")
348 (let* ((elem (car plhs)) 351 (while plhs
349 (n-pages (first elem)) 352 (let* ((elem (car plhs))
350 (n-sects (second elem)) 353 (n-pages (first elem))
351 (space (* n-pages page-size)) 354 (n-sects (second elem))
352 (total (* n-sects space))) 355 (space (* n-pages page-size))
353 (princ (format fmt n-pages space n-sects total)) 356 (total (* n-sects space)))
354 (incf sum-n-pages n-pages) 357 (princ (format fmt n-pages space n-sects total))
355 (incf sum-n-sects n-sects) 358 (incf sum-n-pages n-pages)
356 (incf sum-space space) 359 (incf sum-n-sects n-sects)
357 (incf sum-total total)) 360 (incf sum-space space)
358 (setq plhs (cdr plhs))) 361 (incf sum-total total))
359 (princ (make-string 35 ?=)) 362 (setq plhs (cdr plhs)))
360 (princ "\n") 363 (princ (make-string 35 ?=))
361 (princ (format fmt sum-n-pages sum-space 364 (princ "\n")
362 sum-n-sects sum-total)) 365 (princ (format fmt sum-n-pages sum-space
363 (princ "\n")))) 366 sum-n-sects sum-total))
364 367 (princ "\n"))))
365 (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size)) 368
369 (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size))
366 370
367 (print-used-plhs "USED HEAP" used-plhs) 371 (print-used-plhs "USED HEAP" used-plhs)
368 (princ "\n\n") 372 (princ "\n\n")
369 373
370 (print-free-plhs "FREE HEAP" free-plhs) 374 (print-free-plhs "FREE HEAP" free-plhs)
371 (princ "\n\n") 375 (princ "\n\n")
372 376
373 (let ((fmt "%-30s%10s\n")) 377 (let ((fmt "%-30s%10s\n"))
374 (princ (format fmt "heap sections" "")) 378 (princ (format fmt "heap sections" ""))
375 (princ (make-string 40 ?-)) 379 (princ (make-string 40 ?-))
376 (princ "\n") 380 (princ "\n")
377 (princ (format fmt "number of heap sects" 381 (princ (format fmt "number of heap sects"
378 (first heap-sects))) 382 (first heap-sects)))
379 (princ (format fmt "used size" (second heap-sects))) 383 (princ (format fmt "used size" (second heap-sects)))
380 (princ (make-string 40 ?-)) 384 (princ (make-string 40 ?-))
381 (princ "\n") 385 (princ "\n")
382 (princ (format fmt "real size" (third heap-sects))) 386 (princ (format fmt "real size" (third heap-sects)))
383 (princ (format fmt "global allocator structs" globals)) 387 (princ (format fmt "global allocator structs" globals))
384 (princ (make-string 40 ?-)) 388 (princ (make-string 40 ?-))
385 (princ "\n") 389 (princ "\n")
386 (princ (format fmt "real size + structs" 390 (princ (format fmt "real size + structs"
387 (+ (third heap-sects) globals))) 391 (+ (third heap-sects) globals)))
388 (princ "\n") 392 (princ "\n")
389 (princ (make-string 40 ?=)) 393 (princ (make-string 40 ?=))
390 (princ "\n") 394 (princ "\n")
391 (princ (format fmt "grand total" mc-malloced-bytes))) 395 (princ (format fmt "grand total" mc-malloced-bytes)))
392 396
393 (+ mc-malloced-bytes))))) 397 (+ mc-malloced-bytes))))
398 (message "mc-alloc not used in this XEmacs.")))
394 399
395 400
396 (defun show-gc-stats () 401 (defun show-gc-stats ()
397 "Show statistics about garbage collection cycles." 402 "Show statistics about garbage collection cycles."
398 (interactive) 403 (interactive)
399 (let ((buffer "*garbage collection statistics*") 404 (if-fboundp #'gc-stats
400 (plist (gc-stats)) 405 (let ((buffer "*garbage collection statistics*")
401 (fmt "%-9s %16s %12s %12s %12s %12s\n")) 406 (plist (gc-stats))
402 (flet ((plist-get-stat (category field) 407 (fmt "%-9s %16s %12s %12s %12s %12s\n"))
403 (let ((stat (plist-get plist (intern (concat category field))))) 408 (flet ((plist-get-stat (category field)
404 (if stat 409 (let ((stat (plist-get plist
405 (format "%.0f" stat) 410 (intern (concat category field)))))
406 "-"))) 411 (if stat
407 (show-stats (category) 412 (format "%.0f" stat)
408 (princ (format fmt category 413 "-")))
409 (plist-get-stat category "-total") 414 (show-stats (category)
410 (plist-get-stat category "-in-last-gc") 415 (princ (format fmt category
411 (plist-get-stat category "-in-this-gc") 416 (plist-get-stat category "-total")
412 (plist-get-stat category "-in-last-cycle") 417 (plist-get-stat category "-in-last-gc")
413 (plist-get-stat category "-in-this-cycle"))))) 418 (plist-get-stat category "-in-this-gc")
414 (with-output-to-temp-buffer buffer 419 (plist-get-stat category "-in-last-cycle")
415 (save-excursion 420 (plist-get-stat category "-in-this-cycle")))))
416 (set-buffer buffer) 421 (with-output-to-temp-buffer buffer
417 (princ (format "%s %g\n" "Current phase" (plist-get plist 'phase))) 422 (save-excursion
418 (princ (make-string 78 ?-)) 423 (set-buffer buffer)
419 (princ "\n") 424 (princ (format "%s %g\n" "Current phase"
420 (princ (format fmt "stat" "total" "last-gc" "this-gc" 425 (plist-get plist 'phase)))
421 "last-cycle" "this-cylce")) 426 (princ (make-string 78 ?-))
422 (princ (make-string 78 ?-)) 427 (princ "\n")
423 (princ "\n") 428 (princ (format fmt "stat" "total" "last-gc" "this-gc"
424 (show-stats "n-gc") 429 "last-cycle" "this-cylce"))
425 (show-stats "n-cycles") 430 (princ (make-string 78 ?-))
426 (show-stats "enqueued") 431 (princ "\n")
427 (show-stats "dequeued") 432 (show-stats "n-gc")
428 (show-stats "repushed") 433 (show-stats "n-cycles")
429 (show-stats "enqueued2") 434 (show-stats "enqueued")
430 (show-stats "dequeued2") 435 (show-stats "dequeued")
431 (show-stats "finalized") 436 (show-stats "repushed")
432 (show-stats "freed") 437 (show-stats "enqueued2")
433 (plist-get plist 'n-gc-total)))))) 438 (show-stats "dequeued2")
439 (show-stats "finalized")
440 (show-stats "freed")
441 (plist-get plist 'n-gc-total)))))
442 (error 'void-function "gc-stats not available.")))