/[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 - (hide 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 ram 1.1 ;;; -*- Mode: Lisp; Package: VM -*-
2     ;;;
3     ;;; **********************************************************************
4 wlott 1.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 rtoy 1.34.12.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/room.lisp,v 1.34.12.2 2006/06/26 15:09:20 rtoy Exp $")
9 wlott 1.4 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Heap grovelling memory usage stuff.
13     ;;;
14     (in-package "VM")
15     (use-package "SYSTEM")
16 ram 1.5 (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
17 ram 1.19 instance-usage find-holes print-allocated-objects
18 ram 1.20 code-breakdown uninterned-symbol-count
19     list-allocated-objects))
20 ram 1.1 (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 ram 1.20 (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 ram 1.1
45 ram 1.20 (eval-when (compile eval)
46 ram 1.1
47 ram 1.20 (defvar *meta-room-info* (make-array 256 :initial-element nil))
48 ram 1.1
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 ram 1.20 (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
63 ram 1.1 (variable)
64     (t
65 ram 1.20 (setf (svref *meta-room-info* (symbol-value header))
66 ram 1.1 (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 ram 1.20 (setf (svref *meta-room-info* code)
72 ram 1.1 (make-room-info :name 'array-header :kind :header)))
73    
74 ram 1.20 (setf (svref *meta-room-info* bignum-type)
75 ram 1.1 (make-room-info :name 'bignum :kind :header))
76    
77 ram 1.20 (setf (svref *meta-room-info* closure-header-type)
78 ram 1.1 (make-room-info :name 'closure :kind :closure))
79    
80 wlott 1.2 (dolist (stuff '((simple-bit-vector-type . -3)
81 ram 1.1 (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 dtc 1.27 (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 ram 1.1 (simple-array-single-float-type . 2)
92 dtc 1.26 (simple-array-double-float-type . 3)
93 dtc 1.27 (simple-array-complex-single-float-type . 3)
94 rtoy 1.34.12.1 (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 ram 1.1 (let ((name (car stuff))
101     (size (cdr stuff)))
102 ram 1.20 (setf (svref *meta-room-info* (symbol-value name))
103 ram 1.1 (make-room-info :name name :kind :vector :length size))))
104    
105 ram 1.20 (setf (svref *meta-room-info* simple-string-type)
106 wlott 1.2 (make-room-info :name 'simple-string-type :kind :string :length 0))
107    
108 ram 1.20 (setf (svref *meta-room-info* code-header-type)
109 ram 1.1 (make-room-info :name 'code :kind :code))
110    
111 ram 1.20 (setf (svref *meta-room-info* instance-header-type)
112 ram 1.19 (make-room-info :name 'instance :kind :instance))
113 wlott 1.3
114 ram 1.20 ); eval-when (compile eval)
115    
116     (defparameter *room-info* '#.*meta-room-info*)
117 ram 1.1 (deftype spaces () '(member :static :dynamic :read-only))
118 toy 1.31 ;; A type denoting the virtual address available to us.
119     (deftype memory-size () `(unsigned-byte #.vm:word-bits))
120 ram 1.1
121     ;;;; MAP-ALLOCATED-OBJECTS:
122    
123 pw 1.30 (declaim (type fixnum *static-space-free-pointer*
124     *read-only-space-free-pointer* ))
125 ram 1.1
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 ram 1.10 ;;; 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 ram 1.1
148     ;;; ROUND-TO-DUALWORD -- Internal
149     ;;;
150 cwang 1.34 ;;; Round Size (in bytes) up to the next dualword (eight/16 byte) boundry.
151 ram 1.1 ;;;
152 pw 1.30 (declaim (inline round-to-dualword))
153 ram 1.1 (defun round-to-dualword (size)
154 toy 1.31 (declare (type memory-size size))
155 cwang 1.34 #-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 ram 1.1
161    
162     ;;; VECTOR-TOTAL-SIZE -- Internal
163     ;;;
164     ;;; Return the total size of a vector in bytes, including any pad.
165     ;;;
166 pw 1.30 (declaim (inline vector-total-size))
167 ram 1.1 (defun vector-total-size (obj info)
168     (let ((shift (room-info-length info))
169 ram 1.14 (len (+ (length (the (simple-array * (*)) obj))
170 wlott 1.2 (ecase (room-info-kind info)
171     (:vector 0)
172     (:string 1)))))
173 ram 1.1 (declare (type (integer -3 3) shift))
174     (round-to-dualword
175     (+ (* vector-data-offset word-bytes)
176 toy 1.31 (the memory-size
177 ram 1.1 (if (minusp shift)
178 toy 1.31 (ash (the memory-size
179     (+ len (the memory-size
180     (1- (the memory-size (ash 1 (- shift)))))))
181 ram 1.1 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 pw 1.30 (declaim (maybe-inline map-allocated-objects))
192 ram 1.1 (defun map-allocated-objects (fun space)
193     (declare (type function fun) (type spaces space))
194 ram 1.10 (without-gcing
195     (multiple-value-bind (start end)
196     (space-bounds space)
197 ram 1.14 (declare (type system-area-pointer start end))
198 ram 1.10 (declare (optimize (speed 3) (safety 0)))
199 rtoy 1.33 (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 ram 1.10 (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 rtoy 1.33 (next size)))
221 ram 1.10 ((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 rtoy 1.33 (next size)))
229 ram 1.19 ((eq (room-info-kind info) :instance)
230 ram 1.10 (let* ((obj (make-lisp-obj
231 ram 1.19 (logior (sap-int current) instance-pointer-type)))
232 ram 1.10 (size (round-to-dualword
233 ram 1.19 (* (+ (%instance-length obj) 1) word-bytes))))
234 toy 1.31 (declare (type memory-size size))
235 ram 1.10 (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 ram 1.14 #+nil
240 ram 1.10 (setq prev current)
241 rtoy 1.33 (next size)))
242 ram 1.10 (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 wlott 1.17 (* (the fixnum (%code-code-size obj))
262 ram 1.10 word-bytes)))))))
263 toy 1.31 (declare (type memory-size size))
264 ram 1.10 (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 ram 1.14 #+nil
270 ram 1.10 (setq prev current)
271 rtoy 1.33 (next size))))))
272 ram 1.14
273     #+nil
274 ram 1.10 prev))))
275 ram 1.1
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 toy 1.31 (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 ram 1.1 (map-allocated-objects
288     #'(lambda (obj type size)
289 toy 1.31 (declare (type memory-size size) (optimize (speed 3) (safety 0)) (ignore obj))
290 wlott 1.3 (incf (aref sizes type) size)
291     (incf (aref counts type)))
292 ram 1.1 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 toy 1.31 (declare (type memory-size sum))
334 ram 1.1 (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 toy 1.31 (declare (type memory-size summary-total-bytes summary-total-objects))
343 ram 1.1 (dolist (space-totals
344     (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
345     (let ((total-objects 0)
346     (total-bytes 0)
347     name)
348 toy 1.31 (declare (fixnum total-objects)
349     (type memory-size total-bytes))
350 ram 1.1 (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 ram 1.10 ;;; 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 toy 1.31 (declare (fixnum total-objects cutoff-point reported-objects)
386     (type memory-size total-bytes reported-bytes))
387 ram 1.10 (loop for (bytes objects name) in types do
388     (when (<= bytes cutoff-point)
389 toy 1.31 (format t " ~13:D bytes for ~9:D other object~2:*~P.~%"
390 ram 1.10 (- total-bytes reported-bytes)
391     (- total-objects reported-objects))
392     (return))
393     (incf reported-bytes bytes)
394     (incf reported-objects objects)
395 toy 1.31 (format t " ~13:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
396 ram 1.10 bytes objects name))
397 toy 1.31 (format t " ~13:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
398 ram 1.10 total-bytes total-objects (car space-total))))
399    
400    
401 ram 1.1 ;;; MEMORY-USAGE -- Public
402     ;;;
403     (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
404 ram 1.10 (print-summary t) cutoff)
405 ram 1.1 "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 ram 1.10 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 ram 1.1 (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 ram 1.10 (report-space-total space-total cutoff)))
424 ram 1.1
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 wlott 1.4 (declare (fixnum code-words no-ops)
439     (type unsigned-byte total-bytes))
440 ram 1.1 (map-allocated-objects
441     #'(lambda (obj type size)
442 ram 1.14 (declare (fixnum size) (optimize (safety 0)))
443 ram 1.1 (when (eql type code-header-type)
444     (incf total-bytes size)
445 wlott 1.17 (let ((words (truly-the fixnum (%code-code-size obj)))
446 ram 1.1 (sap (truly-the system-area-pointer
447     (%primitive code-instructions obj))))
448     (incf code-words words)
449     (dotimes (i words)
450 wlott 1.15 (when (zerop (sap-ref-32 sap (* i vm:word-bytes)))
451     (incf no-ops))))))
452 ram 1.1 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 wlott 1.4 ;;; 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 ram 1.14 (declare (fixnum size) (optimize (safety 0)))
475 wlott 1.4 (case type
476     (#.code-header-type
477 wlott 1.17 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
478 wlott 1.4 (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 rtoy 1.34.12.1 #+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 wlott 1.4 #.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 dtc 1.27 #.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 wlott 1.4 #.simple-array-single-float-type
503 dtc 1.26 #.simple-array-double-float-type
504 rtoy 1.34.12.1 #+double-double
505     #.simple-array-double-double-float-type
506 dtc 1.27 #.simple-array-complex-single-float-type
507 rtoy 1.34.12.1 #.simple-array-complex-double-float-type
508     #+double-double
509     #.simple-array-complex-double-double-float-type)
510 wlott 1.4 (incf non-descriptor-headers)
511     (incf non-descriptor-bytes (- size word-bytes)))
512     ((#.list-pointer-type
513 ram 1.19 #.instance-pointer-type
514 wlott 1.4 #.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 rtoy 1.34.12.2 #.instance-header-type
529     #.fdefn-type
530     #+gencgc
531     #.scavenger-hook-type)
532 wlott 1.4 (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 ram 1.19 ;;; INSTANCE-USAGE -- Public
544 ram 1.1 ;;;
545 ram 1.19 (defun instance-usage (space &key (top-n 15))
546 ram 1.1 (declare (type spaces space) (type (or fixnum null) top-n))
547 ram 1.19 "Print a breakdown by instance type of all the instances allocated in
548 ram 1.1 Space. If TOP-N is true, print only information for the the TOP-N types with
549     largest usage."
550 ram 1.19 (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
551 ram 1.1 (let ((totals (make-hash-table :test #'eq))
552     (total-objects 0)
553     (total-bytes 0))
554 toy 1.31 (declare (fixnum total-objects)
555     (type memory-size total-bytes))
556 ram 1.1 (map-allocated-objects
557     #'(lambda (obj type size)
558 toy 1.31 (declare (type memory-size size) (optimize (speed 3) (safety 0)))
559 ram 1.19 (when (eql type instance-header-type)
560 ram 1.1 (incf total-objects)
561     (incf total-bytes size)
562 ram 1.19 (let* ((class (layout-class (%instance-ref obj 0)))
563     (found (gethash class totals)))
564 ram 1.1 (cond (found
565     (incf (the fixnum (car found)))
566     (incf (the fixnum (cdr found)) size))
567     (t
568 ram 1.19 (setf (gethash class totals) (cons 1 size)))))))
569 ram 1.1 space)
570    
571     (collect ((totals-list))
572 ram 1.19 (maphash #'(lambda (class what)
573     (totals-list (cons (prin1-to-string
574     (class-proper-name class))
575     what)))
576 ram 1.1 totals)
577     (let ((sorted (sort (totals-list) #'> :key #'cddr))
578     (printed-bytes 0)
579     (printed-objects 0))
580 toy 1.31 (declare (type memory-size printed-bytes printed-objects))
581 ram 1.1 (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 toy 1.31 (format t " ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)
589 ram 1.1 bytes objects)))
590    
591     (let ((residual-objects (- total-objects printed-objects))
592     (residual-bytes (- total-bytes printed-bytes)))
593     (unless (zerop residual-objects)
594 ram 1.10 (format t " Other types: ~:D bytes, ~D: object~:P.~%"
595 ram 1.1 residual-bytes residual-objects))))
596    
597 ram 1.19 (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
598 ram 1.10 space total-bytes total-objects)))
599 ram 1.1
600 wlott 1.2 (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 ram 1.6 (values))
630    
631    
632     ;;; Print allocated objects:
633    
634     (defun print-allocated-objects (space &key (percent 0) (pages 5)
635 ram 1.9 type larger smaller count
636 ram 1.6 (stream *standard-output*))
637     (declare (type (integer 0 99) percent) (type c::index pages)
638 ram 1.9 (type stream stream) (type spaces space)
639     (type (or c::index null) type larger smaller count))
640 ram 1.6 (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 ram 1.11 (pagesize (system:get-page-size))
646 ram 1.6 (start (+ space-start (round (* space-size percent) 100)))
647 ram 1.20 (printed-conses (make-hash-table :test #'eq))
648 ram 1.6 (pages-so-far 0)
649 ram 1.9 (count-so-far 0)
650 ram 1.6 (last-page 0))
651     (declare (type (unsigned-byte 32) last-page start)
652 ram 1.9 (fixnum pages-so-far count-so-far pagesize))
653 ram 1.20 (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 dtc 1.29 (let ((this-page (* (the (values (unsigned-byte 32) t)
670     (truncate addr pagesize))
671 ram 1.20 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 ram 1.6 (map-allocated-objects
732 ram 1.9 #'(lambda (obj obj-type size)
733 ram 1.14 (declare (optimize (safety 0)))
734 ram 1.20 (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 ram 1.9
744 ram 1.20 (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 ram 1.7
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 ram 1.8
794     (defun code-breakdown (space &key (how :package))
795     (declare (type spaces space) (type (member :file :package) how))
796 ram 1.21 (let ((packages (make-hash-table :test #'equal)))
797 ram 1.7 (map-allocated-objects
798     #'(lambda (obj type size)
799     (when (eql type code-header-type)
800 ram 1.22 (let* ((dinfo (let ((x (%code-debug-info obj)))
801 ram 1.23 (when (typep x 'c::debug-info) x)))
802     (package (if (typep dinfo 'c::compiled-debug-info)
803 ram 1.21 (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 ram 1.22 (file
809     (if dinfo
810 ram 1.23 (let ((src (c::debug-info-source dinfo)))
811 ram 1.22 (cond (src
812     (let ((source
813     (first
814 ram 1.23 (c::debug-info-source
815 ram 1.22 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 ram 1.21 (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 ram 1.7 space)
830    
831 ram 1.21 (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 ram 1.8 (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 ram 1.9 (integer-length (1- size))))
865 ram 1.8 (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