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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5