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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sun Apr 14 23:57:14 1991 UTC (23 years ago) by ram
Branch: MAIN
Changes since 1.6: +42 -3 lines
Added CODE-PACKAGE-BREAKDOWN and UNINTERNED-SYMBOL-COUNT.
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/room.lisp,v 1.7 1991/04/14 23:57:14 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/room.lisp,v 1.7 1991/04/14 23:57:14 ram Exp $
15 ;;;
16 ;;; Heap grovelling memory usage stuff.
17 ;;;
18 (in-package "VM")
19 (use-package "SYSTEM")
20 (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
21 structure-usage find-holes print-allocated-objects
22 code-package-breakdown uninterned-symbol-count))
23 (in-package "LISP")
24 (import '(
25 dynamic-0-space-start dynamic-1-space-start read-only-space-start
26 static-space-start current-dynamic-space-start
27 *static-space-free-pointer* *read-only-space-free-pointer*)
28 "VM")
29 (in-package "VM")
30
31
32 ;;;; Type format database.
33
34 (defstruct room-info
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 :structure))
43 ;;
44 ;; Length if fixed-length, shift amount for element size if :vector.
45 (length nil :type (or fixnum null)))
46
47 (defvar *room-info* (make-array 256 :initial-element nil))
48
49
50 (dolist (obj *primitive-objects*)
51 (let ((header (primitive-object-header obj))
52 (lowtag (primitive-object-lowtag obj))
53 (name (primitive-object-name obj))
54 (variable (primitive-object-variable-length obj))
55 (size (primitive-object-size obj)))
56 (cond
57 ((not lowtag))
58 ((not header)
59 (let ((info (make-room-info :name name :kind :lowtag))
60 (lowtag (symbol-value lowtag)))
61 (declare (fixnum lowtag))
62 (dotimes (i 32)
63 (setf (svref *room-info* (logior lowtag (ash i 3))) info))))
64 (variable)
65 (t
66 (setf (svref *room-info* (symbol-value header))
67 (make-room-info :name name :kind :fixed :length size))))))
68
69 (dolist (code (list complex-string-type simple-array-type
70 complex-bit-vector-type complex-vector-type
71 complex-array-type))
72 (setf (svref *room-info* code)
73 (make-room-info :name 'array-header :kind :header)))
74
75 (setf (svref *room-info* bignum-type)
76 (make-room-info :name 'bignum :kind :header))
77
78 (setf (svref *room-info* closure-header-type)
79 (make-room-info :name 'closure :kind :closure))
80
81 (dolist (stuff '((simple-bit-vector-type . -3)
82 (simple-vector-type . 2)
83 (simple-array-unsigned-byte-2-type . -2)
84 (simple-array-unsigned-byte-4-type . -1)
85 (simple-array-unsigned-byte-8-type . 0)
86 (simple-array-unsigned-byte-16-type . 1)
87 (simple-array-unsigned-byte-32-type . 2)
88 (simple-array-single-float-type . 2)
89 (simple-array-double-float-type . 3)))
90 (let ((name (car stuff))
91 (size (cdr stuff)))
92 (setf (svref *room-info* (symbol-value name))
93 (make-room-info :name name :kind :vector :length size))))
94
95 (setf (svref *room-info* simple-string-type)
96 (make-room-info :name 'simple-string-type :kind :string :length 0))
97
98 (setf (svref *room-info* code-header-type)
99 (make-room-info :name 'code :kind :code))
100
101 (setf (svref *room-info* structure-header-type)
102 (make-room-info :name 'structure :kind :structure))
103
104 (deftype spaces () '(member :static :dynamic :read-only))
105
106
107 ;;;; MAP-ALLOCATED-OBJECTS:
108
109 (proclaim '(type fixnum *static-space-free-pointer*
110 *read-only-space-free-pointer* ))
111
112 (defun space-bounds (space)
113 (declare (type spaces space))
114 (ecase space
115 (:static
116 (values (int-sap (static-space-start))
117 (int-sap (* *static-space-free-pointer* word-bytes))))
118 (:read-only
119 (values (int-sap (read-only-space-start))
120 (int-sap (* *read-only-space-free-pointer* word-bytes))))
121 (:dynamic
122 (values (int-sap (current-dynamic-space-start))
123 (dynamic-space-free-pointer)))))
124
125
126 ;;; ROUND-TO-DUALWORD -- Internal
127 ;;;
128 ;;; Round Size (in bytes) up to the next dualword (eight byte) boundry.
129 ;;;
130 (proclaim '(inline round-to-dualword))
131 (defun round-to-dualword (size)
132 (declare (fixnum size))
133 (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
134
135
136 ;;; VECTOR-TOTAL-SIZE -- Internal
137 ;;;
138 ;;; Return the total size of a vector in bytes, including any pad.
139 ;;;
140 (proclaim '(inline vector-total-size))
141 (defun vector-total-size (obj info)
142 (let ((shift (room-info-length info))
143 (len (+ (length (the vector obj))
144 (ecase (room-info-kind info)
145 (:vector 0)
146 (:string 1)))))
147 (declare (type (integer -3 3) shift))
148 (round-to-dualword
149 (+ (* vector-data-offset word-bytes)
150 (the fixnum
151 (if (minusp shift)
152 (ash (the fixnum
153 (+ len (the fixnum
154 (1- (the fixnum (ash 1 (- shift)))))))
155 shift)
156 (ash len shift)))))))
157
158
159 ;;; MAP-ALLOCATED-OBJECTS -- Interface
160 ;;;
161 ;;; Iterate over all the objects allocated in Space, calling Fun with the
162 ;;; object, the object's type code, and the objects total size in bytes,
163 ;;; including any header and padding.
164 ;;;
165 (proclaim '(maybe-inline map-allocated-objects))
166 (defun map-allocated-objects (fun space)
167 (declare (type function fun) (type spaces space))
168 (multiple-value-bind (start end)
169 (space-bounds space)
170 (declare (optimize (speed 3) (safety 0)))
171 (let ((current start)
172 (prev nil))
173 (loop
174 (let* ((header (sap-ref-32 current 0))
175 (header-type (logand header #xFF))
176 (info (svref *room-info* header-type)))
177 (cond
178 ((or (not info)
179 (eq (room-info-kind info) :lowtag))
180 (let ((size (* cons-size word-bytes)))
181 (funcall fun
182 (make-lisp-obj (logior (sap-int current)
183 list-pointer-type))
184 list-pointer-type
185 size)
186 (setq current (sap+ current size))))
187 ((eql header-type closure-header-type)
188 (let* ((obj (make-lisp-obj (logior (sap-int current)
189 function-pointer-type)))
190 (size (round-to-dualword
191 (* (the fixnum (1+ (get-closure-length obj)))
192 word-bytes))))
193 (funcall fun obj header-type size)
194 (setq current (sap+ current size))))
195 ((eq (room-info-kind info) :structure)
196 (let* ((obj (make-lisp-obj
197 (logior (sap-int current) structure-pointer-type)))
198 (size (round-to-dualword
199 (* (+ (c::structure-length obj) 1) word-bytes))))
200 (declare (fixnum size))
201 (funcall fun obj header-type size)
202 (assert (zerop (logand size lowtag-mask)))
203 (when (> size 200000) (break "Implausible size, prev ~S" prev))
204 (setq prev current)
205 (setq current (sap+ current size))))
206 (t
207 (let* ((obj (make-lisp-obj
208 (logior (sap-int current) other-pointer-type)))
209 (size (ecase (room-info-kind info)
210 (:fixed
211 (assert (or (eql (room-info-length info)
212 (1+ (get-header-data obj)))
213 (floatp obj)))
214 (round-to-dualword
215 (* (room-info-length info) word-bytes)))
216 ((:vector :string)
217 (vector-total-size obj info))
218 (:header
219 (round-to-dualword
220 (* (1+ (get-header-data obj)) word-bytes)))
221 (:code
222 (+ (the fixnum
223 (* (get-header-data obj) word-bytes))
224 (round-to-dualword
225 (* (the fixnum
226 (%primitive code-code-size obj))
227 word-bytes)))))))
228 (declare (fixnum size))
229 (funcall fun obj header-type size)
230 (assert (zerop (logand size lowtag-mask)))
231 (when (> size 200000) (break "Implausible size, prev ~S" prev))
232 (setq prev current)
233 (setq current (sap+ current size))))))
234 (unless (pointer< current end)
235 (assert (not (pointer> current end)))
236 (return)))
237
238 prev)))
239
240
241 ;;;; MEMORY-USAGE:
242
243 ;;; TYPE-BREAKDOWN -- Interface
244 ;;;
245 ;;; Return a list of 3-lists (bytes object type-name) for the objects
246 ;;; allocated in Space.
247 ;;;
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)))
254 (incf (aref sizes type) size)
255 (incf (aref counts type)))
256 space)
257
258 (let ((totals (make-hash-table :test #'eq)))
259 (dotimes (i 256)
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)))
265 (cond (found
266 (incf (first found) total-size)
267 (incf (second found) total-count))
268 (t
269 (setf (gethash name totals)
270 (list total-size total-count name))))))))
271
272 (collect ((totals-list))
273 (maphash #'(lambda (k v)
274 (declare (ignore k))
275 (totals-list v))
276 totals)
277 (sort (totals-list) #'> :key #'first)))))
278
279
280 ;;; PRINT-SUMMARY -- Internal
281 ;;;
282 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
283 ;;; (space-name . totals-for-space), where totals-for-space is the list
284 ;;; returned by TYPE-BREAKDOWN.
285 ;;;
286 (defun print-summary (spaces totals)
287 (let ((summary (make-hash-table :test #'eq)))
288 (dolist (space-total totals)
289 (dolist (total (cdr space-total))
290 (push (cons (car space-total) total)
291 (gethash (third total) summary))))
292
293 (collect ((summary-totals))
294 (maphash #'(lambda (k v)
295 (declare (ignore k))
296 (let ((sum 0))
297 (declare (fixnum sum))
298 (dolist (space-total v)
299 (incf sum (first (cdr space-total))))
300 (summary-totals (cons sum v))))
301 summary)
302
303 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
304 (let ((summary-total-bytes 0)
305 (summary-total-objects 0))
306 (declare (fixnum summary-total-bytes summary-total-objects))
307 (dolist (space-totals
308 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
309 (let ((total-objects 0)
310 (total-bytes 0)
311 name)
312 (declare (fixnum total-objects total-bytes))
313 (collect ((spaces))
314 (dolist (space-total space-totals)
315 (let ((total (cdr space-total)))
316 (setq name (third total))
317 (incf total-bytes (first total))
318 (incf total-objects (second total))
319 (spaces (cons (car space-total) (first total)))))
320 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
321 name total-bytes total-objects)
322 (dolist (space (spaces))
323 (format t ", ~D% ~(~A~)"
324 (round (* (cdr space) 100) total-bytes)
325 (car space)))
326 (format t ".~%")
327 (incf summary-total-bytes total-bytes)
328 (incf summary-total-objects total-objects))))
329 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
330 summary-total-bytes summary-total-objects)))))
331
332
333 ;;; MEMORY-USAGE -- Public
334 ;;;
335 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
336 (print-summary t))
337 "Print out information about the heap memory in use. :Print-Spaces is a list
338 of the spaces to print detailed information for. :Count-Spaces is a list of
339 the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
340 and :Read-Only.) If :Print-Summary is true, then summary information will be
341 printed. The defaults print only summary information for dynamic space."
342 (let* ((spaces (if (eq count-spaces t)
343 '(:static :dynamic :read-only)
344 count-spaces))
345 (totals (mapcar #'(lambda (space)
346 (cons space (type-breakdown space)))
347 spaces)))
348
349 (dolist (space-total totals)
350 (when (or (eq print-spaces t)
351 (member (car space-total) print-spaces))
352 (format t "~2&Breakdown for ~(~A~) space:~2%" (car space-total))
353 (let ((total-objects 0)
354 (total-bytes 0))
355 (declare (fixnum total-objects total-bytes))
356 (dolist (total (cdr space-total))
357 (incf total-bytes (first total))
358 (incf total-objects (second total))
359 (format t "~%~A:~% ~:D bytes, ~:D object~:P.~%"
360 (third total) (first total) (second total)))
361 (format t "~%Space total:~% ~:D bytes, ~:D object~:P.~%"
362 total-bytes total-objects))))
363
364 (when print-summary (print-summary spaces totals)))
365
366 (values))
367
368
369 ;;; COUNT-NO-OPS -- Public
370 ;;;
371 (defun count-no-ops (space)
372 "Print info about how much code and no-ops there are in Space."
373 (declare (type spaces space))
374 (let ((code-words 0)
375 (no-ops 0)
376 (total-bytes 0))
377 (declare (fixnum code-words no-ops)
378 (type unsigned-byte total-bytes))
379 (map-allocated-objects
380 #'(lambda (obj type size)
381 (declare (fixnum size) (optimize (speed 3) (safety 0)))
382 (when (eql type code-header-type)
383 (incf total-bytes size)
384 (let ((words (truly-the fixnum (%primitive code-code-size obj)))
385 (sap (truly-the system-area-pointer
386 (%primitive code-instructions obj))))
387 (incf code-words words)
388 (dotimes (i words)
389 (when (zerop (sap-ref-32 sap i)) (incf no-ops))))))
390 space)
391
392 (format t
393 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
394 total-bytes code-words no-ops
395 (round (* no-ops 100) code-words)))
396
397 (values))
398
399
400 ;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE -- Public
401 ;;;
402 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
403 (let ((descriptor-words 0)
404 (non-descriptor-headers 0)
405 (non-descriptor-bytes 0))
406 (declare (type unsigned-byte descriptor-words non-descriptor-headers
407 non-descriptor-bytes))
408 (dolist (space (or spaces '(:read-only :static :dynamic)))
409 (declare (inline map-allocated-objects))
410 (map-allocated-objects
411 #'(lambda (obj type size)
412 (declare (fixnum size) (optimize (speed 3) (safety 0)))
413 (case type
414 (#.code-header-type
415 (let ((inst-words
416 (truly-the fixnum (%primitive code-code-size obj))))
417 (declare (type fixnum inst-words))
418 (incf non-descriptor-bytes (* inst-words word-bytes))
419 (incf descriptor-words
420 (- (truncate size word-bytes) inst-words))))
421 ((#.bignum-type
422 #.single-float-type
423 #.double-float-type
424 #.simple-string-type
425 #.simple-bit-vector-type
426 #.simple-array-unsigned-byte-2-type
427 #.simple-array-unsigned-byte-4-type
428 #.simple-array-unsigned-byte-8-type
429 #.simple-array-unsigned-byte-16-type
430 #.simple-array-unsigned-byte-32-type
431 #.simple-array-single-float-type
432 #.simple-array-double-float-type)
433 (incf non-descriptor-headers)
434 (incf non-descriptor-bytes (- size word-bytes)))
435 ((#.list-pointer-type
436 #.structure-pointer-type
437 #.ratio-type
438 #.complex-type
439 #.simple-array-type
440 #.simple-vector-type
441 #.complex-string-type
442 #.complex-bit-vector-type
443 #.complex-vector-type
444 #.complex-array-type
445 #.closure-header-type
446 #.funcallable-instance-header-type
447 #.value-cell-header-type
448 #.symbol-header-type
449 #.sap-type
450 #.weak-pointer-type
451 #.structure-header-type)
452 (incf descriptor-words (truncate size word-bytes)))
453 (t
454 (error "Bogus type: ~D" type))))
455 space))
456 (format t "~:D words allocated for descriptor objects.~%"
457 descriptor-words)
458 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
459 non-descriptor-bytes non-descriptor-headers)
460 (values)))
461
462
463 ;;; STRUCTURE-USAGE -- Public
464 ;;;
465 (defun structure-usage (space &key (top-n 15))
466 (declare (type spaces space) (type (or fixnum null) top-n))
467 "Print a breakdown by structure type of all the structures allocated in
468 Space. If TOP-N is true, print only information for the the TOP-N types with
469 largest usage."
470 (let ((totals (make-hash-table :test #'eq))
471 (total-objects 0)
472 (total-bytes 0))
473 (declare (fixnum total-objects total-bytes))
474 (map-allocated-objects
475 #'(lambda (obj type size)
476 (declare (fixnum size) (optimize (speed 3) (safety 0)))
477 (when (eql type structure-header-type)
478 (incf total-objects)
479 (incf total-bytes size)
480 (let* ((name (structure-ref obj 0))
481 (found (gethash name totals)))
482 (cond (found
483 (incf (the fixnum (car found)))
484 (incf (the fixnum (cdr found)) size))
485 (t
486 (setf (gethash name totals) (cons 1 size)))))))
487 space)
488
489 (collect ((totals-list))
490 (maphash #'(lambda (name what)
491 (totals-list (cons name what)))
492 totals)
493 (let ((sorted (sort (totals-list) #'> :key #'cddr))
494 (printed-bytes 0)
495 (printed-objects 0))
496 (declare (fixnum printed-bytes printed-objects))
497 (dolist (what (if top-n
498 (subseq sorted 0 (min (length sorted) top-n))
499 sorted))
500 (let ((bytes (cddr what))
501 (objects (cadr what)))
502 (incf printed-bytes bytes)
503 (incf printed-objects objects)
504 (format t "~S: ~:D bytes, ~D object~:P.~%" (car what)
505 bytes objects)))
506
507 (let ((residual-objects (- total-objects printed-objects))
508 (residual-bytes (- total-bytes printed-bytes)))
509 (unless (zerop residual-objects)
510 (format t "Other types: ~:D bytes, ~D: object~:P.~%"
511 residual-bytes residual-objects))))
512
513 (format t "Structure total: ~:D bytes, ~:D object~:P.~%"
514 total-bytes total-objects)))
515
516 (values))
517
518
519 ;;; FIND-HOLES -- Public
520 ;;;
521 (defun find-holes (&rest spaces)
522 (dolist (space (or spaces '(:read-only :static :dynamic)))
523 (format t "In ~A space:~%" space)
524 (let ((start-addr nil)
525 (total-bytes 0))
526 (declare (type (or null (unsigned-byte 32)) start-addr)
527 (type (unsigned-byte 32) total-bytes))
528 (map-allocated-objects
529 #'(lambda (object typecode bytes)
530 (declare (ignore typecode)
531 (type (unsigned-byte 32) bytes))
532 (if (and (consp object)
533 (eql (car object) 0)
534 (eql (cdr object) 0))
535 (if start-addr
536 (incf total-bytes bytes)
537 (setf start-addr (di::get-lisp-obj-address object)
538 total-bytes bytes))
539 (when start-addr
540 (format t "~D bytes at #x~X~%" total-bytes start-addr)
541 (setf start-addr nil))))
542 space)
543 (when start-addr
544 (format t "~D bytes at #x~X~%" total-bytes start-addr))))
545 (values))
546
547
548 ;;; Print allocated objects:
549
550 (defun pagesize ()
551 (nth-value 1 (mach:vm_statistics system:*task-self*)))
552
553 (defun print-allocated-objects (space &key (percent 0) (pages 5)
554 (stream *standard-output*))
555 (declare (type (integer 0 99) percent) (type c::index pages)
556 (type stream stream) (type spaces space))
557 (multiple-value-bind (start-sap end-sap)
558 (space-bounds space)
559 (let* ((space-start (sap-int start-sap))
560 (space-end (sap-int end-sap))
561 (space-size (- space-end space-start))
562 (pagesize (pagesize))
563 (start (+ space-start (round (* space-size percent) 100)))
564 (pages-so-far 0)
565 (last-page 0))
566 (declare (type (unsigned-byte 32) last-page start)
567 (fixnum pages-so-far pagesize))
568 (map-allocated-objects
569 #'(lambda (obj type size)
570 (declare (ignore size) (optimize (speed 3) (safety 0)))
571 (let ((addr (get-lisp-obj-address obj)))
572 (when (and (>= addr start)
573 (<= pages-so-far pages))
574 (let ((this-page (* (the (unsigned-byte 32)
575 (truncate addr pagesize))
576 pagesize)))
577 (declare (type (unsigned-byte 32) this-page))
578 (when (/= this-page last-page)
579 (when (< pages-so-far pages)
580 (format stream "~2&**** Page ~D, address ~X:~%"
581 pages-so-far addr))
582 (setq last-page this-page)
583 (incf pages-so-far)))
584
585 (case type
586 (#.code-header-type
587 (let ((dinfo (code-debug-info obj)))
588 (format stream "~&Code object: ~S~%"
589 (if dinfo
590 (c::compiled-debug-info-name dinfo)
591 "No debug info."))))
592 (#.symbol-header-type
593 (format stream "~&~S~%" obj))
594 (#.list-pointer-type
595 (write-char #\. stream))
596 (t
597 (fresh-line stream)
598 (let ((str (write-to-string obj :level 5 :length 10
599 :pretty nil)))
600 (unless (eql type structure-header-type)
601 (format stream "~S: " (type-of obj)))
602 (format stream "~A~%"
603 (subseq str 0 (min (length str) 60)))))))))
604 space)))
605 (values))
606
607 ;;;; Misc:
608
609 (defun uninterned-symbol-count (space)
610 (declare (type spaces space))
611 (let ((total 0)
612 (uninterned 0))
613 (map-allocated-objects
614 #'(lambda (obj type size)
615 (declare (ignore type size))
616 (when (symbolp obj)
617 (incf total)
618 (unless (symbol-package obj)
619 (incf uninterned))))
620 space)
621 (values uninterned (float (/ uninterned total)))))
622
623 (defun code-package-breakdown (space)
624 (let ((info (make-hash-table :test #'equal)))
625 (map-allocated-objects
626 #'(lambda (obj type size)
627 (when (eql type code-header-type)
628 (let* ((dinfo (code-debug-info obj))
629 (name (if dinfo
630 (c::compiled-debug-info-package dinfo)
631 "UNKNOWN"))
632 (found (or (gethash name info)
633 (setf (gethash name info) (cons 0 0)))))
634 (incf (car found))
635 (incf (cdr found) size))))
636 space)
637
638 (collect ((res))
639 (maphash #'(lambda (k v)
640 (res (list v k)))
641 info)
642 (loop for ((count . size) name) in (sort (res) #'> :key #'cdar) do
643 (format t "~20@A: ~:D bytes, ~:D objects.~%" name size count))))

  ViewVC Help
Powered by ViewVC 1.1.5