/[cmucl]/src/code/room.lisp
ViewVC logotype

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (show annotations)
Tue Apr 13 13:21:52 2004 UTC (10 years ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2004-05, snapshot-2004-06, amd64-merge-start, release-19a-base, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a
Branch point for: release-19a-branch
Changes since 1.31: +2 -2 lines
Use (logandc2 x y) instead of (logand x (lognot y)).
1 ;;; -*- Mode: Lisp; Package: VM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/room.lisp,v 1.32 2004/04/13 13:21:52 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Heap grovelling memory usage stuff.
13 ;;;
14 (in-package "VM")
15 (use-package "SYSTEM")
16 (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
17 instance-usage find-holes print-allocated-objects
18 code-breakdown uninterned-symbol-count
19 list-allocated-objects))
20 (in-package "LISP")
21 (import '(
22 dynamic-0-space-start dynamic-1-space-start read-only-space-start
23 static-space-start current-dynamic-space-start
24 *static-space-free-pointer* *read-only-space-free-pointer*)
25 "VM")
26 (in-package "VM")
27
28
29 ;;;; Type format database.
30
31 (eval-when (compile load eval)
32 (defstruct (room-info (:make-load-form-fun :just-dump-it-normally))
33 ;;
34 ;; The name of this type.
35 (name nil :type symbol)
36 ;;
37 ;; Kind of type (how we determine length).
38 (kind (required-argument)
39 :type (member :lowtag :fixed :header :vector
40 :string :code :closure :instance))
41 ;;
42 ;; Length if fixed-length, shift amount for element size if :vector.
43 (length nil :type (or fixnum null))))
44
45 (eval-when (compile eval)
46
47 (defvar *meta-room-info* (make-array 256 :initial-element nil))
48
49 (dolist (obj *primitive-objects*)
50 (let ((header (primitive-object-header obj))
51 (lowtag (primitive-object-lowtag obj))
52 (name (primitive-object-name obj))
53 (variable (primitive-object-variable-length obj))
54 (size (primitive-object-size obj)))
55 (cond
56 ((not lowtag))
57 ((not header)
58 (let ((info (make-room-info :name name :kind :lowtag))
59 (lowtag (symbol-value lowtag)))
60 (declare (fixnum lowtag))
61 (dotimes (i 32)
62 (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
63 (variable)
64 (t
65 (setf (svref *meta-room-info* (symbol-value header))
66 (make-room-info :name name :kind :fixed :length size))))))
67
68 (dolist (code (list complex-string-type simple-array-type
69 complex-bit-vector-type complex-vector-type
70 complex-array-type))
71 (setf (svref *meta-room-info* code)
72 (make-room-info :name 'array-header :kind :header)))
73
74 (setf (svref *meta-room-info* bignum-type)
75 (make-room-info :name 'bignum :kind :header))
76
77 (setf (svref *meta-room-info* closure-header-type)
78 (make-room-info :name 'closure :kind :closure))
79
80 (dolist (stuff '((simple-bit-vector-type . -3)
81 (simple-vector-type . 2)
82 (simple-array-unsigned-byte-2-type . -2)
83 (simple-array-unsigned-byte-4-type . -1)
84 (simple-array-unsigned-byte-8-type . 0)
85 (simple-array-unsigned-byte-16-type . 1)
86 (simple-array-unsigned-byte-32-type . 2)
87 (simple-array-signed-byte-8-type . 0)
88 (simple-array-signed-byte-16-type . 1)
89 (simple-array-signed-byte-30-type . 2)
90 (simple-array-signed-byte-32-type . 2)
91 (simple-array-single-float-type . 2)
92 (simple-array-double-float-type . 3)
93 (simple-array-complex-single-float-type . 3)
94 (simple-array-complex-double-float-type . 4)))
95 (let ((name (car stuff))
96 (size (cdr stuff)))
97 (setf (svref *meta-room-info* (symbol-value name))
98 (make-room-info :name name :kind :vector :length size))))
99
100 (setf (svref *meta-room-info* simple-string-type)
101 (make-room-info :name 'simple-string-type :kind :string :length 0))
102
103 (setf (svref *meta-room-info* code-header-type)
104 (make-room-info :name 'code :kind :code))
105
106 (setf (svref *meta-room-info* instance-header-type)
107 (make-room-info :name 'instance :kind :instance))
108
109 ); eval-when (compile eval)
110
111 (defparameter *room-info* '#.*meta-room-info*)
112 (deftype spaces () '(member :static :dynamic :read-only))
113 ;; A type denoting the virtual address available to us.
114 (deftype memory-size () `(unsigned-byte #.vm:word-bits))
115
116 ;;;; MAP-ALLOCATED-OBJECTS:
117
118 (declaim (type fixnum *static-space-free-pointer*
119 *read-only-space-free-pointer* ))
120
121 (defun space-bounds (space)
122 (declare (type spaces space))
123 (ecase space
124 (:static
125 (values (int-sap (static-space-start))
126 (int-sap (* *static-space-free-pointer* word-bytes))))
127 (:read-only
128 (values (int-sap (read-only-space-start))
129 (int-sap (* *read-only-space-free-pointer* word-bytes))))
130 (:dynamic
131 (values (int-sap (current-dynamic-space-start))
132 (dynamic-space-free-pointer)))))
133
134 ;;; SPACE-BYTES -- Internal
135 ;;;
136 ;;; Return the total number of bytes used in Space.
137 ;;;
138 (defun space-bytes (space)
139 (multiple-value-bind (start end)
140 (space-bounds space)
141 (- (sap-int end) (sap-int start))))
142
143 ;;; ROUND-TO-DUALWORD -- Internal
144 ;;;
145 ;;; Round Size (in bytes) up to the next dualword (eight byte) boundry.
146 ;;;
147 (declaim (inline round-to-dualword))
148 (defun round-to-dualword (size)
149 (declare (type memory-size size))
150 (logandc2 (the memory-size (+ size lowtag-mask)) lowtag-mask))
151
152
153 ;;; VECTOR-TOTAL-SIZE -- Internal
154 ;;;
155 ;;; Return the total size of a vector in bytes, including any pad.
156 ;;;
157 (declaim (inline vector-total-size))
158 (defun vector-total-size (obj info)
159 (let ((shift (room-info-length info))
160 (len (+ (length (the (simple-array * (*)) obj))
161 (ecase (room-info-kind info)
162 (:vector 0)
163 (:string 1)))))
164 (declare (type (integer -3 3) shift))
165 (round-to-dualword
166 (+ (* vector-data-offset word-bytes)
167 (the memory-size
168 (if (minusp shift)
169 (ash (the memory-size
170 (+ len (the memory-size
171 (1- (the memory-size (ash 1 (- shift)))))))
172 shift)
173 (ash len shift)))))))
174
175
176 ;;; MAP-ALLOCATED-OBJECTS -- Interface
177 ;;;
178 ;;; Iterate over all the objects allocated in Space, calling Fun with the
179 ;;; object, the object's type code, and the objects total size in bytes,
180 ;;; including any header and padding.
181 ;;;
182 (declaim (maybe-inline map-allocated-objects))
183 (defun map-allocated-objects (fun space)
184 (declare (type function fun) (type spaces space))
185 (without-gcing
186 (multiple-value-bind (start end)
187 (space-bounds space)
188 (declare (type system-area-pointer start end))
189 (declare (optimize (speed 3) (safety 0)))
190 (let ((current start)
191 #+nil
192 (prev nil))
193 (loop
194 (let* ((header (sap-ref-32 current 0))
195 (header-type (logand header #xFF))
196 (info (svref *room-info* header-type)))
197 (cond
198 ((or (not info)
199 (eq (room-info-kind info) :lowtag))
200 (let ((size (* cons-size word-bytes)))
201 (funcall fun
202 (make-lisp-obj (logior (sap-int current)
203 list-pointer-type))
204 list-pointer-type
205 size)
206 (setq current (sap+ current size))))
207 ((eql header-type closure-header-type)
208 (let* ((obj (make-lisp-obj (logior (sap-int current)
209 function-pointer-type)))
210 (size (round-to-dualword
211 (* (the fixnum (1+ (get-closure-length obj)))
212 word-bytes))))
213 (funcall fun obj header-type size)
214 (setq current (sap+ current size))))
215 ((eq (room-info-kind info) :instance)
216 (let* ((obj (make-lisp-obj
217 (logior (sap-int current) instance-pointer-type)))
218 (size (round-to-dualword
219 (* (+ (%instance-length obj) 1) word-bytes))))
220 (declare (type memory-size size))
221 (funcall fun obj header-type size)
222 (assert (zerop (logand size lowtag-mask)))
223 #+nil
224 (when (> size 200000) (break "Implausible size, prev ~S" prev))
225 #+nil
226 (setq prev current)
227 (setq current (sap+ current size))))
228 (t
229 (let* ((obj (make-lisp-obj
230 (logior (sap-int current) other-pointer-type)))
231 (size (ecase (room-info-kind info)
232 (:fixed
233 (assert (or (eql (room-info-length info)
234 (1+ (get-header-data obj)))
235 (floatp obj)))
236 (round-to-dualword
237 (* (room-info-length info) word-bytes)))
238 ((:vector :string)
239 (vector-total-size obj info))
240 (:header
241 (round-to-dualword
242 (* (1+ (get-header-data obj)) word-bytes)))
243 (:code
244 (+ (the fixnum
245 (* (get-header-data obj) word-bytes))
246 (round-to-dualword
247 (* (the fixnum (%code-code-size obj))
248 word-bytes)))))))
249 (declare (type memory-size size))
250 (funcall fun obj header-type size)
251 (assert (zerop (logand size lowtag-mask)))
252 #+nil
253 (when (> size 200000)
254 (break "Implausible size, prev ~S" prev))
255 #+nil
256 (setq prev current)
257 (setq current (sap+ current size))))))
258 (unless (sap< current end)
259 (assert (sap= current end))
260 (return)))
261
262 #+nil
263 prev))))
264
265
266 ;;;; MEMORY-USAGE:
267
268 ;;; TYPE-BREAKDOWN -- Interface
269 ;;;
270 ;;; Return a list of 3-lists (bytes object type-name) for the objects
271 ;;; allocated in Space.
272 ;;;
273 (defun type-breakdown (space)
274 (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte 32)))
275 (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte 32))))
276 (map-allocated-objects
277 #'(lambda (obj type size)
278 (declare (type memory-size size) (optimize (speed 3) (safety 0)) (ignore obj))
279 (incf (aref sizes type) size)
280 (incf (aref counts type)))
281 space)
282
283 (let ((totals (make-hash-table :test #'eq)))
284 (dotimes (i 256)
285 (let ((total-count (aref counts i)))
286 (unless (zerop total-count)
287 (let* ((total-size (aref sizes i))
288 (name (room-info-name (aref *room-info* i)))
289 (found (gethash name totals)))
290 (cond (found
291 (incf (first found) total-size)
292 (incf (second found) total-count))
293 (t
294 (setf (gethash name totals)
295 (list total-size total-count name))))))))
296
297 (collect ((totals-list))
298 (maphash #'(lambda (k v)
299 (declare (ignore k))
300 (totals-list v))
301 totals)
302 (sort (totals-list) #'> :key #'first)))))
303
304
305 ;;; PRINT-SUMMARY -- Internal
306 ;;;
307 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
308 ;;; (space-name . totals-for-space), where totals-for-space is the list
309 ;;; returned by TYPE-BREAKDOWN.
310 ;;;
311 (defun print-summary (spaces totals)
312 (let ((summary (make-hash-table :test #'eq)))
313 (dolist (space-total totals)
314 (dolist (total (cdr space-total))
315 (push (cons (car space-total) total)
316 (gethash (third total) summary))))
317
318 (collect ((summary-totals))
319 (maphash #'(lambda (k v)
320 (declare (ignore k))
321 (let ((sum 0))
322 (declare (type memory-size sum))
323 (dolist (space-total v)
324 (incf sum (first (cdr space-total))))
325 (summary-totals (cons sum v))))
326 summary)
327
328 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
329 (let ((summary-total-bytes 0)
330 (summary-total-objects 0))
331 (declare (type memory-size summary-total-bytes summary-total-objects))
332 (dolist (space-totals
333 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
334 (let ((total-objects 0)
335 (total-bytes 0)
336 name)
337 (declare (fixnum total-objects)
338 (type memory-size total-bytes))
339 (collect ((spaces))
340 (dolist (space-total space-totals)
341 (let ((total (cdr space-total)))
342 (setq name (third total))
343 (incf total-bytes (first total))
344 (incf total-objects (second total))
345 (spaces (cons (car space-total) (first total)))))
346 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
347 name total-bytes total-objects)
348 (dolist (space (spaces))
349 (format t ", ~D% ~(~A~)"
350 (round (* (cdr space) 100) total-bytes)
351 (car space)))
352 (format t ".~%")
353 (incf summary-total-bytes total-bytes)
354 (incf summary-total-objects total-objects))))
355 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
356 summary-total-bytes summary-total-objects)))))
357
358
359 ;;; REPORT-SPACE-TOTAL -- Internal
360 ;;;
361 ;;; Report object usage for a single space.
362 ;;;
363 (defun report-space-total (space-total cutoff)
364 (declare (list space-total) (type (or single-float null) cutoff))
365 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
366 (let* ((types (cdr space-total))
367 (total-bytes (reduce #'+ (mapcar #'first types)))
368 (total-objects (reduce #'+ (mapcar #'second types)))
369 (cutoff-point (if cutoff
370 (truncate (* (float total-bytes) cutoff))
371 0))
372 (reported-bytes 0)
373 (reported-objects 0))
374 (declare (fixnum total-objects cutoff-point reported-objects)
375 (type memory-size total-bytes reported-bytes))
376 (loop for (bytes objects name) in types do
377 (when (<= bytes cutoff-point)
378 (format t " ~13:D bytes for ~9:D other object~2:*~P.~%"
379 (- total-bytes reported-bytes)
380 (- total-objects reported-objects))
381 (return))
382 (incf reported-bytes bytes)
383 (incf reported-objects objects)
384 (format t " ~13:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
385 bytes objects name))
386 (format t " ~13:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
387 total-bytes total-objects (car space-total))))
388
389
390 ;;; MEMORY-USAGE -- Public
391 ;;;
392 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
393 (print-summary t) cutoff)
394 "Print out information about the heap memory in use. :Print-Spaces is a list
395 of the spaces to print detailed information for. :Count-Spaces is a list of
396 the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
397 and :Read-Only.) If :Print-Summary is true, then summary information will be
398 printed. The defaults print only summary information for dynamic space.
399 If true, Cutoff is a fraction of the usage in a report below which types will
400 be combined as OTHER."
401 (declare (type (or single-float null) cutoff))
402 (let* ((spaces (if (eq count-spaces t)
403 '(:static :dynamic :read-only)
404 count-spaces))
405 (totals (mapcar #'(lambda (space)
406 (cons space (type-breakdown space)))
407 spaces)))
408
409 (dolist (space-total totals)
410 (when (or (eq print-spaces t)
411 (member (car space-total) print-spaces))
412 (report-space-total space-total cutoff)))
413
414 (when print-summary (print-summary spaces totals)))
415
416 (values))
417
418
419 ;;; COUNT-NO-OPS -- Public
420 ;;;
421 (defun count-no-ops (space)
422 "Print info about how much code and no-ops there are in Space."
423 (declare (type spaces space))
424 (let ((code-words 0)
425 (no-ops 0)
426 (total-bytes 0))
427 (declare (fixnum code-words no-ops)
428 (type unsigned-byte total-bytes))
429 (map-allocated-objects
430 #'(lambda (obj type size)
431 (declare (fixnum size) (optimize (safety 0)))
432 (when (eql type code-header-type)
433 (incf total-bytes size)
434 (let ((words (truly-the fixnum (%code-code-size obj)))
435 (sap (truly-the system-area-pointer
436 (%primitive code-instructions obj))))
437 (incf code-words words)
438 (dotimes (i words)
439 (when (zerop (sap-ref-32 sap (* i vm:word-bytes)))
440 (incf no-ops))))))
441 space)
442
443 (format t
444 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
445 total-bytes code-words no-ops
446 (round (* no-ops 100) code-words)))
447
448 (values))
449
450
451 ;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE -- Public
452 ;;;
453 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
454 (let ((descriptor-words 0)
455 (non-descriptor-headers 0)
456 (non-descriptor-bytes 0))
457 (declare (type unsigned-byte descriptor-words non-descriptor-headers
458 non-descriptor-bytes))
459 (dolist (space (or spaces '(:read-only :static :dynamic)))
460 (declare (inline map-allocated-objects))
461 (map-allocated-objects
462 #'(lambda (obj type size)
463 (declare (fixnum size) (optimize (safety 0)))
464 (case type
465 (#.code-header-type
466 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
467 (declare (type fixnum inst-words))
468 (incf non-descriptor-bytes (* inst-words word-bytes))
469 (incf descriptor-words
470 (- (truncate size word-bytes) inst-words))))
471 ((#.bignum-type
472 #.single-float-type
473 #.double-float-type
474 #.simple-string-type
475 #.simple-bit-vector-type
476 #.simple-array-unsigned-byte-2-type
477 #.simple-array-unsigned-byte-4-type
478 #.simple-array-unsigned-byte-8-type
479 #.simple-array-unsigned-byte-16-type
480 #.simple-array-unsigned-byte-32-type
481 #.simple-array-signed-byte-8-type
482 #.simple-array-signed-byte-16-type
483 #.simple-array-signed-byte-30-type
484 #.simple-array-signed-byte-32-type
485 #.simple-array-single-float-type
486 #.simple-array-double-float-type
487 #.simple-array-complex-single-float-type
488 #.simple-array-complex-double-float-type)
489 (incf non-descriptor-headers)
490 (incf non-descriptor-bytes (- size word-bytes)))
491 ((#.list-pointer-type
492 #.instance-pointer-type
493 #.ratio-type
494 #.complex-type
495 #.simple-array-type
496 #.simple-vector-type
497 #.complex-string-type
498 #.complex-bit-vector-type
499 #.complex-vector-type
500 #.complex-array-type
501 #.closure-header-type
502 #.funcallable-instance-header-type
503 #.value-cell-header-type
504 #.symbol-header-type
505 #.sap-type
506 #.weak-pointer-type
507 #.instance-header-type)
508 (incf descriptor-words (truncate size word-bytes)))
509 (t
510 (error "Bogus type: ~D" type))))
511 space))
512 (format t "~:D words allocated for descriptor objects.~%"
513 descriptor-words)
514 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
515 non-descriptor-bytes non-descriptor-headers)
516 (values)))
517
518
519 ;;; INSTANCE-USAGE -- Public
520 ;;;
521 (defun instance-usage (space &key (top-n 15))
522 (declare (type spaces space) (type (or fixnum null) top-n))
523 "Print a breakdown by instance type of all the instances allocated in
524 Space. If TOP-N is true, print only information for the the TOP-N types with
525 largest usage."
526 (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
527 (let ((totals (make-hash-table :test #'eq))
528 (total-objects 0)
529 (total-bytes 0))
530 (declare (fixnum total-objects)
531 (type memory-size total-bytes))
532 (map-allocated-objects
533 #'(lambda (obj type size)
534 (declare (type memory-size size) (optimize (speed 3) (safety 0)))
535 (when (eql type instance-header-type)
536 (incf total-objects)
537 (incf total-bytes size)
538 (let* ((class (layout-class (%instance-ref obj 0)))
539 (found (gethash class totals)))
540 (cond (found
541 (incf (the fixnum (car found)))
542 (incf (the fixnum (cdr found)) size))
543 (t
544 (setf (gethash class totals) (cons 1 size)))))))
545 space)
546
547 (collect ((totals-list))
548 (maphash #'(lambda (class what)
549 (totals-list (cons (prin1-to-string
550 (class-proper-name class))
551 what)))
552 totals)
553 (let ((sorted (sort (totals-list) #'> :key #'cddr))
554 (printed-bytes 0)
555 (printed-objects 0))
556 (declare (type memory-size printed-bytes printed-objects))
557 (dolist (what (if top-n
558 (subseq sorted 0 (min (length sorted) top-n))
559 sorted))
560 (let ((bytes (cddr what))
561 (objects (cadr what)))
562 (incf printed-bytes bytes)
563 (incf printed-objects objects)
564 (format t " ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)
565 bytes objects)))
566
567 (let ((residual-objects (- total-objects printed-objects))
568 (residual-bytes (- total-bytes printed-bytes)))
569 (unless (zerop residual-objects)
570 (format t " Other types: ~:D bytes, ~D: object~:P.~%"
571 residual-bytes residual-objects))))
572
573 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
574 space total-bytes total-objects)))
575
576 (values))
577
578
579 ;;; FIND-HOLES -- Public
580 ;;;
581 (defun find-holes (&rest spaces)
582 (dolist (space (or spaces '(:read-only :static :dynamic)))
583 (format t "In ~A space:~%" space)
584 (let ((start-addr nil)
585 (total-bytes 0))
586 (declare (type (or null (unsigned-byte 32)) start-addr)
587 (type (unsigned-byte 32) total-bytes))
588 (map-allocated-objects
589 #'(lambda (object typecode bytes)
590 (declare (ignore typecode)
591 (type (unsigned-byte 32) bytes))
592 (if (and (consp object)
593 (eql (car object) 0)
594 (eql (cdr object) 0))
595 (if start-addr
596 (incf total-bytes bytes)
597 (setf start-addr (di::get-lisp-obj-address object)
598 total-bytes bytes))
599 (when start-addr
600 (format t "~D bytes at #x~X~%" total-bytes start-addr)
601 (setf start-addr nil))))
602 space)
603 (when start-addr
604 (format t "~D bytes at #x~X~%" total-bytes start-addr))))
605 (values))
606
607
608 ;;; Print allocated objects:
609
610 (defun print-allocated-objects (space &key (percent 0) (pages 5)
611 type larger smaller count
612 (stream *standard-output*))
613 (declare (type (integer 0 99) percent) (type c::index pages)
614 (type stream stream) (type spaces space)
615 (type (or c::index null) type larger smaller count))
616 (multiple-value-bind (start-sap end-sap)
617 (space-bounds space)
618 (let* ((space-start (sap-int start-sap))
619 (space-end (sap-int end-sap))
620 (space-size (- space-end space-start))
621 (pagesize (system:get-page-size))
622 (start (+ space-start (round (* space-size percent) 100)))
623 (printed-conses (make-hash-table :test #'eq))
624 (pages-so-far 0)
625 (count-so-far 0)
626 (last-page 0))
627 (declare (type (unsigned-byte 32) last-page start)
628 (fixnum pages-so-far count-so-far pagesize))
629 (labels ((note-conses (x)
630 (unless (or (atom x) (gethash x printed-conses))
631 (setf (gethash x printed-conses) t)
632 (note-conses (car x))
633 (note-conses (cdr x)))))
634 (map-allocated-objects
635 #'(lambda (obj obj-type size)
636 (declare (optimize (safety 0)))
637 (let ((addr (get-lisp-obj-address obj)))
638 (when (>= addr start)
639 (when (if count
640 (> count-so-far count)
641 (> pages-so-far pages))
642 (return-from print-allocated-objects (values)))
643
644 (unless count
645 (let ((this-page (* (the (values (unsigned-byte 32) t)
646 (truncate addr pagesize))
647 pagesize)))
648 (declare (type (unsigned-byte 32) this-page))
649 (when (/= this-page last-page)
650 (when (< pages-so-far pages)
651 (format stream "~2&**** Page ~D, address ~X:~%"
652 pages-so-far addr))
653 (setq last-page this-page)
654 (incf pages-so-far))))
655
656 (when (and (or (not type) (eql obj-type type))
657 (or (not smaller) (<= size smaller))
658 (or (not larger) (>= size larger)))
659 (incf count-so-far)
660 (case type
661 (#.code-header-type
662 (let ((dinfo (%code-debug-info obj)))
663 (format stream "~&Code object: ~S~%"
664 (if dinfo
665 (c::compiled-debug-info-name dinfo)
666 "No debug info."))))
667 (#.symbol-header-type
668 (format stream "~&~S~%" obj))
669 (#.list-pointer-type
670 (unless (gethash obj printed-conses)
671 (note-conses obj)
672 (let ((*print-circle* t)
673 (*print-level* 5)
674 (*print-length* 10))
675 (format stream "~&~S~%" obj))))
676 (t
677 (fresh-line stream)
678 (let ((str (write-to-string obj :level 5 :length 10
679 :pretty nil)))
680 (unless (eql type instance-header-type)
681 (format stream "~S: " (type-of obj)))
682 (format stream "~A~%"
683 (subseq str 0 (min (length str) 60))))))))))
684 space))))
685 (values))
686
687
688 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
689
690 (defvar *ignore-after* nil)
691
692 (defun maybe-cons (space x stuff)
693 (if (or (not (eq space :dynamic))
694 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
695 (cons x stuff)
696 stuff))
697
698 (defun list-allocated-objects (space &key type larger smaller count
699 test)
700 (declare (type spaces space)
701 (type (or c::index null) larger smaller type count)
702 (type (or function null) test)
703 (inline map-allocated-objects))
704 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
705 (collect ((counted 0 1+))
706 (let ((res ()))
707 (map-allocated-objects
708 #'(lambda (obj obj-type size)
709 (declare (optimize (safety 0)))
710 (when (and (or (not type) (eql obj-type type))
711 (or (not smaller) (<= size smaller))
712 (or (not larger) (>= size larger))
713 (or (not test) (funcall test obj)))
714 (setq res (maybe-cons space obj res))
715 (when (and count (>= (counted) count))
716 (return-from list-allocated-objects res))))
717 space)
718 res)))
719
720 (defun list-referencing-objects (space object)
721 (declare (type spaces space) (inline map-allocated-objects))
722 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
723 (let ((res ()))
724 (flet ((res (x)
725 (setq res (maybe-cons space x res))))
726 (map-allocated-objects
727 #'(lambda (obj obj-type size)
728 (declare (optimize (safety 0)) (ignore obj-type size))
729 (typecase obj
730 (cons
731 (when (or (eq (car obj) object) (eq (cdr obj) object))
732 (res obj)))
733 (instance
734 (dotimes (i (%instance-length obj))
735 (when (eq (%instance-ref obj i) object)
736 (res obj)
737 (return))))
738 (simple-vector
739 (dotimes (i (length obj))
740 (when (eq (svref obj i) object)
741 (res obj)
742 (return))))
743 (symbol
744 (when (or (eq (symbol-name obj) object)
745 (eq (symbol-package obj) object)
746 (eq (symbol-plist obj) object)
747 (eq (symbol-value obj) object))
748 (res obj)))))
749 space))
750 res))
751
752
753 ;;;; Misc:
754
755 (defun uninterned-symbol-count (space)
756 (declare (type spaces space))
757 (let ((total 0)
758 (uninterned 0))
759 (map-allocated-objects
760 #'(lambda (obj type size)
761 (declare (ignore type size))
762 (when (symbolp obj)
763 (incf total)
764 (unless (symbol-package obj)
765 (incf uninterned))))
766 space)
767 (values uninterned (float (/ uninterned total)))))
768
769
770 (defun code-breakdown (space &key (how :package))
771 (declare (type spaces space) (type (member :file :package) how))
772 (let ((packages (make-hash-table :test #'equal)))
773 (map-allocated-objects
774 #'(lambda (obj type size)
775 (when (eql type code-header-type)
776 (let* ((dinfo (let ((x (%code-debug-info obj)))
777 (when (typep x 'c::debug-info) x)))
778 (package (if (typep dinfo 'c::compiled-debug-info)
779 (c::compiled-debug-info-package dinfo)
780 "UNKNOWN"))
781 (pkg-info (or (gethash package packages)
782 (setf (gethash package packages)
783 (make-hash-table :test #'equal))))
784 (file
785 (if dinfo
786 (let ((src (c::debug-info-source dinfo)))
787 (cond (src
788 (let ((source
789 (first
790 (c::debug-info-source
791 dinfo))))
792 (if (eq (c::debug-source-from source)
793 :file)
794 (c::debug-source-name source)
795 "FROM LISP")))
796 (t
797 (warn "No source for ~S" obj)
798 "NO SOURCE")))
799 "UNKNOWN"))
800 (file-info (or (gethash file pkg-info)
801 (setf (gethash file pkg-info)
802 (cons 0 0)))))
803 (incf (car file-info))
804 (incf (cdr file-info) size))))
805 space)
806
807 (let ((res ()))
808 (do-hash (pkg pkg-info packages)
809 (let ((pkg-res ())
810 (pkg-count 0)
811 (pkg-size 0))
812 (do-hash (file file-info pkg-info)
813 (incf pkg-count (car file-info))
814 (incf pkg-size (cdr file-info))
815 (push (list file file-info) pkg-res))
816 (push (cons pkg-count pkg-size) pkg-res)
817 (push pkg pkg-res)
818 (push pkg-res res)))
819
820 (loop for (pkg (pkg-count . pkg-size) . files) in
821 (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
822 (format t "~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"
823 pkg pkg-size pkg-count)
824 (when (eq how :file)
825 (loop for (file (file-count . file-size)) in
826 (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
827 (format t "~30@A: ~9:D bytes, ~9:D object~:P.~%"
828 (file-namestring file) file-size file-count))))))
829
830 (values))
831
832
833 ;;;; Histogram interface. Uses Scott's Hist package.
834 #+nil
835 (defun memory-histogram (space &key (low 4) (high 20)
836 (bucket-size 1)
837 (function
838 #'(lambda (obj type size)
839 (declare (ignore obj type) (fixnum size))
840 (integer-length (1- size))))
841 (type nil))
842 (let ((function (if (eval:interpreted-function-p function)
843 (compile nil function)
844 function)))
845 (hist:hist (low high bucket-size)
846 (map-allocated-objects
847 #'(lambda (obj this-type size)
848 (when (or (not type) (eql this-type type))
849 (hist:hist-record (funcall function obj type size))))
850 space)))
851 (values))
852
853 ;;; Return the number of fbound constants in a code object.
854 ;;;
855 (defun code-object-calls (obj)
856 (loop for i from code-constants-offset below (get-header-data obj)
857 count (find-code-object (code-header-ref obj i))))
858
859 ;;; Return the number of calls in Obj to functions with <= N calls. Calls is
860 ;;; an eq hashtable translating code objects to the number of references.
861 ;;;
862 (defun code-object-leaf-calls (obj n calls)
863 (loop for i from code-constants-offset below (get-header-data obj)
864 count (let ((code (find-code-object (code-header-ref obj i))))
865 (and code (<= (gethash code calls 0) n)))))
866
867 #+nil
868 (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
869 (function #'identity))
870 "Given a hashtable, print a histogram of the contents. Function should give
871 the value to plot when applied to the hashtable values."
872 (let ((function (if (eval:interpreted-function-p function)
873 (compile nil function)
874 function)))
875 (hist:hist (low high bucket-size)
876 (loop for count being each hash-value in table do
877 (hist:hist-record (funcall function count))))))
878
879 (defun report-top-n (table &key (top-n 20) (function #'identity))
880 "Report the Top-N entries in the hashtable Table, when sorted by Function
881 applied to the hash value. If Top-N is NIL, report all entries."
882 (let ((function (if (eval:interpreted-function-p function)
883 (compile nil function)
884 function)))
885 (collect ((totals-list)
886 (total-val 0 +))
887 (maphash #'(lambda (name what)
888 (let ((val (funcall function what)))
889 (totals-list (cons name val))
890 (total-val val)))
891 table)
892 (let ((sorted (sort (totals-list) #'> :key #'cdr))
893 (printed 0))
894 (declare (fixnum printed))
895 (dolist (what (if top-n
896 (subseq sorted 0 (min (length sorted) top-n))
897 sorted))
898 (let ((val (cdr what)))
899 (incf printed val)
900 (format t "~8:D: ~S~%" val (car what))))
901
902 (let ((residual (- (total-val) printed)))
903 (unless (zerop residual)
904 (format t "~8:D: Other~%" residual))))
905
906 (format t "~8:D: Total~%" (total-val))))
907 (values))
908
909
910 ;;; Given any Lisp object, return the associated code object, or NIL.
911 ;;;
912 (defun find-code-object (const)
913 (flet ((frob (def)
914 (function-code-header
915 (ecase (get-type def)
916 ((#.closure-header-type
917 #.funcallable-instance-header-type)
918 (%closure-function def))
919 (#.function-header-type
920 def)))))
921 (typecase const
922 (function (frob const))
923 (symbol
924 (if (fboundp const)
925 (frob (symbol-function const))
926 nil))
927 (t nil))))
928
929
930 (defun find-caller-counts (space)
931 "Return a hashtable mapping each function in for which a call appears in
932 Space to the number of times such a call appears."
933 (let ((counts (make-hash-table :test #'eq)))
934 (map-allocated-objects
935 #'(lambda (obj type size)
936 (declare (ignore size))
937 (when (eql type code-header-type)
938 (loop for i from code-constants-offset below (get-header-data obj)
939 do (let ((code (find-code-object (code-header-ref obj i))))
940 (when code
941 (incf (gethash code counts 0)))))))
942 space)
943 counts))
944
945 (defun find-high-callers (space &key (above 10) table (threshold 2))
946 "Return a hashtable translating code objects to function constant counts for
947 all code objects in Space with more than Above function constants."
948 (let ((counts (make-hash-table :test #'eq)))
949 (map-allocated-objects
950 #'(lambda (obj type size)
951 (declare (ignore size))
952 (when (eql type code-header-type)
953 (let ((count (if table
954 (code-object-leaf-calls obj threshold table)
955 (code-object-calls obj))))
956 (when (> count above)
957 (setf (gethash obj counts) count)))))
958 space)
959 counts))

  ViewVC Help
Powered by ViewVC 1.1.5