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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5