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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18.1.2 - (show annotations) (vendor branch)
Wed Feb 10 23:41:16 1993 UTC (21 years, 2 months ago) by ram
Branch: new_struct
Changes since 1.18.1.1: +4 -4 lines
fix paren lossage
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.18.1.2 1993/02/10 23:41:16 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Heap grovelling memory usage stuff.
15 ;;;
16 (in-package "VM")
17 (use-package "SYSTEM")
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 (in-package "LISP")
22 (import '(
23 dynamic-0-space-start dynamic-1-space-start read-only-space-start
24 static-space-start current-dynamic-space-start
25 *static-space-free-pointer* *read-only-space-free-pointer*)
26 "VM")
27 (in-package "VM")
28
29
30 ;;;; Type format database.
31
32 (defstruct room-info
33 ;;
34 ;; The name of this type.
35 (name nil :type symbol)
36 ;;
37 ;; Kind of type (how we determine length).
38 (kind (required-argument)
39 :type (member :lowtag :fixed :header :vector
40 :string :code :closure :instance))
41 ;;
42 ;; Length if fixed-length, shift amount for element size if :vector.
43 (length nil :type (or fixnum null)))
44
45 (defvar *room-info* (make-array 256 :initial-element nil))
46
47
48 (dolist (obj *primitive-objects*)
49 (let ((header (primitive-object-header obj))
50 (lowtag (primitive-object-lowtag obj))
51 (name (primitive-object-name obj))
52 (variable (primitive-object-variable-length obj))
53 (size (primitive-object-size obj)))
54 (cond
55 ((not lowtag))
56 ((not header)
57 (let ((info (make-room-info :name name :kind :lowtag))
58 (lowtag (symbol-value lowtag)))
59 (declare (fixnum lowtag))
60 (dotimes (i 32)
61 (setf (svref *room-info* (logior lowtag (ash i 3))) info))))
62 (variable)
63 (t
64 (setf (svref *room-info* (symbol-value header))
65 (make-room-info :name name :kind :fixed :length size))))))
66
67 (dolist (code (list complex-string-type simple-array-type
68 complex-bit-vector-type complex-vector-type
69 complex-array-type))
70 (setf (svref *room-info* code)
71 (make-room-info :name 'array-header :kind :header)))
72
73 (setf (svref *room-info* bignum-type)
74 (make-room-info :name 'bignum :kind :header))
75
76 (setf (svref *room-info* closure-header-type)
77 (make-room-info :name 'closure :kind :closure))
78
79 (dolist (stuff '((simple-bit-vector-type . -3)
80 (simple-vector-type . 2)
81 (simple-array-unsigned-byte-2-type . -2)
82 (simple-array-unsigned-byte-4-type . -1)
83 (simple-array-unsigned-byte-8-type . 0)
84 (simple-array-unsigned-byte-16-type . 1)
85 (simple-array-unsigned-byte-32-type . 2)
86 (simple-array-single-float-type . 2)
87 (simple-array-double-float-type . 3)))
88 (let ((name (car stuff))
89 (size (cdr stuff)))
90 (setf (svref *room-info* (symbol-value name))
91 (make-room-info :name name :kind :vector :length size))))
92
93 (setf (svref *room-info* simple-string-type)
94 (make-room-info :name 'simple-string-type :kind :string :length 0))
95
96 (setf (svref *room-info* code-header-type)
97 (make-room-info :name 'code :kind :code))
98
99 (setf (svref *room-info* instance-header-type)
100 (make-room-info :name 'instance :kind :instance))
101
102 (deftype spaces () '(member :static :dynamic :read-only))
103
104
105 ;;;; MAP-ALLOCATED-OBJECTS:
106
107 (proclaim '(type fixnum *static-space-free-pointer*
108 *read-only-space-free-pointer* ))
109
110 (defun space-bounds (space)
111 (declare (type spaces space))
112 (ecase space
113 (:static
114 (values (int-sap (static-space-start))
115 (int-sap (* *static-space-free-pointer* word-bytes))))
116 (:read-only
117 (values (int-sap (read-only-space-start))
118 (int-sap (* *read-only-space-free-pointer* word-bytes))))
119 (:dynamic
120 (values (int-sap (current-dynamic-space-start))
121 (dynamic-space-free-pointer)))))
122
123 ;;; SPACE-BYTES -- Internal
124 ;;;
125 ;;; Return the total number of bytes used in Space.
126 ;;;
127 (defun space-bytes (space)
128 (multiple-value-bind (start end)
129 (space-bounds space)
130 (- (sap-int end) (sap-int start))))
131
132 ;;; ROUND-TO-DUALWORD -- Internal
133 ;;;
134 ;;; Round Size (in bytes) up to the next dualword (eight byte) boundry.
135 ;;;
136 (proclaim '(inline round-to-dualword))
137 (defun round-to-dualword (size)
138 (declare (fixnum size))
139 (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
140
141
142 ;;; VECTOR-TOTAL-SIZE -- Internal
143 ;;;
144 ;;; Return the total size of a vector in bytes, including any pad.
145 ;;;
146 (proclaim '(inline vector-total-size))
147 (defun vector-total-size (obj info)
148 (let ((shift (room-info-length info))
149 (len (+ (length (the (simple-array * (*)) obj))
150 (ecase (room-info-kind info)
151 (:vector 0)
152 (:string 1)))))
153 (declare (type (integer -3 3) shift))
154 (round-to-dualword
155 (+ (* vector-data-offset word-bytes)
156 (the fixnum
157 (if (minusp shift)
158 (ash (the fixnum
159 (+ len (the fixnum
160 (1- (the fixnum (ash 1 (- shift)))))))
161 shift)
162 (ash len shift)))))))
163
164
165 ;;; MAP-ALLOCATED-OBJECTS -- Interface
166 ;;;
167 ;;; Iterate over all the objects allocated in Space, calling Fun with the
168 ;;; object, the object's type code, and the objects total size in bytes,
169 ;;; including any header and padding.
170 ;;;
171 (proclaim '(maybe-inline map-allocated-objects))
172 (defun map-allocated-objects (fun space)
173 (declare (type function fun) (type spaces space))
174 (without-gcing
175 (multiple-value-bind (start end)
176 (space-bounds space)
177 (declare (type system-area-pointer start end))
178 (declare (optimize (speed 3) (safety 0)))
179 (let ((current start)
180 #+nil
181 (prev nil))
182 (loop
183 (let* ((header (sap-ref-32 current 0))
184 (header-type (logand header #xFF))
185 (info (svref *room-info* header-type)))
186 (cond
187 ((or (not info)
188 (eq (room-info-kind info) :lowtag))
189 (let ((size (* cons-size word-bytes)))
190 (funcall fun
191 (make-lisp-obj (logior (sap-int current)
192 list-pointer-type))
193 list-pointer-type
194 size)
195 (setq current (sap+ current size))))
196 ((eql header-type closure-header-type)
197 (let* ((obj (make-lisp-obj (logior (sap-int current)
198 function-pointer-type)))
199 (size (round-to-dualword
200 (* (the fixnum (1+ (get-closure-length obj)))
201 word-bytes))))
202 (funcall fun obj header-type size)
203 (setq current (sap+ current size))))
204 ((eq (room-info-kind info) :instance)
205 (let* ((obj (make-lisp-obj
206 (logior (sap-int current) instance-pointer-type)))
207 (size (round-to-dualword
208 (* (+ (%instance-length obj) 1) word-bytes))))
209 (declare (fixnum size))
210 (funcall fun obj header-type size)
211 (assert (zerop (logand size lowtag-mask)))
212 #+nil
213 (when (> size 200000) (break "Implausible size, prev ~S" prev))
214 #+nil
215 (setq prev current)
216 (setq current (sap+ current size))))
217 (t
218 (let* ((obj (make-lisp-obj
219 (logior (sap-int current) other-pointer-type)))
220 (size (ecase (room-info-kind info)
221 (:fixed
222 (assert (or (eql (room-info-length info)
223 (1+ (get-header-data obj)))
224 (floatp obj)))
225 (round-to-dualword
226 (* (room-info-length info) word-bytes)))
227 ((:vector :string)
228 (vector-total-size obj info))
229 (:header
230 (round-to-dualword
231 (* (1+ (get-header-data obj)) word-bytes)))
232 (:code
233 (+ (the fixnum
234 (* (get-header-data obj) word-bytes))
235 (round-to-dualword
236 (* (the fixnum (%code-code-size obj))
237 word-bytes)))))))
238 (declare (fixnum size))
239 (funcall fun obj header-type size)
240 (assert (zerop (logand size lowtag-mask)))
241 #+nil
242 (when (> size 200000)
243 (break "Implausible size, prev ~S" prev))
244 #+nil
245 (setq prev current)
246 (setq current (sap+ current size))))))
247 (unless (sap< current end)
248 (assert (sap= current end))
249 (return)))
250
251 #+nil
252 prev))))
253
254
255 ;;;; MEMORY-USAGE:
256
257 ;;; TYPE-BREAKDOWN -- Interface
258 ;;;
259 ;;; Return a list of 3-lists (bytes object type-name) for the objects
260 ;;; allocated in Space.
261 ;;;
262 (defun type-breakdown (space)
263 (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
264 (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
265 (map-allocated-objects
266 #'(lambda (obj type size)
267 (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
268 (incf (aref sizes type) size)
269 (incf (aref counts type)))
270 space)
271
272 (let ((totals (make-hash-table :test #'eq)))
273 (dotimes (i 256)
274 (let ((total-count (aref counts i)))
275 (unless (zerop total-count)
276 (let* ((total-size (aref sizes i))
277 (name (room-info-name (aref *room-info* i)))
278 (found (gethash name totals)))
279 (cond (found
280 (incf (first found) total-size)
281 (incf (second found) total-count))
282 (t
283 (setf (gethash name totals)
284 (list total-size total-count name))))))))
285
286 (collect ((totals-list))
287 (maphash #'(lambda (k v)
288 (declare (ignore k))
289 (totals-list v))
290 totals)
291 (sort (totals-list) #'> :key #'first)))))
292
293
294 ;;; PRINT-SUMMARY -- Internal
295 ;;;
296 ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
297 ;;; (space-name . totals-for-space), where totals-for-space is the list
298 ;;; returned by TYPE-BREAKDOWN.
299 ;;;
300 (defun print-summary (spaces totals)
301 (let ((summary (make-hash-table :test #'eq)))
302 (dolist (space-total totals)
303 (dolist (total (cdr space-total))
304 (push (cons (car space-total) total)
305 (gethash (third total) summary))))
306
307 (collect ((summary-totals))
308 (maphash #'(lambda (k v)
309 (declare (ignore k))
310 (let ((sum 0))
311 (declare (fixnum sum))
312 (dolist (space-total v)
313 (incf sum (first (cdr space-total))))
314 (summary-totals (cons sum v))))
315 summary)
316
317 (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
318 (let ((summary-total-bytes 0)
319 (summary-total-objects 0))
320 (declare (fixnum summary-total-bytes summary-total-objects))
321 (dolist (space-totals
322 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
323 (let ((total-objects 0)
324 (total-bytes 0)
325 name)
326 (declare (fixnum total-objects total-bytes))
327 (collect ((spaces))
328 (dolist (space-total space-totals)
329 (let ((total (cdr space-total)))
330 (setq name (third total))
331 (incf total-bytes (first total))
332 (incf total-objects (second total))
333 (spaces (cons (car space-total) (first total)))))
334 (format t "~%~A:~% ~:D bytes, ~:D object~:P"
335 name total-bytes total-objects)
336 (dolist (space (spaces))
337 (format t ", ~D% ~(~A~)"
338 (round (* (cdr space) 100) total-bytes)
339 (car space)))
340 (format t ".~%")
341 (incf summary-total-bytes total-bytes)
342 (incf summary-total-objects total-objects))))
343 (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
344 summary-total-bytes summary-total-objects)))))
345
346
347 ;;; REPORT-SPACE-TOTAL -- Internal
348 ;;;
349 ;;; Report object usage for a single space.
350 ;;;
351 (defun report-space-total (space-total cutoff)
352 (declare (list space-total) (type (or single-float null) cutoff))
353 (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
354 (let* ((types (cdr space-total))
355 (total-bytes (reduce #'+ (mapcar #'first types)))
356 (total-objects (reduce #'+ (mapcar #'second types)))
357 (cutoff-point (if cutoff
358 (truncate (* (float total-bytes) cutoff))
359 0))
360 (reported-bytes 0)
361 (reported-objects 0))
362 (declare (fixnum total-objects total-bytes cutoff-point reported-objects
363 reported-bytes))
364 (loop for (bytes objects name) in types do
365 (when (<= bytes cutoff-point)
366 (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
367 (- total-bytes reported-bytes)
368 (- total-objects reported-objects))
369 (return))
370 (incf reported-bytes bytes)
371 (incf reported-objects objects)
372 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
373 bytes objects name))
374 (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
375 total-bytes total-objects (car space-total))))
376
377
378 ;;; MEMORY-USAGE -- Public
379 ;;;
380 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
381 (print-summary t) cutoff)
382 "Print out information about the heap memory in use. :Print-Spaces is a list
383 of the spaces to print detailed information for. :Count-Spaces is a list of
384 the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
385 and :Read-Only.) If :Print-Summary is true, then summary information will be
386 printed. The defaults print only summary information for dynamic space.
387 If true, Cutoff is a fraction of the usage in a report below which types will
388 be combined as OTHER."
389 (declare (type (or single-float null) cutoff))
390 (let* ((spaces (if (eq count-spaces t)
391 '(:static :dynamic :read-only)
392 count-spaces))
393 (totals (mapcar #'(lambda (space)
394 (cons space (type-breakdown space)))
395 spaces)))
396
397 (dolist (space-total totals)
398 (when (or (eq print-spaces t)
399 (member (car space-total) print-spaces))
400 (report-space-total space-total cutoff)))
401
402 (when print-summary (print-summary spaces totals)))
403
404 (values))
405
406
407 ;;; COUNT-NO-OPS -- Public
408 ;;;
409 (defun count-no-ops (space)
410 "Print info about how much code and no-ops there are in Space."
411 (declare (type spaces space))
412 (let ((code-words 0)
413 (no-ops 0)
414 (total-bytes 0))
415 (declare (fixnum code-words no-ops)
416 (type unsigned-byte total-bytes))
417 (map-allocated-objects
418 #'(lambda (obj type size)
419 (declare (fixnum size) (optimize (safety 0)))
420 (when (eql type code-header-type)
421 (incf total-bytes size)
422 (let ((words (truly-the fixnum (%code-code-size obj)))
423 (sap (truly-the system-area-pointer
424 (%primitive code-instructions obj))))
425 (incf code-words words)
426 (dotimes (i words)
427 (when (zerop (sap-ref-32 sap (* i vm:word-bytes)))
428 (incf no-ops))))))
429 space)
430
431 (format t
432 "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
433 total-bytes code-words no-ops
434 (round (* no-ops 100) code-words)))
435
436 (values))
437
438
439 ;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE -- Public
440 ;;;
441 (defun descriptor-vs-non-descriptor-storage (&rest spaces)
442 (let ((descriptor-words 0)
443 (non-descriptor-headers 0)
444 (non-descriptor-bytes 0))
445 (declare (type unsigned-byte descriptor-words non-descriptor-headers
446 non-descriptor-bytes))
447 (dolist (space (or spaces '(:read-only :static :dynamic)))
448 (declare (inline map-allocated-objects))
449 (map-allocated-objects
450 #'(lambda (obj type size)
451 (declare (fixnum size) (optimize (safety 0)))
452 (case type
453 (#.code-header-type
454 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
455 (declare (type fixnum inst-words))
456 (incf non-descriptor-bytes (* inst-words word-bytes))
457 (incf descriptor-words
458 (- (truncate size word-bytes) inst-words))))
459 ((#.bignum-type
460 #.single-float-type
461 #.double-float-type
462 #.simple-string-type
463 #.simple-bit-vector-type
464 #.simple-array-unsigned-byte-2-type
465 #.simple-array-unsigned-byte-4-type
466 #.simple-array-unsigned-byte-8-type
467 #.simple-array-unsigned-byte-16-type
468 #.simple-array-unsigned-byte-32-type
469 #.simple-array-single-float-type
470 #.simple-array-double-float-type)
471 (incf non-descriptor-headers)
472 (incf non-descriptor-bytes (- size word-bytes)))
473 ((#.list-pointer-type
474 #.instance-pointer-type
475 #.ratio-type
476 #.complex-type
477 #.simple-array-type
478 #.simple-vector-type
479 #.complex-string-type
480 #.complex-bit-vector-type
481 #.complex-vector-type
482 #.complex-array-type
483 #.closure-header-type
484 #.funcallable-instance-header-type
485 #.value-cell-header-type
486 #.symbol-header-type
487 #.sap-type
488 #.weak-pointer-type
489 #.instance-header-type)
490 (incf descriptor-words (truncate size word-bytes)))
491 (t
492 (error "Bogus type: ~D" type))))
493 space))
494 (format t "~:D words allocated for descriptor objects.~%"
495 descriptor-words)
496 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
497 non-descriptor-bytes non-descriptor-headers)
498 (values)))
499
500
501 ;;; INSTANCE-USAGE -- Public
502 ;;;
503 (defun instance-usage (space &key (top-n 15))
504 (declare (type spaces space) (type (or fixnum null) top-n))
505 "Print a breakdown by instance type of all the instances allocated in
506 Space. If TOP-N is true, print only information for the the TOP-N types with
507 largest usage."
508 (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
509 (let ((totals (make-hash-table :test #'eq))
510 (total-objects 0)
511 (total-bytes 0))
512 (declare (fixnum total-objects total-bytes))
513 (map-allocated-objects
514 #'(lambda (obj type size)
515 (declare (fixnum size) (optimize (speed 3) (safety 0)))
516 (when (eql type instance-header-type)
517 (incf total-objects)
518 (incf total-bytes size)
519 (let* ((class (layout-class (%instance-ref obj 0)))
520 (found (gethash class totals)))
521 (cond (found
522 (incf (the fixnum (car found)))
523 (incf (the fixnum (cdr found)) size))
524 (t
525 (setf (gethash class totals) (cons 1 size)))))))
526 space)
527
528 (collect ((totals-list))
529 (maphash #'(lambda (class what)
530 (totals-list (cons (prin1-to-string
531 (class-proper-name class))
532 what)))
533 totals)
534 (let ((sorted (sort (totals-list) #'> :key #'cddr))
535 (printed-bytes 0)
536 (printed-objects 0))
537 (declare (fixnum printed-bytes printed-objects))
538 (dolist (what (if top-n
539 (subseq sorted 0 (min (length sorted) top-n))
540 sorted))
541 (let ((bytes (cddr what))
542 (objects (cadr what)))
543 (incf printed-bytes bytes)
544 (incf printed-objects objects)
545 (format t " ~A: ~:D bytes, ~D object~:P.~%" (car what)
546 bytes objects)))
547
548 (let ((residual-objects (- total-objects printed-objects))
549 (residual-bytes (- total-bytes printed-bytes)))
550 (unless (zerop residual-objects)
551 (format t " Other types: ~:D bytes, ~D: object~:P.~%"
552 residual-bytes residual-objects))))
553
554 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
555 space total-bytes total-objects)))
556
557 (values))
558
559
560 ;;; FIND-HOLES -- Public
561 ;;;
562 (defun find-holes (&rest spaces)
563 (dolist (space (or spaces '(:read-only :static :dynamic)))
564 (format t "In ~A space:~%" space)
565 (let ((start-addr nil)
566 (total-bytes 0))
567 (declare (type (or null (unsigned-byte 32)) start-addr)
568 (type (unsigned-byte 32) total-bytes))
569 (map-allocated-objects
570 #'(lambda (object typecode bytes)
571 (declare (ignore typecode)
572 (type (unsigned-byte 32) bytes))
573 (if (and (consp object)
574 (eql (car object) 0)
575 (eql (cdr object) 0))
576 (if start-addr
577 (incf total-bytes bytes)
578 (setf start-addr (di::get-lisp-obj-address object)
579 total-bytes bytes))
580 (when start-addr
581 (format t "~D bytes at #x~X~%" total-bytes start-addr)
582 (setf start-addr nil))))
583 space)
584 (when start-addr
585 (format t "~D bytes at #x~X~%" total-bytes start-addr))))
586 (values))
587
588
589 ;;; Print allocated objects:
590
591 (defun print-allocated-objects (space &key (percent 0) (pages 5)
592 type larger smaller count
593 (stream *standard-output*))
594 (declare (type (integer 0 99) percent) (type c::index pages)
595 (type stream stream) (type spaces space)
596 (type (or c::index null) type larger smaller count))
597 (multiple-value-bind (start-sap end-sap)
598 (space-bounds space)
599 (let* ((space-start (sap-int start-sap))
600 (space-end (sap-int end-sap))
601 (space-size (- space-end space-start))
602 (pagesize (system:get-page-size))
603 (start (+ space-start (round (* space-size percent) 100)))
604 (pages-so-far 0)
605 (count-so-far 0)
606 (last-page 0))
607 (declare (type (unsigned-byte 32) last-page start)
608 (fixnum pages-so-far count-so-far pagesize))
609 (map-allocated-objects
610 #'(lambda (obj obj-type size)
611 (declare (optimize (safety 0)))
612 (let ((addr (get-lisp-obj-address obj)))
613 (when (>= addr start)
614 (when (if count
615 (> count-so-far count)
616 (> pages-so-far pages))
617 (return-from print-allocated-objects (values)))
618
619 (unless count
620 (let ((this-page (* (the (unsigned-byte 32)
621 (truncate addr pagesize))
622 pagesize)))
623 (declare (type (unsigned-byte 32) this-page))
624 (when (/= this-page last-page)
625 (when (< pages-so-far pages)
626 (format stream "~2&**** Page ~D, address ~X:~%"
627 pages-so-far addr))
628 (setq last-page this-page)
629 (incf pages-so-far))))
630
631 (when (and (or (not type) (eql obj-type type))
632 (or (not smaller) (<= size smaller))
633 (or (not larger) (>= size larger)))
634 (incf count-so-far)
635 (case type
636 (#.code-header-type
637 (let ((dinfo (%code-debug-info obj)))
638 (format stream "~&Code object: ~S~%"
639 (if dinfo
640 (c::compiled-debug-info-name dinfo)
641 "No debug info."))))
642 (#.symbol-header-type
643 (format stream "~&~S~%" obj))
644 (#.list-pointer-type
645 (write-char #\. stream))
646 (t
647 (fresh-line stream)
648 (let ((str (write-to-string obj :level 5 :length 10
649 :pretty nil)))
650 (unless (eql type instance-header-type)
651 (format stream "~S: " (type-of obj)))
652 (format stream "~A~%"
653 (subseq str 0 (min (length str) 60))))))))))
654 space)))
655 (values))
656
657 ;;;; Misc:
658
659 (defun uninterned-symbol-count (space)
660 (declare (type spaces space))
661 (let ((total 0)
662 (uninterned 0))
663 (map-allocated-objects
664 #'(lambda (obj type size)
665 (declare (ignore type size))
666 (when (symbolp obj)
667 (incf total)
668 (unless (symbol-package obj)
669 (incf uninterned))))
670 space)
671 (values uninterned (float (/ uninterned total)))))
672
673
674 (defun code-breakdown (space &key (how :package))
675 (declare (type spaces space) (type (member :file :package) how))
676 (let ((info (make-hash-table :test (if (eq how :package) #'equal #'eq))))
677 (map-allocated-objects
678 #'(lambda (obj type size)
679 (when (eql type code-header-type)
680 (let* ((dinfo (%code-debug-info obj))
681 (name (if dinfo
682 (ecase how
683 (:package (c::compiled-debug-info-package dinfo))
684 (:file
685 (let ((source
686 (first (c::compiled-debug-info-source
687 dinfo))))
688 (if (eq (c::debug-source-from source)
689 :file)
690 (c::debug-source-name source)
691 "FROM LISP"))))
692 "UNKNOWN"))
693 (found (or (gethash name info)
694 (setf (gethash name info) (cons 0 0)))))
695 (incf (car found))
696 (incf (cdr found) size))))
697 space)
698
699 (collect ((res))
700 (maphash #'(lambda (k v)
701 (res (list v k)))
702 info)
703 (loop for ((count . size) name) in (sort (res) #'> :key #'cdar) do
704 (format t "~40@A: ~:D bytes, ~:D object~:P.~%"
705 (subseq name (max (- (length name) 40) 0))
706 size count))))
707 (values))
708
709
710 ;;;; Histogram interface. Uses Scott's Hist package.
711 #+nil
712 (defun memory-histogram (space &key (low 4) (high 20)
713 (bucket-size 1)
714 (function
715 #'(lambda (obj type size)
716 (declare (ignore obj type) (fixnum size))
717 (integer-length (1- size))))
718 (type nil))
719 (let ((function (if (eval:interpreted-function-p function)
720 (compile nil function)
721 function)))
722 (hist:hist (low high bucket-size)
723 (map-allocated-objects
724 #'(lambda (obj this-type size)
725 (when (or (not type) (eql this-type type))
726 (hist:hist-record (funcall function obj type size))))
727 space)))
728 (values))
729
730 ;;; Return the number of fbound constants in a code object.
731 ;;;
732 (defun code-object-calls (obj)
733 (loop for i from code-constants-offset below (get-header-data obj)
734 count (find-code-object (code-header-ref obj i))))
735
736 ;;; Return the number of calls in Obj to functions with <= N calls. Calls is
737 ;;; an eq hashtable translating code objects to the number of references.
738 ;;;
739 (defun code-object-leaf-calls (obj n calls)
740 (loop for i from code-constants-offset below (get-header-data obj)
741 count (let ((code (find-code-object (code-header-ref obj i))))
742 (and code (<= (gethash code calls 0) n)))))
743
744 #+nil
745 (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
746 (function #'identity))
747 "Given a hashtable, print a histogram of the contents. Function should give
748 the value to plot when applied to the hashtable values."
749 (let ((function (if (eval:interpreted-function-p function)
750 (compile nil function)
751 function)))
752 (hist:hist (low high bucket-size)
753 (loop for count being each hash-value in table do
754 (hist:hist-record (funcall function count))))))
755
756 (defun report-top-n (table &key (top-n 20) (function #'identity))
757 "Report the Top-N entries in the hashtable Table, when sorted by Function
758 applied to the hash value. If Top-N is NIL, report all entries."
759 (let ((function (if (eval:interpreted-function-p function)
760 (compile nil function)
761 function)))
762 (collect ((totals-list)
763 (total-val 0 +))
764 (maphash #'(lambda (name what)
765 (let ((val (funcall function what)))
766 (totals-list (cons name val))
767 (total-val val)))
768 table)
769 (let ((sorted (sort (totals-list) #'> :key #'cdr))
770 (printed 0))
771 (declare (fixnum printed))
772 (dolist (what (if top-n
773 (subseq sorted 0 (min (length sorted) top-n))
774 sorted))
775 (let ((val (cdr what)))
776 (incf printed val)
777 (format t "~8:D: ~S~%" val (car what))))
778
779 (let ((residual (- (total-val) printed)))
780 (unless (zerop residual)
781 (format t "~8:D: Other~%" residual))))
782
783 (format t "~8:D: Total~%" (total-val))))
784 (values))
785
786
787 ;;; Given any Lisp object, return the associated code object, or NIL.
788 ;;;
789 (defun find-code-object (const)
790 (flet ((frob (def)
791 (function-code-header
792 (ecase (get-type def)
793 ((#.closure-header-type
794 #.funcallable-instance-header-type)
795 (%closure-function def))
796 (#.function-header-type
797 def)))))
798 (typecase const
799 (function (frob const))
800 (symbol
801 (if (fboundp const)
802 (frob (symbol-function const))
803 nil))
804 (t nil))))
805
806
807 (defun find-caller-counts (space)
808 "Return a hashtable mapping each function in for which a call appears in
809 Space to the number of times such a call appears."
810 (let ((counts (make-hash-table :test #'eq)))
811 (map-allocated-objects
812 #'(lambda (obj type size)
813 (declare (ignore size))
814 (when (eql type code-header-type)
815 (loop for i from code-constants-offset below (get-header-data obj)
816 do (let ((code (find-code-object (code-header-ref obj i))))
817 (when code
818 (incf (gethash code counts 0)))))))
819 space)
820 counts))
821
822 (defun find-high-callers (space &key (above 10) table (threshold 2))
823 "Return a hashtable translating code objects to function constant counts for
824 all code objects in Space with more than Above function constants."
825 (let ((counts (make-hash-table :test #'eq)))
826 (map-allocated-objects
827 #'(lambda (obj type size)
828 (declare (ignore size))
829 (when (eql type code-header-type)
830 (let ((count (if table
831 (code-object-leaf-calls obj threshold table)
832 (code-object-calls obj))))
833 (when (> count above)
834 (setf (gethash obj counts) count)))))
835 space)
836 counts))

  ViewVC Help
Powered by ViewVC 1.1.5