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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5