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.
14 ;;;; type format database
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
18 ;; The name of this type.
19 (name nil :type symbol)
20 ;; Kind of type (how we determine length).
21 (kind (required-argument)
22 :type (member :lowtag :fixed :header :vector
23 :string :code :closure :instance))
24 ;; Length if fixed-length, shift amount for element size if :VECTOR.
25 (length nil :type (or fixnum null))))
27 (eval-when (:compile-toplevel :execute)
29 (defvar *meta-room-info* (make-array 256 :initial-element nil))
31 (dolist (obj *primitive-objects*)
32 (let ((header (primitive-object-header obj))
33 (lowtag (primitive-object-lowtag obj))
34 (name (primitive-object-name obj))
35 (variable (primitive-object-variable-length obj))
36 (size (primitive-object-size obj)))
40 (let ((info (make-room-info :name name
42 (lowtag (symbol-value lowtag)))
43 (declare (fixnum lowtag))
45 (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
48 (setf (svref *meta-room-info* (symbol-value header))
49 (make-room-info :name name
53 (dolist (code (list complex-string-type simple-array-type
54 complex-bit-vector-type complex-vector-type
56 (setf (svref *meta-room-info* code)
57 (make-room-info :name 'array-header
60 (setf (svref *meta-room-info* bignum-type)
61 (make-room-info :name 'bignum
64 (setf (svref *meta-room-info* closure-header-type)
65 (make-room-info :name 'closure
68 (dolist (stuff '((simple-bit-vector-type . -3)
69 (simple-vector-type . 2)
70 (simple-array-unsigned-byte-2-type . -2)
71 (simple-array-unsigned-byte-4-type . -1)
72 (simple-array-unsigned-byte-8-type . 0)
73 (simple-array-unsigned-byte-16-type . 1)
74 (simple-array-unsigned-byte-32-type . 2)
75 (simple-array-signed-byte-8-type . 0)
76 (simple-array-signed-byte-16-type . 1)
77 (simple-array-signed-byte-30-type . 2)
78 (simple-array-signed-byte-32-type . 2)
79 (simple-array-single-float-type . 2)
80 (simple-array-double-float-type . 3)
81 (simple-array-complex-single-float-type . 3)
82 (simple-array-complex-double-float-type . 4)))
83 (let ((name (car stuff))
85 (setf (svref *meta-room-info* (symbol-value name))
86 (make-room-info :name name
90 (setf (svref *meta-room-info* simple-string-type)
91 (make-room-info :name 'simple-string-type
95 (setf (svref *meta-room-info* code-header-type)
96 (make-room-info :name 'code
99 (setf (svref *meta-room-info* instance-header-type)
100 (make-room-info :name 'instance
103 ); eval-when (compile eval)
105 (defparameter *room-info* '#.*meta-room-info*)
106 (deftype spaces () '(member :static :dynamic :read-only))
108 ;;;; MAP-ALLOCATED-OBJECTS
110 ;;; Since they're represented as counts of words, we should never
111 ;;; need bignums to represent these:
112 (declaim (type fixnum
113 *static-space-free-pointer*
114 *read-only-space-free-pointer*))
116 (defun space-bounds (space)
117 (declare (type spaces space))
120 (values (int-sap static-space-start)
121 (int-sap (* *static-space-free-pointer* word-bytes))))
123 (values (int-sap read-only-space-start)
124 (int-sap (* *read-only-space-free-pointer* word-bytes))))
126 (values (int-sap dynamic-space-start)
127 (dynamic-space-free-pointer)))))
129 ;;; Return the total number of bytes used in SPACE.
130 (defun space-bytes (space)
131 (multiple-value-bind (start end) (space-bounds space)
132 (- (sap-int end) (sap-int start))))
134 ;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
135 #!-sb-fluid (declaim (inline round-to-dualword))
136 (defun round-to-dualword (size)
137 (declare (fixnum size))
138 (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
140 ;;; Return the total size of a vector in bytes, including any pad.
141 #!-sb-fluid (declaim (inline vector-total-size))
142 (defun vector-total-size (obj info)
143 (let ((shift (room-info-length info))
144 (len (+ (length (the (simple-array * (*)) obj))
145 (ecase (room-info-kind info)
148 (declare (type (integer -3 3) shift))
150 (+ (* vector-data-offset word-bytes)
155 (1- (the fixnum (ash 1 (- shift)))))))
157 (ash len shift)))))))
159 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
160 ;;; the object, the object's type code, and the objects total size in
161 ;;; bytes, including any header and padding.
162 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
163 (defun map-allocated-objects (fun space)
164 (declare (type function fun) (type spaces space))
166 (multiple-value-bind (start end) (space-bounds space)
167 (declare (type system-area-pointer start end))
168 (declare (optimize (speed 3) (safety 0)))
169 (let ((current start)
173 (let* ((header (sap-ref-32 current 0))
174 (header-type (logand header #xFF))
175 (info (svref *room-info* header-type)))
178 (eq (room-info-kind info) :lowtag))
179 (let ((size (* cons-size word-bytes)))
181 (make-lisp-obj (logior (sap-int current)
185 (setq current (sap+ current size))))
186 ((eql header-type closure-header-type)
187 (let* ((obj (make-lisp-obj (logior (sap-int current)
188 function-pointer-type)))
189 (size (round-to-dualword
190 (* (the fixnum (1+ (get-closure-length obj)))
192 (funcall fun obj header-type size)
193 (setq current (sap+ current size))))
194 ((eq (room-info-kind info) :instance)
195 (let* ((obj (make-lisp-obj
196 (logior (sap-int current) instance-pointer-type)))
197 (size (round-to-dualword
198 (* (+ (%instance-length obj) 1) word-bytes))))
199 (declare (fixnum size))
200 (funcall fun obj header-type size)
201 (aver (zerop (logand size lowtag-mask)))
203 (when (> size 200000) (break "implausible size, prev ~S" prev))
206 (setq current (sap+ current size))))
208 (let* ((obj (make-lisp-obj
209 (logior (sap-int current) other-pointer-type)))
210 (size (ecase (room-info-kind info)
212 (aver (or (eql (room-info-length info)
213 (1+ (get-header-data obj)))
216 (* (room-info-length info) word-bytes)))
218 (vector-total-size obj info))
221 (* (1+ (get-header-data obj)) word-bytes)))
224 (* (get-header-data obj) word-bytes))
226 (* (the fixnum (%code-code-size obj))
228 (declare (fixnum size))
229 (funcall fun obj header-type size)
230 (aver (zerop (logand size lowtag-mask)))
232 (when (> size 200000)
233 (break "Implausible size, prev ~S" prev))
236 (setq current (sap+ current size))))))
237 (unless (sap< current end)
238 (aver (sap= current end))
246 ;;; Return a list of 3-lists (bytes object type-name) for the objects
247 ;;; allocated in Space.
248 (defun type-breakdown (space)
249 (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
250 (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
251 (map-allocated-objects
252 #'(lambda (obj type size)
253 (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
254 (incf (aref sizes type) size)
255 (incf (aref counts type)))
258 (let ((totals (make-hash-table :test 'eq)))
260 (let ((total-count (aref counts i)))
261 (unless (zerop total-count)
262 (let* ((total-size (aref sizes i))
263 (name (room-info-name (aref *room-info* i)))
264 (found (gethash name totals)))
266 (incf (first found) total-size)
267 (incf (second found) total-count))
269 (setf (gethash name totals)
270 (list total-size total-count name))))))))
272 (collect ((totals-list))
273 (maphash #'(lambda (k v)
277 (sort (totals-list) #'> :key #'first)))))
279 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
280 ;;; (space-name . totals-for-space), where totals-for-space is the list
281 ;;; returned by TYPE-BREAKDOWN.
282 (defun print-summary (spaces totals)
283 (let ((summary (make-hash-table :test 'eq)))
284 (dolist (space-total totals)
285 (dolist (total (cdr space-total))
286 (push (cons (car space-total) total)
287 (gethash (third total) summary))))
289 (collect ((summary-totals))
290 (maphash #'(lambda (k v)
293 (declare (fixnum sum))
294 (dolist (space-total v)
295 (incf sum (first (cdr space-total))))
296 (summary-totals (cons sum v))))
299 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
300 (let ((summary-total-bytes 0)
301 (summary-total-objects 0))
302 (declare (fixnum summary-total-bytes summary-total-objects))
303 (dolist (space-totals
304 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
305 (let ((total-objects 0)
308 (declare (fixnum total-objects total-bytes))
310 (dolist (space-total space-totals)
311 (let ((total (cdr space-total)))
312 (setq name (third total))
313 (incf total-bytes (first total))
314 (incf total-objects (second total))
315 (spaces (cons (car space-total) (first total)))))
316 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
317 name total-bytes total-objects)
318 (dolist (space (spaces))
319 (format t ", ~D% ~(~A~)"
320 (round (* (cdr space) 100) total-bytes)
323 (incf summary-total-bytes total-bytes)
324 (incf summary-total-objects total-objects))))
325 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
326 summary-total-bytes summary-total-objects)))))
328 ;;; Report object usage for a single space.
329 (defun report-space-total (space-total cutoff)
330 (declare (list space-total) (type (or single-float null) cutoff))
331 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
332 (let* ((types (cdr space-total))
333 (total-bytes (reduce #'+ (mapcar #'first types)))
334 (total-objects (reduce #'+ (mapcar #'second types)))
335 (cutoff-point (if cutoff
336 (truncate (* (float total-bytes) cutoff))
339 (reported-objects 0))
340 (declare (fixnum total-objects total-bytes cutoff-point reported-objects
342 (loop for (bytes objects name) in types do
343 (when (<= bytes cutoff-point)
344 (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
345 (- total-bytes reported-bytes)
346 (- total-objects reported-objects))
348 (incf reported-bytes bytes)
349 (incf reported-objects objects)
350 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
352 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
353 total-bytes total-objects (car space-total))))
355 ;;; Print information about the heap memory in use. PRINT-SPACES is a
356 ;;; list of the spaces to print detailed information for.
357 ;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
358 ;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
359 ;;; PRINT-SUMMARY is true, then summary information will be printed.
360 ;;; The defaults print only summary information for dynamic space. If
361 ;;; true, CUTOFF is a fraction of the usage in a report below which
362 ;;; types will be combined as OTHER.
363 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
364 (print-summary t) cutoff)
365 (declare (type (or single-float null) cutoff))
366 (let* ((spaces (if (eq count-spaces t)
367 '(:static :dynamic :read-only)
369 (totals (mapcar #'(lambda (space)
370 (cons space (type-breakdown space)))
373 (dolist (space-total totals)
374 (when (or (eq print-spaces t)
375 (member (car space-total) print-spaces))
376 (report-space-total space-total cutoff)))
378 (when print-summary (print-summary spaces totals)))
382 ;;; Print info about how much code and no-ops there are in SPACE.
383 (defun count-no-ops (space)
384 (declare (type spaces space))
388 (declare (fixnum code-words no-ops)
389 (type unsigned-byte total-bytes))
390 (map-allocated-objects
391 #'(lambda (obj type size)
392 (declare (fixnum size) (optimize (safety 0)))
393 (when (eql type code-header-type)
394 (incf total-bytes size)
395 (let ((words (truly-the fixnum (%code-code-size obj)))
396 (sap (truly-the system-area-pointer
397 (%primitive code-instructions obj))))
398 (incf code-words words)
400 (when (zerop (sap-ref-32 sap (* i sb!vm:word-bytes)))
405 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
406 total-bytes code-words no-ops
407 (round (* no-ops 100) code-words)))
411 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
412 (let ((descriptor-words 0)
413 (non-descriptor-headers 0)
414 (non-descriptor-bytes 0))
415 (declare (type unsigned-byte descriptor-words non-descriptor-headers
416 non-descriptor-bytes))
417 (dolist (space (or spaces '(:read-only :static :dynamic)))
418 (declare (inline map-allocated-objects))
419 (map-allocated-objects
420 #'(lambda (obj type size)
421 (declare (fixnum size) (optimize (safety 0)))
424 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
425 (declare (type fixnum inst-words))
426 (incf non-descriptor-bytes (* inst-words word-bytes))
427 (incf descriptor-words
428 (- (truncate size word-bytes) inst-words))))
433 #.simple-bit-vector-type
434 #.simple-array-unsigned-byte-2-type
435 #.simple-array-unsigned-byte-4-type
436 #.simple-array-unsigned-byte-8-type
437 #.simple-array-unsigned-byte-16-type
438 #.simple-array-unsigned-byte-32-type
439 #.simple-array-signed-byte-8-type
440 #.simple-array-signed-byte-16-type
441 #.simple-array-signed-byte-30-type
442 #.simple-array-signed-byte-32-type
443 #.simple-array-single-float-type
444 #.simple-array-double-float-type
445 #.simple-array-complex-single-float-type
446 #.simple-array-complex-double-float-type)
447 (incf non-descriptor-headers)
448 (incf non-descriptor-bytes (- size word-bytes)))
449 ((#.list-pointer-type
450 #.instance-pointer-type
455 #.complex-string-type
456 #.complex-bit-vector-type
457 #.complex-vector-type
459 #.closure-header-type
460 #.funcallable-instance-header-type
461 #.value-cell-header-type
465 #.instance-header-type)
466 (incf descriptor-words (truncate size word-bytes)))
468 (error "Bogus type: ~D" type))))
470 (format t "~:D words allocated for descriptor objects.~%"
472 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
473 non-descriptor-bytes non-descriptor-headers)
476 ;;; Print a breakdown by instance type of all the instances allocated
477 ;;; in SPACE. If TOP-N is true, print only information for the the
478 ;;; TOP-N types with largest usage.
479 (defun instance-usage (space &key (top-n 15))
480 (declare (type spaces space) (type (or fixnum null) top-n))
481 (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
482 (let ((totals (make-hash-table :test 'eq))
485 (declare (fixnum total-objects total-bytes))
486 (map-allocated-objects
487 #'(lambda (obj type size)
488 (declare (fixnum size) (optimize (speed 3) (safety 0)))
489 (when (eql type instance-header-type)
491 (incf total-bytes size)
492 (let* ((class (layout-class (%instance-ref obj 0)))
493 (found (gethash class totals)))
495 (incf (the fixnum (car found)))
496 (incf (the fixnum (cdr found)) size))
498 (setf (gethash class totals) (cons 1 size)))))))
501 (collect ((totals-list))
502 (maphash #'(lambda (class what)
503 (totals-list (cons (prin1-to-string
504 (class-proper-name class))
507 (let ((sorted (sort (totals-list) #'> :key #'cddr))
510 (declare (fixnum printed-bytes printed-objects))
511 (dolist (what (if top-n
512 (subseq sorted 0 (min (length sorted) top-n))
514 (let ((bytes (cddr what))
515 (objects (cadr what)))
516 (incf printed-bytes bytes)
517 (incf printed-objects objects)
518 (format t " ~A: ~:D bytes, ~D object~:P.~%" (car what)
521 (let ((residual-objects (- total-objects printed-objects))
522 (residual-bytes (- total-bytes printed-bytes)))
523 (unless (zerop residual-objects)
524 (format t " Other types: ~:D bytes, ~D object~:P.~%"
525 residual-bytes residual-objects))))
527 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
528 space total-bytes total-objects)))
532 (defun find-holes (&rest spaces)
533 (dolist (space (or spaces '(:read-only :static :dynamic)))
534 (format t "In ~A space:~%" space)
535 (let ((start-addr nil)
537 (declare (type (or null (unsigned-byte 32)) start-addr)
538 (type (unsigned-byte 32) total-bytes))
539 (map-allocated-objects
540 #'(lambda (object typecode bytes)
541 (declare (ignore typecode)
542 (type (unsigned-byte 32) bytes))
543 (if (and (consp object)
545 (eql (cdr object) 0))
547 (incf total-bytes bytes)
548 (setf start-addr (sb!di::get-lisp-obj-address object)
551 (format t "~D bytes at #X~X~%" total-bytes start-addr)
552 (setf start-addr nil))))
555 (format t "~D bytes at #X~X~%" total-bytes start-addr))))
558 ;;;; PRINT-ALLOCATED-OBJECTS
560 (defun print-allocated-objects (space &key (percent 0) (pages 5)
561 type larger smaller count
562 (stream *standard-output*))
563 (declare (type (integer 0 99) percent) (type sb!c::index pages)
564 (type stream stream) (type spaces space)
565 (type (or sb!c::index null) type larger smaller count))
566 (multiple-value-bind (start-sap end-sap) (space-bounds space)
567 (let* ((space-start (sap-int start-sap))
568 (space-end (sap-int end-sap))
569 (space-size (- space-end space-start))
570 (pagesize (sb!sys:get-page-size))
571 (start (+ space-start (round (* space-size percent) 100)))
572 (printed-conses (make-hash-table :test 'eq))
576 (declare (type (unsigned-byte 32) last-page start)
577 (fixnum pages-so-far count-so-far pagesize))
578 (labels ((note-conses (x)
579 (unless (or (atom x) (gethash x printed-conses))
580 (setf (gethash x printed-conses) t)
581 (note-conses (car x))
582 (note-conses (cdr x)))))
583 (map-allocated-objects
584 #'(lambda (obj obj-type size)
585 (declare (optimize (safety 0)))
586 (let ((addr (get-lisp-obj-address obj)))
587 (when (>= addr start)
589 (> count-so-far count)
590 (> pages-so-far pages))
591 (return-from print-allocated-objects (values)))
594 (let ((this-page (* (the (values (unsigned-byte 32) t)
595 (truncate addr pagesize))
597 (declare (type (unsigned-byte 32) this-page))
598 (when (/= this-page last-page)
599 (when (< pages-so-far pages)
600 ;; FIXME: What is this? (ERROR "Argh..")? or
601 ;; a warning? or code that can be removed
602 ;; once the system is stable? or what?
603 (format stream "~2&**** Page ~D, address ~X:~%"
605 (setq last-page this-page)
606 (incf pages-so-far))))
608 (when (and (or (not type) (eql obj-type type))
609 (or (not smaller) (<= size smaller))
610 (or (not larger) (>= size larger)))
614 (let ((dinfo (%code-debug-info obj)))
615 (format stream "~&Code object: ~S~%"
617 (sb!c::compiled-debug-info-name dinfo)
619 (#.symbol-header-type
620 (format stream "~&~S~%" obj))
622 (unless (gethash obj printed-conses)
624 (let ((*print-circle* t)
627 (format stream "~&~S~%" obj))))
630 (let ((str (write-to-string obj :level 5 :length 10
632 (unless (eql type instance-header-type)
633 (format stream "~S: " (type-of obj)))
634 (format stream "~A~%"
635 (subseq str 0 (min (length str) 60))))))))))
639 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
641 (defvar *ignore-after* nil)
643 (defun maybe-cons (space x stuff)
644 (if (or (not (eq space :dynamic))
645 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
649 (defun list-allocated-objects (space &key type larger smaller count
651 (declare (type spaces space)
652 (type (or sb!c::index null) larger smaller type count)
653 (type (or function null) test)
654 (inline map-allocated-objects))
655 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
656 (collect ((counted 0 1+))
658 (map-allocated-objects
659 #'(lambda (obj obj-type size)
660 (declare (optimize (safety 0)))
661 (when (and (or (not type) (eql obj-type type))
662 (or (not smaller) (<= size smaller))
663 (or (not larger) (>= size larger))
664 (or (not test) (funcall test obj)))
665 (setq res (maybe-cons space obj res))
666 (when (and count (>= (counted) count))
667 (return-from list-allocated-objects res))))
671 (defun list-referencing-objects (space object)
672 (declare (type spaces space) (inline map-allocated-objects))
673 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
676 (setq res (maybe-cons space x res))))
677 (map-allocated-objects
678 #'(lambda (obj obj-type size)
679 (declare (optimize (safety 0)) (ignore obj-type size))
682 (when (or (eq (car obj) object) (eq (cdr obj) object))
685 (dotimes (i (%instance-length obj))
686 (when (eq (%instance-ref obj i) object)
690 (dotimes (i (length obj))
691 (when (eq (svref obj i) object)
695 (when (or (eq (symbol-name obj) object)
696 (eq (symbol-package obj) object)
697 (eq (symbol-plist obj) object)
698 (eq (symbol-value obj) object))