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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37.12.1 - (show annotations)
Thu Feb 25 20:34:51 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.37: +33 -31 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
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.37.12.1 2010/02/25 20:34:51 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))
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 _"~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 _"~%~A:~% ~:D bytes, ~:D object~:P"
513 name total-bytes total-objects)
514 (dolist (space (spaces))
515 (format t ", ~D% ~(~A~)"
516 (round (* (cdr space) 100) total-bytes)
517 (car space)))
518 (format t ".~%")
519 (incf summary-total-bytes total-bytes)
520 (incf summary-total-objects total-objects))))
521 (format t _"~%Summary total:~% ~:D bytes, ~:D objects.~%"
522 summary-total-bytes summary-total-objects)))))
523
524
525 ;;; REPORT-SPACE-TOTAL -- Internal
526 ;;;
527 ;;; Report object usage for a single space.
528 ;;;
529 (defun report-space-total (space-total cutoff)
530 (declare (list space-total) (type (or single-float null) cutoff))
531 (format t _"~2&Breakdown for ~(~A~) space:~%" (car space-total))
532 (let* ((types (cdr space-total))
533 (total-bytes (reduce #'+ (mapcar #'first types)))
534 (total-objects (reduce #'+ (mapcar #'second types)))
535 (cutoff-point (if cutoff
536 (truncate (* (float total-bytes) cutoff))
537 0))
538 (reported-bytes 0)
539 (reported-objects 0))
540 (declare (fixnum total-objects cutoff-point reported-objects)
541 (type memory-size total-bytes reported-bytes))
542 (loop for (bytes objects name) in types do
543 (when (<= bytes cutoff-point)
544 (format t _" ~13:D bytes for ~9:D other object~2:*~P.~%"
545 (- total-bytes reported-bytes)
546 (- total-objects reported-objects))
547 (return))
548 (incf reported-bytes bytes)
549 (incf reported-objects objects)
550 (format t _" ~13:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
551 bytes objects name))
552 (format t _" ~13:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
553 total-bytes total-objects (car space-total))))
554
555
556 ;;; MEMORY-USAGE -- Public
557 ;;;
558 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
559 (print-summary t) cutoff)
560 _N"Print out information about the heap memory in use. :Print-Spaces is a list
561 of the spaces to print detailed information for. :Count-Spaces is a list of
562 the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
563 and :Read-Only.) If :Print-Summary is true, then summary information will be
564 printed. The defaults print only summary information for dynamic space.
565 If true, Cutoff is a fraction of the usage in a report below which types will
566 be combined as OTHER."
567 (declare (type (or single-float null) cutoff))
568 (let* ((spaces (if (eq count-spaces t)
569 '(:static :dynamic :read-only)
570 count-spaces))
571 (totals (mapcar #'(lambda (space)
572 (cons space (type-breakdown space)))
573 spaces)))
574
575 (dolist (space-total totals)
576 (when (or (eq print-spaces t)
577 (member (car space-total) print-spaces))
578 (report-space-total space-total cutoff)))
579
580 (when print-summary (print-summary spaces totals)))
581
582 (values))
583
584
585 ;;; COUNT-NO-OPS -- Public
586 ;;;
587 (defun count-no-ops (space)
588 _N"Print info about how much code and no-ops there are in Space."
589 (declare (type spaces space))
590 (let ((code-words 0)
591 (no-ops 0)
592 (total-bytes 0))
593 (declare (fixnum code-words no-ops)
594 (type unsigned-byte total-bytes))
595 (map-allocated-objects
596 #'(lambda (obj type size)
597 (declare (fixnum size) (optimize (safety 0)))
598 (when (eql type code-header-type)
599 (incf total-bytes size)
600 (let ((words (truly-the fixnum (%code-code-size obj)))
601 (sap (truly-the system-area-pointer
602 (%primitive code-instructions obj))))
603 (incf code-words words)
604 (dotimes (i words)
605 (when (zerop (sap-ref-32 sap (* i vm:word-bytes)))
606 (incf no-ops))))))
607 space)
608
609 (format t
610 _"~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
611 total-bytes code-words no-ops
612 (round (* no-ops 100) code-words)))
613
614 (values))
615
616
617 ;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE -- Public
618 ;;;
619 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
620 (let ((descriptor-words 0)
621 (non-descriptor-headers 0)
622 (non-descriptor-bytes 0))
623 (declare (type unsigned-byte descriptor-words non-descriptor-headers
624 non-descriptor-bytes))
625 (dolist (space (or spaces '(:read-only :static :dynamic)))
626 (declare (inline map-allocated-objects))
627 (map-allocated-objects
628 #'(lambda (obj type size)
629 (declare (fixnum size) (optimize (safety 0)))
630 (case type
631 (#.code-header-type
632 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
633 (declare (type fixnum inst-words))
634 (incf non-descriptor-bytes (* inst-words word-bytes))
635 (incf descriptor-words
636 (- (truncate size word-bytes) inst-words))))
637 ((#.bignum-type
638 #.single-float-type
639 #.double-float-type
640 #+double-double
641 #.double-double-float-type
642 #.complex-single-float-type
643 #.complex-double-float-type
644 #+double-double
645 #.complex-double-double-float-type
646 #.simple-string-type
647 #.simple-bit-vector-type
648 #.simple-array-unsigned-byte-2-type
649 #.simple-array-unsigned-byte-4-type
650 #.simple-array-unsigned-byte-8-type
651 #.simple-array-unsigned-byte-16-type
652 #.simple-array-unsigned-byte-32-type
653 #.simple-array-signed-byte-8-type
654 #.simple-array-signed-byte-16-type
655 #.simple-array-signed-byte-30-type
656 #.simple-array-signed-byte-32-type
657 #.simple-array-single-float-type
658 #.simple-array-double-float-type
659 #+double-double
660 #.simple-array-double-double-float-type
661 #.simple-array-complex-single-float-type
662 #.simple-array-complex-double-float-type
663 #+double-double
664 #.simple-array-complex-double-double-float-type)
665 (incf non-descriptor-headers)
666 (incf non-descriptor-bytes (- size word-bytes)))
667 ((#.list-pointer-type
668 #.instance-pointer-type
669 #.ratio-type
670 #.complex-type
671 #.simple-array-type
672 #.simple-vector-type
673 #.complex-string-type
674 #.complex-bit-vector-type
675 #.complex-vector-type
676 #.complex-array-type
677 #.closure-header-type
678 #.funcallable-instance-header-type
679 #.value-cell-header-type
680 #.symbol-header-type
681 #.sap-type
682 #.weak-pointer-type
683 #.instance-header-type
684 #.fdefn-type
685 #+gencgc
686 #.scavenger-hook-type)
687 (incf descriptor-words (truncate size word-bytes)))
688 (t
689 (error _"Bogus type: ~D" type))))
690 space))
691 (format t _"~:D words allocated for descriptor objects.~%"
692 descriptor-words)
693 (format t _"~:D bytes data/~:D words header for non-descriptor objects.~%"
694 non-descriptor-bytes non-descriptor-headers)
695 (values)))
696
697
698 ;;; INSTANCE-USAGE -- Public
699 ;;;
700 (defun instance-usage (space &key (top-n 15))
701 (declare (type spaces space) (type (or fixnum null) top-n))
702 _N"Print a breakdown by instance type of all the instances allocated in
703 Space. If TOP-N is true, print only information for the the TOP-N types with
704 largest usage."
705 (format t _"~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
706 (let ((totals (make-hash-table :test #'eq))
707 (total-objects 0)
708 (total-bytes 0))
709 (declare (fixnum total-objects)
710 (type memory-size total-bytes))
711 (map-allocated-objects
712 #'(lambda (obj type size)
713 (declare (type memory-size size) (optimize (speed 3) (safety 0)))
714 (when (eql type instance-header-type)
715 (incf total-objects)
716 (incf total-bytes size)
717 (let* ((class (layout-class (%instance-ref obj 0)))
718 (found (gethash class totals)))
719 (cond (found
720 (incf (the fixnum (car found)))
721 (incf (the fixnum (cdr found)) size))
722 (t
723 (setf (gethash class totals) (cons 1 size)))))))
724 space)
725
726 (collect ((totals-list))
727 (maphash #'(lambda (class what)
728 (totals-list (cons (prin1-to-string
729 (class-proper-name class))
730 what)))
731 totals)
732 (let ((sorted (sort (totals-list) #'> :key #'cddr))
733 (printed-bytes 0)
734 (printed-objects 0))
735 (declare (type memory-size printed-bytes printed-objects))
736 (dolist (what (if top-n
737 (subseq sorted 0 (min (length sorted) top-n))
738 sorted))
739 (let ((bytes (cddr what))
740 (objects (cadr what)))
741 (incf printed-bytes bytes)
742 (incf printed-objects objects)
743 (format t _" ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)
744 bytes objects)))
745
746 (let ((residual-objects (- total-objects printed-objects))
747 (residual-bytes (- total-bytes printed-bytes)))
748 (unless (zerop residual-objects)
749 (format t _" Other types: ~:D bytes, ~D: object~:P.~%"
750 residual-bytes residual-objects))))
751
752 (format t _" ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
753 space total-bytes total-objects)))
754
755 (values))
756
757
758 ;;; FIND-HOLES -- Public
759 ;;;
760 (defun find-holes (&rest spaces)
761 (dolist (space (or spaces '(:read-only :static :dynamic)))
762 (format t _"In ~A space:~%" space)
763 (let ((start-addr nil)
764 (total-bytes 0))
765 (declare (type (or null (unsigned-byte 32)) start-addr)
766 (type (unsigned-byte 32) total-bytes))
767 (map-allocated-objects
768 #'(lambda (object typecode bytes)
769 (declare (ignore typecode)
770 (type (unsigned-byte 32) bytes))
771 (if (and (consp object)
772 (eql (car object) 0)
773 (eql (cdr object) 0))
774 (if start-addr
775 (incf total-bytes bytes)
776 (setf start-addr (di::get-lisp-obj-address object)
777 total-bytes bytes))
778 (when start-addr
779 (format t _"~D bytes at #x~X~%" total-bytes start-addr)
780 (setf start-addr nil))))
781 space)
782 (when start-addr
783 (format t _"~D bytes at #x~X~%" total-bytes start-addr))))
784 (values))
785
786
787 ;;; Print allocated objects:
788
789 (defun print-allocated-objects (space &key (percent 0) (pages 5)
790 type larger smaller count
791 (stream *standard-output*))
792 (declare (type (integer 0 99) percent) (type c::index pages)
793 (type stream stream) (type spaces space)
794 (type (or c::index null) type larger smaller count))
795 (multiple-value-bind (start-sap end-sap)
796 (space-bounds space)
797 (let* ((space-start (sap-int start-sap))
798 (space-end (sap-int end-sap))
799 (space-size (- space-end space-start))
800 (pagesize (system:get-page-size))
801 (start (+ space-start (round (* space-size percent) 100)))
802 (printed-conses (make-hash-table :test #'eq))
803 (pages-so-far 0)
804 (count-so-far 0)
805 (last-page 0))
806 (declare (type (unsigned-byte 32) last-page start)
807 (fixnum pages-so-far count-so-far pagesize))
808 (labels ((note-conses (x)
809 (unless (or (atom x) (gethash x printed-conses))
810 (setf (gethash x printed-conses) t)
811 (note-conses (car x))
812 (note-conses (cdr x)))))
813 (map-allocated-objects
814 #'(lambda (obj obj-type size)
815 (declare (optimize (safety 0)))
816 (let ((addr (get-lisp-obj-address obj)))
817 (when (>= addr start)
818 (when (if count
819 (> count-so-far count)
820 (> pages-so-far pages))
821 (return-from print-allocated-objects (values)))
822
823 (unless count
824 (let ((this-page (* (the (values (unsigned-byte 32) t)
825 (truncate addr pagesize))
826 pagesize)))
827 (declare (type (unsigned-byte 32) this-page))
828 (when (/= this-page last-page)
829 (when (< pages-so-far pages)
830 (format stream "~2&**** Page ~D, address ~X:~%"
831 pages-so-far addr))
832 (setq last-page this-page)
833 (incf pages-so-far))))
834
835 (when (and (or (not type) (eql obj-type type))
836 (or (not smaller) (<= size smaller))
837 (or (not larger) (>= size larger)))
838 (incf count-so-far)
839 (case type
840 (#.code-header-type
841 (let ((dinfo (%code-debug-info obj)))
842 (format stream "~&Code object: ~S~%"
843 (if dinfo
844 (c::compiled-debug-info-name dinfo)
845 "No debug info."))))
846 (#.symbol-header-type
847 (format stream "~&~S~%" obj))
848 (#.list-pointer-type
849 (unless (gethash obj printed-conses)
850 (note-conses obj)
851 (let ((*print-circle* t)
852 (*print-level* 5)
853 (*print-length* 10))
854 (format stream "~&~S~%" obj))))
855 (t
856 (fresh-line stream)
857 (let ((str (write-to-string obj :level 5 :length 10
858 :pretty nil)))
859 (unless (eql type instance-header-type)
860 (format stream "~S: " (type-of obj)))
861 (format stream "~A~%"
862 (subseq str 0 (min (length str) 60))))))))))
863 space))))
864 (values))
865
866
867 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
868
869 (defvar *ignore-after* nil)
870
871 (defun maybe-cons (space x stuff)
872 (if (or (not (eq space :dynamic))
873 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
874 (cons x stuff)
875 stuff))
876
877 (defun list-allocated-objects (space &key type larger smaller count
878 test)
879 (declare (type spaces space)
880 (type (or c::index null) larger smaller type count)
881 (type (or function null) test)
882 (inline map-allocated-objects))
883 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
884 (collect ((counted 0 1+))
885 (let ((res ()))
886 (map-allocated-objects
887 #'(lambda (obj obj-type size)
888 (declare (optimize (safety 0)))
889 (when (and (or (not type) (eql obj-type type))
890 (or (not smaller) (<= size smaller))
891 (or (not larger) (>= size larger))
892 (or (not test) (funcall test obj)))
893 (setq res (maybe-cons space obj res))
894 (when (and count (>= (counted) count))
895 (return-from list-allocated-objects res))))
896 space)
897 res)))
898
899 (defun list-referencing-objects (space object)
900 (declare (type spaces space) (inline map-allocated-objects))
901 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
902 (let ((res ()))
903 (flet ((res (x)
904 (setq res (maybe-cons space x res))))
905 (map-allocated-objects
906 #'(lambda (obj obj-type size)
907 (declare (optimize (safety 0)) (ignore obj-type size))
908 (typecase obj
909 (cons
910 (when (or (eq (car obj) object) (eq (cdr obj) object))
911 (res obj)))
912 (instance
913 (dotimes (i (%instance-length obj))
914 (when (eq (%instance-ref obj i) object)
915 (res obj)
916 (return))))
917 (simple-vector
918 (dotimes (i (length obj))
919 (when (eq (svref obj i) object)
920 (res obj)
921 (return))))
922 (symbol
923 (when (or (eq (symbol-name obj) object)
924 (eq (symbol-package obj) object)
925 (eq (symbol-plist obj) object)
926 (eq (symbol-value obj) object))
927 (res obj)))))
928 space))
929 res))
930
931
932 ;;;; Misc:
933
934 (defun uninterned-symbol-count (space)
935 (declare (type spaces space))
936 (let ((total 0)
937 (uninterned 0))
938 (map-allocated-objects
939 #'(lambda (obj type size)
940 (declare (ignore type size))
941 (when (symbolp obj)
942 (incf total)
943 (unless (symbol-package obj)
944 (incf uninterned))))
945 space)
946 (values uninterned (float (/ uninterned total)))))
947
948
949 (defun code-breakdown (space &key (how :package))
950 (declare (type spaces space) (type (member :file :package) how))
951 (let ((packages (make-hash-table :test #'equal)))
952 (map-allocated-objects
953 #'(lambda (obj type size)
954 (when (eql type code-header-type)
955 (let* ((dinfo (let ((x (%code-debug-info obj)))
956 (when (typep x 'c::debug-info) x)))
957 (package (if (typep dinfo 'c::compiled-debug-info)
958 (c::compiled-debug-info-package dinfo)
959 "UNKNOWN"))
960 (pkg-info (or (gethash package packages)
961 (setf (gethash package packages)
962 (make-hash-table :test #'equal))))
963 (file
964 (if dinfo
965 (let ((src (c::debug-info-source dinfo)))
966 (cond (src
967 (let ((source
968 (first
969 (c::debug-info-source
970 dinfo))))
971 (if (eq (c::debug-source-from source)
972 :file)
973 (c::debug-source-name source)
974 "FROM LISP")))
975 (t
976 (warn _"No source for ~S" obj)
977 "NO SOURCE")))
978 "UNKNOWN"))
979 (file-info (or (gethash file pkg-info)
980 (setf (gethash file pkg-info)
981 (cons 0 0)))))
982 (incf (car file-info))
983 (incf (cdr file-info) size))))
984 space)
985
986 (let ((res ()))
987 (do-hash (pkg pkg-info packages)
988 (let ((pkg-res ())
989 (pkg-count 0)
990 (pkg-size 0))
991 (do-hash (file file-info pkg-info)
992 (incf pkg-count (car file-info))
993 (incf pkg-size (cdr file-info))
994 (push (list file file-info) pkg-res))
995 (push (cons pkg-count pkg-size) pkg-res)
996 (push pkg pkg-res)
997 (push pkg-res res)))
998
999 (loop for (pkg (pkg-count . pkg-size) . files) in
1000 (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
1001 (format t _"~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"
1002 pkg pkg-size pkg-count)
1003 (when (eq how :file)
1004 (loop for (file (file-count . file-size)) in
1005 (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
1006 (format t _"~30@A: ~9:D bytes, ~9:D object~:P.~%"
1007 (file-namestring file) file-size file-count))))))
1008
1009 (values))
1010
1011
1012 ;;;; Histogram interface. Uses Scott's Hist package.
1013 #+nil
1014 (defun memory-histogram (space &key (low 4) (high 20)
1015 (bucket-size 1)
1016 (function
1017 #'(lambda (obj type size)
1018 (declare (ignore obj type) (fixnum size))
1019 (integer-length (1- size))))
1020 (type nil))
1021 (let ((function (if (eval:interpreted-function-p function)
1022 (compile nil function)
1023 function)))
1024 (hist:hist (low high bucket-size)
1025 (map-allocated-objects
1026 #'(lambda (obj this-type size)
1027 (when (or (not type) (eql this-type type))
1028 (hist:hist-record (funcall function obj type size))))
1029 space)))
1030 (values))
1031
1032 ;;; Return the number of fbound constants in a code object.
1033 ;;;
1034 (defun code-object-calls (obj)
1035 (loop for i from code-constants-offset below (get-header-data obj)
1036 count (find-code-object (code-header-ref obj i))))
1037
1038 ;;; Return the number of calls in Obj to functions with <= N calls. Calls is
1039 ;;; an eq hashtable translating code objects to the number of references.
1040 ;;;
1041 (defun code-object-leaf-calls (obj n calls)
1042 (loop for i from code-constants-offset below (get-header-data obj)
1043 count (let ((code (find-code-object (code-header-ref obj i))))
1044 (and code (<= (gethash code calls 0) n)))))
1045
1046 #+nil
1047 (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
1048 (function #'identity))
1049 _N"Given a hashtable, print a histogram of the contents. Function should give
1050 the value to plot when applied to the hashtable values."
1051 (let ((function (if (eval:interpreted-function-p function)
1052 (compile nil function)
1053 function)))
1054 (hist:hist (low high bucket-size)
1055 (loop for count being each hash-value in table do
1056 (hist:hist-record (funcall function count))))))
1057
1058 (defun report-top-n (table &key (top-n 20) (function #'identity))
1059 _N"Report the Top-N entries in the hashtable Table, when sorted by Function
1060 applied to the hash value. If Top-N is NIL, report all entries."
1061 (let ((function (if (eval:interpreted-function-p function)
1062 (compile nil function)
1063 function)))
1064 (collect ((totals-list)
1065 (total-val 0 +))
1066 (maphash #'(lambda (name what)
1067 (let ((val (funcall function what)))
1068 (totals-list (cons name val))
1069 (total-val val)))
1070 table)
1071 (let ((sorted (sort (totals-list) #'> :key #'cdr))
1072 (printed 0))
1073 (declare (fixnum printed))
1074 (dolist (what (if top-n
1075 (subseq sorted 0 (min (length sorted) top-n))
1076 sorted))
1077 (let ((val (cdr what)))
1078 (incf printed val)
1079 (format t "~8:D: ~S~%" val (car what))))
1080
1081 (let ((residual (- (total-val) printed)))
1082 (unless (zerop residual)
1083 (format t _"~8:D: Other~%" residual))))
1084
1085 (format t _"~8:D: Total~%" (total-val))))
1086 (values))
1087
1088
1089 ;;; Given any Lisp object, return the associated code object, or NIL.
1090 ;;;
1091 (defun find-code-object (const)
1092 (flet ((frob (def)
1093 (function-code-header
1094 (ecase (get-type def)
1095 ((#.closure-header-type
1096 #.funcallable-instance-header-type)
1097 (%closure-function def))
1098 (#.function-header-type
1099 def)))))
1100 (typecase const
1101 (function (frob const))
1102 (symbol
1103 (if (fboundp const)
1104 (frob (symbol-function const))
1105 nil))
1106 (t nil))))
1107
1108
1109 (defun find-caller-counts (space)
1110 _N"Return a hashtable mapping each function in for which a call appears in
1111 Space to the number of times such a call appears."
1112 (let ((counts (make-hash-table :test #'eq)))
1113 (map-allocated-objects
1114 #'(lambda (obj type size)
1115 (declare (ignore size))
1116 (when (eql type code-header-type)
1117 (loop for i from code-constants-offset below (get-header-data obj)
1118 do (let ((code (find-code-object (code-header-ref obj i))))
1119 (when code
1120 (incf (gethash code counts 0)))))))
1121 space)
1122 counts))
1123
1124 (defun find-high-callers (space &key (above 10) table (threshold 2))
1125 _N"Return a hashtable translating code objects to function constant counts for
1126 all code objects in Space with more than Above function constants."
1127 (let ((counts (make-hash-table :test #'eq)))
1128 (map-allocated-objects
1129 #'(lambda (obj type size)
1130 (declare (ignore size))
1131 (when (eql type code-header-type)
1132 (let ((count (if table
1133 (code-object-leaf-calls obj threshold table)
1134 (code-object-calls obj))))
1135 (when (> count above)
1136 (setf (gethash obj counts) count)))))
1137 space)
1138 counts))

  ViewVC Help
Powered by ViewVC 1.1.5