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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5