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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5