/[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.1 - (show annotations)
Fri Jun 23 01:09:14 2006 UTC (7 years, 10 months ago) by rtoy
Branch: double-double-array-branch
Changes since 1.34: +18 -3 lines
Tell ROOM about double-double-float, (complex double-double-float),
and simple-array's of these types.
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.1 2006/06/23 01:09:14 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 (incf descriptor-words (truncate size word-bytes)))
530 (t
531 (error "Bogus type: ~D" type))))
532 space))
533 (format t "~:D words allocated for descriptor objects.~%"
534 descriptor-words)
535 (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
536 non-descriptor-bytes non-descriptor-headers)
537 (values)))
538
539
540 ;;; INSTANCE-USAGE -- Public
541 ;;;
542 (defun instance-usage (space &key (top-n 15))
543 (declare (type spaces space) (type (or fixnum null) top-n))
544 "Print a breakdown by instance type of all the instances allocated in
545 Space. If TOP-N is true, print only information for the the TOP-N types with
546 largest usage."
547 (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
548 (let ((totals (make-hash-table :test #'eq))
549 (total-objects 0)
550 (total-bytes 0))
551 (declare (fixnum total-objects)
552 (type memory-size total-bytes))
553 (map-allocated-objects
554 #'(lambda (obj type size)
555 (declare (type memory-size size) (optimize (speed 3) (safety 0)))
556 (when (eql type instance-header-type)
557 (incf total-objects)
558 (incf total-bytes size)
559 (let* ((class (layout-class (%instance-ref obj 0)))
560 (found (gethash class totals)))
561 (cond (found
562 (incf (the fixnum (car found)))
563 (incf (the fixnum (cdr found)) size))
564 (t
565 (setf (gethash class totals) (cons 1 size)))))))
566 space)
567
568 (collect ((totals-list))
569 (maphash #'(lambda (class what)
570 (totals-list (cons (prin1-to-string
571 (class-proper-name class))
572 what)))
573 totals)
574 (let ((sorted (sort (totals-list) #'> :key #'cddr))
575 (printed-bytes 0)
576 (printed-objects 0))
577 (declare (type memory-size printed-bytes printed-objects))
578 (dolist (what (if top-n
579 (subseq sorted 0 (min (length sorted) top-n))
580 sorted))
581 (let ((bytes (cddr what))
582 (objects (cadr what)))
583 (incf printed-bytes bytes)
584 (incf printed-objects objects)
585 (format t " ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)
586 bytes objects)))
587
588 (let ((residual-objects (- total-objects printed-objects))
589 (residual-bytes (- total-bytes printed-bytes)))
590 (unless (zerop residual-objects)
591 (format t " Other types: ~:D bytes, ~D: object~:P.~%"
592 residual-bytes residual-objects))))
593
594 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
595 space total-bytes total-objects)))
596
597 (values))
598
599
600 ;;; FIND-HOLES -- Public
601 ;;;
602 (defun find-holes (&rest spaces)
603 (dolist (space (or spaces '(:read-only :static :dynamic)))
604 (format t "In ~A space:~%" space)
605 (let ((start-addr nil)
606 (total-bytes 0))
607 (declare (type (or null (unsigned-byte 32)) start-addr)
608 (type (unsigned-byte 32) total-bytes))
609 (map-allocated-objects
610 #'(lambda (object typecode bytes)
611 (declare (ignore typecode)
612 (type (unsigned-byte 32) bytes))
613 (if (and (consp object)
614 (eql (car object) 0)
615 (eql (cdr object) 0))
616 (if start-addr
617 (incf total-bytes bytes)
618 (setf start-addr (di::get-lisp-obj-address object)
619 total-bytes bytes))
620 (when start-addr
621 (format t "~D bytes at #x~X~%" total-bytes start-addr)
622 (setf start-addr nil))))
623 space)
624 (when start-addr
625 (format t "~D bytes at #x~X~%" total-bytes start-addr))))
626 (values))
627
628
629 ;;; Print allocated objects:
630
631 (defun print-allocated-objects (space &key (percent 0) (pages 5)
632 type larger smaller count
633 (stream *standard-output*))
634 (declare (type (integer 0 99) percent) (type c::index pages)
635 (type stream stream) (type spaces space)
636 (type (or c::index null) type larger smaller count))
637 (multiple-value-bind (start-sap end-sap)
638 (space-bounds space)
639 (let* ((space-start (sap-int start-sap))
640 (space-end (sap-int end-sap))
641 (space-size (- space-end space-start))
642 (pagesize (system:get-page-size))
643 (start (+ space-start (round (* space-size percent) 100)))
644 (printed-conses (make-hash-table :test #'eq))
645 (pages-so-far 0)
646 (count-so-far 0)
647 (last-page 0))
648 (declare (type (unsigned-byte 32) last-page start)
649 (fixnum pages-so-far count-so-far pagesize))
650 (labels ((note-conses (x)
651 (unless (or (atom x) (gethash x printed-conses))
652 (setf (gethash x printed-conses) t)
653 (note-conses (car x))
654 (note-conses (cdr x)))))
655 (map-allocated-objects
656 #'(lambda (obj obj-type size)
657 (declare (optimize (safety 0)))
658 (let ((addr (get-lisp-obj-address obj)))
659 (when (>= addr start)
660 (when (if count
661 (> count-so-far count)
662 (> pages-so-far pages))
663 (return-from print-allocated-objects (values)))
664
665 (unless count
666 (let ((this-page (* (the (values (unsigned-byte 32) t)
667 (truncate addr pagesize))
668 pagesize)))
669 (declare (type (unsigned-byte 32) this-page))
670 (when (/= this-page last-page)
671 (when (< pages-so-far pages)
672 (format stream "~2&**** Page ~D, address ~X:~%"
673 pages-so-far addr))
674 (setq last-page this-page)
675 (incf pages-so-far))))
676
677 (when (and (or (not type) (eql obj-type type))
678 (or (not smaller) (<= size smaller))
679 (or (not larger) (>= size larger)))
680 (incf count-so-far)
681 (case type
682 (#.code-header-type
683 (let ((dinfo (%code-debug-info obj)))
684 (format stream "~&Code object: ~S~%"
685 (if dinfo
686 (c::compiled-debug-info-name dinfo)
687 "No debug info."))))
688 (#.symbol-header-type
689 (format stream "~&~S~%" obj))
690 (#.list-pointer-type
691 (unless (gethash obj printed-conses)
692 (note-conses obj)
693 (let ((*print-circle* t)
694 (*print-level* 5)
695 (*print-length* 10))
696 (format stream "~&~S~%" obj))))
697 (t
698 (fresh-line stream)
699 (let ((str (write-to-string obj :level 5 :length 10
700 :pretty nil)))
701 (unless (eql type instance-header-type)
702 (format stream "~S: " (type-of obj)))
703 (format stream "~A~%"
704 (subseq str 0 (min (length str) 60))))))))))
705 space))))
706 (values))
707
708
709 ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
710
711 (defvar *ignore-after* nil)
712
713 (defun maybe-cons (space x stuff)
714 (if (or (not (eq space :dynamic))
715 (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
716 (cons x stuff)
717 stuff))
718
719 (defun list-allocated-objects (space &key type larger smaller count
720 test)
721 (declare (type spaces space)
722 (type (or c::index null) larger smaller type count)
723 (type (or function null) test)
724 (inline map-allocated-objects))
725 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
726 (collect ((counted 0 1+))
727 (let ((res ()))
728 (map-allocated-objects
729 #'(lambda (obj obj-type size)
730 (declare (optimize (safety 0)))
731 (when (and (or (not type) (eql obj-type type))
732 (or (not smaller) (<= size smaller))
733 (or (not larger) (>= size larger))
734 (or (not test) (funcall test obj)))
735 (setq res (maybe-cons space obj res))
736 (when (and count (>= (counted) count))
737 (return-from list-allocated-objects res))))
738 space)
739 res)))
740
741 (defun list-referencing-objects (space object)
742 (declare (type spaces space) (inline map-allocated-objects))
743 (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
744 (let ((res ()))
745 (flet ((res (x)
746 (setq res (maybe-cons space x res))))
747 (map-allocated-objects
748 #'(lambda (obj obj-type size)
749 (declare (optimize (safety 0)) (ignore obj-type size))
750 (typecase obj
751 (cons
752 (when (or (eq (car obj) object) (eq (cdr obj) object))
753 (res obj)))
754 (instance
755 (dotimes (i (%instance-length obj))
756 (when (eq (%instance-ref obj i) object)
757 (res obj)
758 (return))))
759 (simple-vector
760 (dotimes (i (length obj))
761 (when (eq (svref obj i) object)
762 (res obj)
763 (return))))
764 (symbol
765 (when (or (eq (symbol-name obj) object)
766 (eq (symbol-package obj) object)
767 (eq (symbol-plist obj) object)
768 (eq (symbol-value obj) object))
769 (res obj)))))
770 space))
771 res))
772
773
774 ;;;; Misc:
775
776 (defun uninterned-symbol-count (space)
777 (declare (type spaces space))
778 (let ((total 0)
779 (uninterned 0))
780 (map-allocated-objects
781 #'(lambda (obj type size)
782 (declare (ignore type size))
783 (when (symbolp obj)
784 (incf total)
785 (unless (symbol-package obj)
786 (incf uninterned))))
787 space)
788 (values uninterned (float (/ uninterned total)))))
789
790
791 (defun code-breakdown (space &key (how :package))
792 (declare (type spaces space) (type (member :file :package) how))
793 (let ((packages (make-hash-table :test #'equal)))
794 (map-allocated-objects
795 #'(lambda (obj type size)
796 (when (eql type code-header-type)
797 (let* ((dinfo (let ((x (%code-debug-info obj)))
798 (when (typep x 'c::debug-info) x)))
799 (package (if (typep dinfo 'c::compiled-debug-info)
800 (c::compiled-debug-info-package dinfo)
801 "UNKNOWN"))
802 (pkg-info (or (gethash package packages)
803 (setf (gethash package packages)
804 (make-hash-table :test #'equal))))
805 (file
806 (if dinfo
807 (let ((src (c::debug-info-source dinfo)))
808 (cond (src
809 (let ((source
810 (first
811 (c::debug-info-source
812 dinfo))))
813 (if (eq (c::debug-source-from source)
814 :file)
815 (c::debug-source-name source)
816 "FROM LISP")))
817 (t
818 (warn "No source for ~S" obj)
819 "NO SOURCE")))
820 "UNKNOWN"))
821 (file-info (or (gethash file pkg-info)
822 (setf (gethash file pkg-info)
823 (cons 0 0)))))
824 (incf (car file-info))
825 (incf (cdr file-info) size))))
826 space)
827
828 (let ((res ()))
829 (do-hash (pkg pkg-info packages)
830 (let ((pkg-res ())
831 (pkg-count 0)
832 (pkg-size 0))
833 (do-hash (file file-info pkg-info)
834 (incf pkg-count (car file-info))
835 (incf pkg-size (cdr file-info))
836 (push (list file file-info) pkg-res))
837 (push (cons pkg-count pkg-size) pkg-res)
838 (push pkg pkg-res)
839 (push pkg-res res)))
840
841 (loop for (pkg (pkg-count . pkg-size) . files) in
842 (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
843 (format t "~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"
844 pkg pkg-size pkg-count)
845 (when (eq how :file)
846 (loop for (file (file-count . file-size)) in
847 (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
848 (format t "~30@A: ~9:D bytes, ~9:D object~:P.~%"
849 (file-namestring file) file-size file-count))))))
850
851 (values))
852
853
854 ;;;; Histogram interface. Uses Scott's Hist package.
855 #+nil
856 (defun memory-histogram (space &key (low 4) (high 20)
857 (bucket-size 1)
858 (function
859 #'(lambda (obj type size)
860 (declare (ignore obj type) (fixnum size))
861 (integer-length (1- size))))
862 (type nil))
863 (let ((function (if (eval:interpreted-function-p function)
864 (compile nil function)
865 function)))
866 (hist:hist (low high bucket-size)
867 (map-allocated-objects
868 #'(lambda (obj this-type size)
869 (when (or (not type) (eql this-type type))
870 (hist:hist-record (funcall function obj type size))))
871 space)))
872 (values))
873
874 ;;; Return the number of fbound constants in a code object.
875 ;;;
876 (defun code-object-calls (obj)
877 (loop for i from code-constants-offset below (get-header-data obj)
878 count (find-code-object (code-header-ref obj i))))
879
880 ;;; Return the number of calls in Obj to functions with <= N calls. Calls is
881 ;;; an eq hashtable translating code objects to the number of references.
882 ;;;
883 (defun code-object-leaf-calls (obj n calls)
884 (loop for i from code-constants-offset below (get-header-data obj)
885 count (let ((code (find-code-object (code-header-ref obj i))))
886 (and code (<= (gethash code calls 0) n)))))
887
888 #+nil
889 (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
890 (function #'identity))
891 "Given a hashtable, print a histogram of the contents. Function should give
892 the value to plot when applied to the hashtable values."
893 (let ((function (if (eval:interpreted-function-p function)
894 (compile nil function)
895 function)))
896 (hist:hist (low high bucket-size)
897 (loop for count being each hash-value in table do
898 (hist:hist-record (funcall function count))))))
899
900 (defun report-top-n (table &key (top-n 20) (function #'identity))
901 "Report the Top-N entries in the hashtable Table, when sorted by Function
902 applied to the hash value. If Top-N is NIL, report all entries."
903 (let ((function (if (eval:interpreted-function-p function)
904 (compile nil function)
905 function)))
906 (collect ((totals-list)
907 (total-val 0 +))
908 (maphash #'(lambda (name what)
909 (let ((val (funcall function what)))
910 (totals-list (cons name val))
911 (total-val val)))
912 table)
913 (let ((sorted (sort (totals-list) #'> :key #'cdr))
914 (printed 0))
915 (declare (fixnum printed))
916 (dolist (what (if top-n
917 (subseq sorted 0 (min (length sorted) top-n))
918 sorted))
919 (let ((val (cdr what)))
920 (incf printed val)
921 (format t "~8:D: ~S~%" val (car what))))
922
923 (let ((residual (- (total-val) printed)))
924 (unless (zerop residual)
925 (format t "~8:D: Other~%" residual))))
926
927 (format t "~8:D: Total~%" (total-val))))
928 (values))
929
930
931 ;;; Given any Lisp object, return the associated code object, or NIL.
932 ;;;
933 (defun find-code-object (const)
934 (flet ((frob (def)
935 (function-code-header
936 (ecase (get-type def)
937 ((#.closure-header-type
938 #.funcallable-instance-header-type)
939 (%closure-function def))
940 (#.function-header-type
941 def)))))
942 (typecase const
943 (function (frob const))
944 (symbol
945 (if (fboundp const)
946 (frob (symbol-function const))
947 nil))
948 (t nil))))
949
950
951 (defun find-caller-counts (space)
952 "Return a hashtable mapping each function in for which a call appears in
953 Space to the number of times such a call appears."
954 (let ((counts (make-hash-table :test #'eq)))
955 (map-allocated-objects
956 #'(lambda (obj type size)
957 (declare (ignore size))
958 (when (eql type code-header-type)
959 (loop for i from code-constants-offset below (get-header-data obj)
960 do (let ((code (find-code-object (code-header-ref obj i))))
961 (when code
962 (incf (gethash code counts 0)))))))
963 space)
964 counts))
965
966 (defun find-high-callers (space &key (above 10) table (threshold 2))
967 "Return a hashtable translating code objects to function constant counts for
968 all code objects in Space with more than Above function constants."
969 (let ((counts (make-hash-table :test #'eq)))
970 (map-allocated-objects
971 #'(lambda (obj type size)
972 (declare (ignore size))
973 (when (eql type code-header-type)
974 (let ((count (if table
975 (code-object-leaf-calls obj threshold table)
976 (code-object-calls obj))))
977 (when (> count above)
978 (setf (gethash obj counts) count)))))
979 space)
980 counts))

  ViewVC Help
Powered by ViewVC 1.1.5