1 ;;;; heap-grovelling memory usage stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
17 ;;;; type format database
19 (eval-when (:compile-toplevel :load-toplevel :execute)
20 (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
21 ;; The name of this type.
22 (name nil :type symbol)
23 ;; Kind of type (how we determine length).
24 (kind (required-argument)
25 :type (member :lowtag :fixed :header :vector
26 :string :code :closure :instance))
27 ;; Length if fixed-length, shift amount for element size if :vector.
28 (length nil :type (or fixnum null))))
30 (eval-when (:compile-toplevel :execute)
32 (defvar *meta-room-info* (make-array 256 :initial-element nil))
34 (dolist (obj *primitive-objects*)
35 (let ((header (primitive-object-header obj))
36 (lowtag (primitive-object-lowtag obj))
37 (name (primitive-object-name obj))
38 (variable (primitive-object-variable-length obj))
39 (size (primitive-object-size obj)))
43 (let ((info (make-room-info :name name
45 (lowtag (symbol-value lowtag)))
46 (declare (fixnum lowtag))
48 (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
51 (setf (svref *meta-room-info* (symbol-value header))
52 (make-room-info :name name
56 (dolist (code (list complex-string-type simple-array-type
57 complex-bit-vector-type complex-vector-type
59 (setf (svref *meta-room-info* code)
60 (make-room-info :name 'array-header
63 (setf (svref *meta-room-info* bignum-type)
64 (make-room-info :name 'bignum
67 (setf (svref *meta-room-info* closure-header-type)
68 (make-room-info :name 'closure
71 (dolist (stuff '((simple-bit-vector-type . -3)
72 (simple-vector-type . 2)
73 (simple-array-unsigned-byte-2-type . -2)
74 (simple-array-unsigned-byte-4-type . -1)
75 (simple-array-unsigned-byte-8-type . 0)
76 (simple-array-unsigned-byte-16-type . 1)
77 (simple-array-unsigned-byte-32-type . 2)
78 (simple-array-signed-byte-8-type . 0)
79 (simple-array-signed-byte-16-type . 1)
80 (simple-array-signed-byte-30-type . 2)
81 (simple-array-signed-byte-32-type . 2)
82 (simple-array-single-float-type . 2)
83 (simple-array-double-float-type . 3)
84 (simple-array-complex-single-float-type . 3)
85 (simple-array-complex-double-float-type . 4)))
86 (let ((name (car stuff))
88 (setf (svref *meta-room-info* (symbol-value name))
89 (make-room-info :name name
93 (setf (svref *meta-room-info* simple-string-type)
94 (make-room-info :name 'simple-string-type
98 (setf (svref *meta-room-info* code-header-type)
99 (make-room-info :name 'code
102 (setf (svref *meta-room-info* instance-header-type)
103 (make-room-info :name 'instance
106 ); eval-when (compile eval)
108 (defparameter *room-info* '#.*meta-room-info*)
109 (deftype spaces () '(member :static :dynamic :read-only))
111 ;;;; MAP-ALLOCATED-OBJECTS
113 ;;; Since they're represented as counts of words, we should never
114 ;;; need bignums to represent these:
115 (declaim (type fixnum
116 *static-space-free-pointer*
117 *read-only-space-free-pointer*))
119 (defun space-bounds (space)
120 (declare (type spaces space))
123 (values (int-sap static-space-start)
124 (int-sap (* *static-space-free-pointer* word-bytes))))
126 (values (int-sap read-only-space-start)
127 (int-sap (* *read-only-space-free-pointer* word-bytes))))
129 (values (int-sap dynamic-space-start)
130 (dynamic-space-free-pointer)))))
132 ;;; Return the total number of bytes used in SPACE.
133 (defun space-bytes (space)
134 (multiple-value-bind (start end) (space-bounds space)
135 (- (sap-int end) (sap-int start))))
137 ;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
138 #!-sb-fluid (declaim (inline round-to-dualword))
139 (defun round-to-dualword (size)
140 (declare (fixnum size))
141 (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
143 ;;; Return the total size of a vector in bytes, including any pad.
144 #!-sb-fluid (declaim (inline vector-total-size))
145 (defun vector-total-size (obj info)
146 (let ((shift (room-info-length info))
147 (len (+ (length (the (simple-array * (*)) obj))
148 (ecase (room-info-kind info)
151 (declare (type (integer -3 3) shift))
153 (+ (* vector-data-offset word-bytes)
158 (1- (the fixnum (ash 1 (- shift)))))))
160 (ash len shift)))))))
162 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
163 ;;; the object, the object's type code, and the objects total size in
164 ;;; bytes, including any header and padding.
165 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
166 (defun map-allocated-objects (fun space)
167 (declare (type function fun) (type spaces space))
169 (multiple-value-bind (start end) (space-bounds space)
170 (declare (type system-area-pointer start end))
171 (declare (optimize (speed 3) (safety 0)))
172 (let ((current start)
176 (let* ((header (sap-ref-32 current 0))
177 (header-type (logand header #xFF))
178 (info (svref *room-info* header-type)))
181 (eq (room-info-kind info) :lowtag))
182 (let ((size (* cons-size word-bytes)))
184 (make-lisp-obj (logior (sap-int current)
188 (setq current (sap+ current size))))
189 ((eql header-type closure-header-type)
190 (let* ((obj (make-lisp-obj (logior (sap-int current)
191 function-pointer-type)))
192 (size (round-to-dualword
193 (* (the fixnum (1+ (get-closure-length obj)))
195 (funcall fun obj header-type size)
196 (setq current (sap+ current size))))
197 ((eq (room-info-kind info) :instance)
198 (let* ((obj (make-lisp-obj
199 (logior (sap-int current) instance-pointer-type)))
200 (size (round-to-dualword
201 (* (+ (%instance-length obj) 1) word-bytes))))
202 (declare (fixnum size))
203 (funcall fun obj header-type size)
204 (assert (zerop (logand size lowtag-mask)))
206 (when (> size 200000) (break "implausible size, prev ~S" prev))
209 (setq current (sap+ current size))))
211 (let* ((obj (make-lisp-obj
212 (logior (sap-int current) other-pointer-type)))
213 (size (ecase (room-info-kind info)
215 (assert (or (eql (room-info-length info)
216 (1+ (get-header-data obj)))
219 (* (room-info-length info) word-bytes)))
221 (vector-total-size obj info))
224 (* (1+ (get-header-data obj)) word-bytes)))
227 (* (get-header-data obj) word-bytes))
229 (* (the fixnum (%code-code-size obj))
231 (declare (fixnum size))
232 (funcall fun obj header-type size)
233 (assert (zerop (logand size lowtag-mask)))
235 (when (> size 200000)
236 (break "Implausible size, prev ~S" prev))
239 (setq current (sap+ current size))))))
240 (unless (sap< current end)
241 (assert (sap= current end))
249 ;;; Return a list of 3-lists (bytes object type-name) for the objects
250 ;;; allocated in Space.
251 (defun type-breakdown (space)
252 (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
253 (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
254 (map-allocated-objects
255 #'(lambda (obj type size)
256 (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
257 (incf (aref sizes type) size)
258 (incf (aref counts type)))
261 (let ((totals (make-hash-table :test 'eq)))
263 (let ((total-count (aref counts i)))
264 (unless (zerop total-count)
265 (let* ((total-size (aref sizes i))
266 (name (room-info-name (aref *room-info* i)))
267 (found (gethash name totals)))
269 (incf (first found) total-size)
270 (incf (second found) total-count))
272 (setf (gethash name totals)
273 (list total-size total-count name))))))))
275 (collect ((totals-list))
276 (maphash #'(lambda (k v)
280 (sort (totals-list) #'> :key #'first)))))
282 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
283 ;;; (space-name . totals-for-space), where totals-for-space is the list
284 ;;; returned by TYPE-BREAKDOWN.
285 (defun print-summary (spaces totals)
286 (let ((summary (make-hash-table :test 'eq)))
287 (dolist (space-total totals)
288 (dolist (total (cdr space-total))
289 (push (cons (car space-total) total)
290 (gethash (third total) summary))))
292 (collect ((summary-totals))
293 (maphash #'(lambda (k v)
296 (declare (fixnum sum))
297 (dolist (space-total v)
298 (incf sum (first (cdr space-total))))
299 (summary-totals (cons sum v))))
302 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
303 (let ((summary-total-bytes 0)
304 (summary-total-objects 0))
305 (declare (fixnum summary-total-bytes summary-total-objects))
306 (dolist (space-totals
307 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
308 (let ((total-objects 0)
311 (declare (fixnum total-objects total-bytes))
313 (dolist (space-total space-totals)
314 (let ((total (cdr space-total)))
315 (setq name (third total))
316 (incf total-bytes (first total))
317 (incf total-objects (second total))
318 (spaces (cons (car space-total) (first total)))))
319 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
320 name total-bytes total-objects)
321 (dolist (space (spaces))
322 (format t ", ~D% ~(~A~)"
323 (round (* (cdr space) 100) total-bytes)
326 (incf summary-total-bytes total-bytes)
327 (incf summary-total-objects total-objects))))
328 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
329 summary-total-bytes summary-total-objects)))))
331 ;;; Report object usage for a single space.
332 (defun report-space-total (space-total cutoff)
333 (declare (list space-total) (type (or single-float null) cutoff))
334 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
335 (let* ((types (cdr space-total))
336 (total-bytes (reduce #'+ (mapcar #'first types)))
337 (total-objects (reduce #'+ (mapcar #'second types)))
338 (cutoff-point (if cutoff
339 (truncate (* (float total-bytes) cutoff))
342 (reported-objects 0))
343 (declare (fixnum total-objects total-bytes cutoff-point reported-objects
345 (loop for (bytes objects name) in types do
346 (when (<= bytes cutoff-point)
347 (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
348 (- total-bytes reported-bytes)
349 (- total-objects reported-objects))
351 (incf reported-bytes bytes)
352 (incf reported-objects objects)
353 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
355 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
356 total-bytes total-objects (car space-total))))
358 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
359 (print-summary t) cutoff)
361 "Print out information about the heap memory in use. :Print-Spaces is a list
362 of the spaces to print detailed information for. :Count-Spaces is a list of
363 the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
364 and :Read-Only.) If :Print-Summary is true, then summary information will be
365 printed. The defaults print only summary information for dynamic space.
366 If true, Cutoff is a fraction of the usage in a report below which types will
367 be combined as OTHER."
368 (declare (type (or single-float null) cutoff))
369 (let* ((spaces (if (eq count-spaces t)
370 '(:static :dynamic :read-only)
372 (totals (mapcar #'(lambda (space)
373 (cons space (type-breakdown space)))
376 (dolist (space-total totals)
377 (when (or (eq print-spaces t)
378 (member (car space-total) print-spaces))
379 (report-space-total space-total cutoff)))
381 (when print-summary (print-summary spaces totals)))
385 (defun count-no-ops (space)
387 "Print info about how much code and no-ops there are in Space."
388 (declare (type spaces space))
392 (declare (fixnum code-words no-ops)
393 (type unsigned-byte total-bytes))
394 (map-allocated-objects
395 #'(lambda (obj type size)
396 (declare (fixnum size) (optimize (safety 0)))
397 (when (eql type code-header-type)
398 (incf total-bytes size)
399 (let ((words (truly-the fixnum (%code-code-size obj)))
400 (sap (truly-the system-area-pointer
401 (%primitive code-instructions obj))))
402 (incf code-words words)
404 (when (zerop (sap-ref-32 sap (* i sb!vm:word-bytes)))
409 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
410 total-bytes code-words no-ops
411 (round (* no-ops 100) code-words)))
415 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
416 (let ((descriptor-words 0)
417 (non-descriptor-headers 0)
418 (non-descriptor-bytes 0))
419 (declare (type unsigned-byte descriptor-words non-descriptor-headers
420 non-descriptor-bytes))
421 (dolist (space (or spaces '(:read-only :static :dynamic)))
422 (declare (inline map-allocated-objects))
423 (map-allocated-objects
424 #'(lambda (obj type size)
425 (declare (fixnum size) (optimize (safety 0)))
428 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
429 (declare (type fixnum inst-words))
430 (incf non-descriptor-bytes (* inst-words word-bytes))
431 (incf descriptor-words
432 (- (truncate size word-bytes) inst-words))))
437 #.simple-bit-vector-type
438 #.simple-array-unsigned-byte-2-type
439 #.simple-array-unsigned-byte-4-type
440 #.simple-array-unsigned-byte-8-type
441 #.simple-array-unsigned-byte-16-type
442 #.simple-array-unsigned-byte-32-type
443 #.simple-array-signed-byte-8-type
444 #.simple-array-signed-byte-16-type
445 #.simple-array-signed-byte-30-type
446 #.simple-array-signed-byte-32-type
447 #.simple-array-single-float-type
448 #.simple-array-double-float-type
449 #.simple-array-complex-single-float-type
450 #.simple-array-complex-double-float-type)
451 (incf non-descriptor-headers)
452 (incf non-descriptor-bytes (- size word-bytes)))
453 ((#.list-pointer-type
454 #.instance-pointer-type
459 #.complex-string-type
460 #.complex-bit-vector-type
461 #.complex-vector-type
463 #.closure-header-type
464 #.funcallable-instance-header-type
465 #.value-cell-header-type
469 #.instance-header-type)
470 (incf descriptor-words (truncate size word-bytes)))
472 (error "Bogus type: ~D" type))))
474 (format t "~:D words allocated for descriptor objects.~%"
476 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
477 non-descriptor-bytes non-descriptor-headers)
480 (defun instance-usage (space &key (top-n 15))
481 (declare (type spaces space) (type (or fixnum null) top-n))
483 "Print a breakdown by instance type of all the instances allocated in
484 Space. If TOP-N is true, print only information for the the TOP-N types with
486 (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
487 (let ((totals (make-hash-table :test 'eq))
490 (declare (fixnum total-objects total-bytes))
491 (map-allocated-objects
492 #'(lambda (obj type size)
493 (declare (fixnum size) (optimize (speed 3) (safety 0)))
494 (when (eql type instance-header-type)
496 (incf total-bytes size)
497 (let* ((class (layout-class (%instance-ref obj 0)))
498 (found (gethash class totals)))
500 (incf (the fixnum (car found)))
501 (incf (the fixnum (cdr found)) size))
503 (setf (gethash class totals) (cons 1 size)))))))
506 (collect ((totals-list))
507 (maphash #'(lambda (class what)
508 (totals-list (cons (prin1-to-string
509 (class-proper-name class))
512 (let ((sorted (sort (totals-list) #'> :key #'cddr))
515 (declare (fixnum printed-bytes printed-objects))
516 (dolist (what (if top-n
517 (subseq sorted 0 (min (length sorted) top-n))
519 (let ((bytes (cddr what))
520 (objects (cadr what)))
521 (incf printed-bytes bytes)
522 (incf printed-objects objects)
523 (format t " ~A: ~:D bytes, ~D object~:P.~%" (car what)
526 (let ((residual-objects (- total-objects printed-objects))
527 (residual-bytes (- total-bytes printed-bytes)))
528 (unless (zerop residual-objects)
529 (format t " Other types: ~:D bytes, ~D: object~:P.~%"
530 residual-bytes residual-objects))))
532 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
533 space total-bytes total-objects)))
537 (defun find-holes (&rest spaces)
538 (dolist (space (or spaces '(:read-only :static :dynamic)))
539 (format t "In ~A space:~%" space)
540 (let ((start-addr nil)
542 (declare (type (or null (unsigned-byte 32)) start-addr)
543 (type (unsigned-byte 32) total-bytes))
544 (map-allocated-objects
545 #'(lambda (object typecode bytes)
546 (declare (ignore typecode)
547 (type (unsigned-byte 32) bytes))
548 (if (and (consp object)
550 (eql (cdr object) 0))
552 (incf total-bytes bytes)
553 (setf start-addr (sb!di::get-lisp-obj-address object)
556 (format t "~D bytes at #X~X~%" total-bytes start-addr)
557 (setf start-addr nil))))
560 (format t "~D bytes at #X~X~%" total-bytes start-addr))))
563 ;;;; PRINT-ALLOCATED-OBJECTS
565 (defun print-allocated-objects (space &key (percent 0) (pages 5)
566 type larger smaller count
567 (stream *standard-output*))
568 (declare (type (integer 0 99) percent) (type sb!c::index pages)
569 (type stream stream) (type spaces space)
570 (type (or sb!c::index null) type larger smaller count))
571 (multiple-value-bind (start-sap end-sap) (space-bounds space)
572 (let* ((space-start (sap-int start-sap))
573 (space-end (sap-int end-sap))
574 (space-size (- space-end space-start))
575 (pagesize (sb!sys:get-page-size))
576 (start (+ space-start (round (* space-size percent) 100)))
577 (printed-conses (make-hash-table :test 'eq))
581 (declare (type (unsigned-byte 32) last-page start)
582 (fixnum pages-so-far count-so-far pagesize))
583 (labels ((note-conses (x)
584 (unless (or (atom x) (gethash x printed-conses))
585 (setf (gethash x printed-conses) t)
586 (note-conses (car x))
587 (note-conses (cdr x)))))
588 (map-allocated-objects
589 #'(lambda (obj obj-type size)
590 (declare (optimize (safety 0)))
591 (let ((addr (get-lisp-obj-address obj)))
592 (when (>= addr start)
594 (> count-so-far count)
595 (> pages-so-far pages))
596 (return-from print-allocated-objects (values)))
599 (let ((this-page (* (the (unsigned-byte 32)
600 (truncate addr pagesize))
602 (declare (type (unsigned-byte 32) this-page))
603 (when (/= this-page last-page)
604 (when (< pages-so-far pages)
605 (format stream "~2&**** Page ~D, address ~X:~%"
607 (setq last-page this-page)
608 (incf pages-so-far))))
610 (when (and (or (not type) (eql obj-type type))
611 (or (not smaller) (<= size smaller))
612 (or (not larger) (>= size larger)))
616 (let ((dinfo (%code-debug-info obj)))
617 (format stream "~&Code object: ~S~%"
619 (sb!c::compiled-debug-info-name dinfo)
621 (#.symbol-header-type
622 (format stream "~&~S~%" obj))
624 (unless (gethash obj printed-conses)
626 (let ((*print-circle* t)
629 (format stream "~&~S~%" obj))))
632 (let ((str (write-to-string obj :level 5 :length 10
634 (unless (eql type instance-header-type)
635 (format stream "~S: " (type-of obj)))
636 (format stream "~A~%"
637 (subseq str 0 (min (length str) 60))))))))))
641 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
643 (defvar *ignore-after* nil)
645 (defun maybe-cons (space x stuff)
646 (if (or (not (eq space :dynamic))
647 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
651 (defun list-allocated-objects (space &key type larger smaller count
653 (declare (type spaces space)
654 (type (or sb!c::index null) larger smaller type count)
655 (type (or function null) test)
656 (inline map-allocated-objects))
657 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
658 (collect ((counted 0 1+))
660 (map-allocated-objects
661 #'(lambda (obj obj-type size)
662 (declare (optimize (safety 0)))
663 (when (and (or (not type) (eql obj-type type))
664 (or (not smaller) (<= size smaller))
665 (or (not larger) (>= size larger))
666 (or (not test) (funcall test obj)))
667 (setq res (maybe-cons space obj res))
668 (when (and count (>= (counted) count))
669 (return-from list-allocated-objects res))))
673 (defun list-referencing-objects (space object)
674 (declare (type spaces space) (inline map-allocated-objects))
675 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
678 (setq res (maybe-cons space x res))))
679 (map-allocated-objects
680 #'(lambda (obj obj-type size)
681 (declare (optimize (safety 0)) (ignore obj-type size))
684 (when (or (eq (car obj) object) (eq (cdr obj) object))
687 (dotimes (i (%instance-length obj))
688 (when (eq (%instance-ref obj i) object)
692 (dotimes (i (length obj))
693 (when (eq (svref obj i) object)
697 (when (or (eq (symbol-name obj) object)
698 (eq (symbol-package obj) object)
699 (eq (symbol-plist obj) object)
700 (eq (symbol-value obj) object))