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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.41 - (show annotations)
Sun Aug 21 07:43:38 2011 UTC (2 years, 7 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, HEAD
Changes since 1.40: +2 -2 lines
Reduce consing of SAPs in ROOM.

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

  ViewVC Help
Powered by ViewVC 1.1.5