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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5