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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5