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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Tue Apr 20 17:57:45 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.39: +15 -15 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: VM -*-
2     ;;;
3     ;;; **********************************************************************
4 wlott 1.4 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.40 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/room.lisp,v 1.40 2010/04/20 17:57:45 rtoy Rel $")
9 wlott 1.4 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Heap grovelling memory usage stuff.
13     ;;;
14     (in-package "VM")
15     (use-package "SYSTEM")
16 rtoy 1.38 (intl:textdomain "cmucl")
17    
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 dtc 1.27 (simple-array-signed-byte-8-type . 0)
90     (simple-array-signed-byte-16-type . 1)
91     (simple-array-signed-byte-30-type . 2)
92     (simple-array-signed-byte-32-type . 2)
93 ram 1.1 (simple-array-single-float-type . 2)
94 dtc 1.26 (simple-array-double-float-type . 3)
95 dtc 1.27 (simple-array-complex-single-float-type . 3)
96 rtoy 1.35 (simple-array-complex-double-float-type . 4)
97     #+double-double
98     (simple-array-double-double-float-type . 4)
99     #+double-double
100     (simple-array-complex-double-double-float-type . 5)
101     ))
102 ram 1.1 (let ((name (car stuff))
103     (size (cdr stuff)))
104 ram 1.20 (setf (svref *meta-room-info* (symbol-value name))
105 ram 1.1 (make-room-info :name name :kind :vector :length size))))
106    
107 rtoy 1.37 ;; For unicode, there are 2 bytes per character, not 1.
108 ram 1.20 (setf (svref *meta-room-info* simple-string-type)
109 rtoy 1.37 (make-room-info :name 'simple-string-type :kind :string
110     ;; Assumes char-bytes is a power of two!
111     :length (1- (integer-length vm:char-bytes))))
112 wlott 1.2
113 ram 1.20 (setf (svref *meta-room-info* code-header-type)
114 ram 1.1 (make-room-info :name 'code :kind :code))
115    
116 ram 1.20 (setf (svref *meta-room-info* instance-header-type)
117 ram 1.19 (make-room-info :name 'instance :kind :instance))
118 wlott 1.3
119 ram 1.20 ); eval-when (compile eval)
120    
121     (defparameter *room-info* '#.*meta-room-info*)
122 ram 1.1 (deftype spaces () '(member :static :dynamic :read-only))
123 toy 1.31 ;; A type denoting the virtual address available to us.
124     (deftype memory-size () `(unsigned-byte #.vm:word-bits))
125 ram 1.1
126     ;;;; MAP-ALLOCATED-OBJECTS:
127    
128 pw 1.30 (declaim (type fixnum *static-space-free-pointer*
129     *read-only-space-free-pointer* ))
130 ram 1.1
131 rtoy 1.36 #+gencgc
132     (eval-when (compile load eval)
133     ;; This had better match the value in gencgc.h!!!!
134     (defconstant gencgc-page-size
135     #+sparc (* 4 8192)
136     #+ppc (* 4 4096)
137     #-(or sparc ppc) 4096))
138    
139     #+gencgc
140     (def-alien-variable last-free-page c-call:unsigned-int)
141    
142 ram 1.1 (defun space-bounds (space)
143     (declare (type spaces space))
144     (ecase space
145     (:static
146     (values (int-sap (static-space-start))
147     (int-sap (* *static-space-free-pointer* word-bytes))))
148     (:read-only
149     (values (int-sap (read-only-space-start))
150     (int-sap (* *read-only-space-free-pointer* word-bytes))))
151     (:dynamic
152 rtoy 1.36 ;; DYNAMIC-SPACE-FREE-POINTER isn't quite right here for sparc
153     ;; and ppc with gencgc. We really want the last free page, which
154     ;; is stored in *allocation-pointer* on x86, but sparc and ppc
155     ;; don't have *allocation-pointer*, so grab the value directly
156     ;; from last-free-page.
157 ram 1.1 (values (int-sap (current-dynamic-space-start))
158 rtoy 1.36 #+(and gencgc (or sparc ppc))
159     (int-sap (truly-the (unsigned-byte 32)
160     (+ (current-dynamic-space-start)
161     (the (unsigned-byte 32) (* gencgc-page-size last-free-page)))))
162     #-(and gencgc (or sparc ppc))
163 ram 1.1 (dynamic-space-free-pointer)))))
164    
165 ram 1.10 ;;; SPACE-BYTES -- Internal
166     ;;;
167     ;;; Return the total number of bytes used in Space.
168     ;;;
169     (defun space-bytes (space)
170     (multiple-value-bind (start end)
171     (space-bounds space)
172     (- (sap-int end) (sap-int start))))
173 ram 1.1
174     ;;; ROUND-TO-DUALWORD -- Internal
175     ;;;
176 cwang 1.34 ;;; Round Size (in bytes) up to the next dualword (eight/16 byte) boundry.
177 ram 1.1 ;;;
178 pw 1.30 (declaim (inline round-to-dualword))
179 ram 1.1 (defun round-to-dualword (size)
180 toy 1.31 (declare (type memory-size size))
181 cwang 1.34 #-amd64
182     (logandc2 (the memory-size (+ size lowtag-mask)) lowtag-mask)
183     ;; when we use 4-bit lowtag for amd64 we can get rid of this
184     #+amd64
185     (logandc2 (the memory-size (+ size 15)) 15))
186 ram 1.1
187    
188     ;;; VECTOR-TOTAL-SIZE -- Internal
189     ;;;
190     ;;; Return the total size of a vector in bytes, including any pad.
191     ;;;
192 pw 1.30 (declaim (inline vector-total-size))
193 ram 1.1 (defun vector-total-size (obj info)
194     (let ((shift (room-info-length info))
195 ram 1.14 (len (+ (length (the (simple-array * (*)) obj))
196 wlott 1.2 (ecase (room-info-kind info)
197     (:vector 0)
198     (:string 1)))))
199 ram 1.1 (declare (type (integer -3 3) shift))
200     (round-to-dualword
201     (+ (* vector-data-offset word-bytes)
202 toy 1.31 (the memory-size
203 ram 1.1 (if (minusp shift)
204 toy 1.31 (ash (the memory-size
205     (+ len (the memory-size
206     (1- (the memory-size (ash 1 (- shift)))))))
207 ram 1.1 shift)
208     (ash len shift)))))))
209    
210 rtoy 1.36 ;;; Access to the GENCGC page table for better precision in
211     ;;; MAP-ALLOCATED-OBJECTS.
212     #+gencgc
213     (progn
214     (declaim (inline find-page-index get-page-table-info))
215     (def-alien-routine "find_page_index" c-call:int
216     (addr c-call:long))
217     (def-alien-routine get-page-table-info c-call:void
218     (page c-call:int)
219     (flags c-call:int :out)
220     (bytes c-call:int :out))
221     )
222 ram 1.1
223     ;;; MAP-ALLOCATED-OBJECTS -- Interface
224     ;;;
225     ;;; Iterate over all the objects allocated in Space, calling Fun with the
226     ;;; object, the object's type code, and the objects total size in bytes,
227     ;;; including any header and padding.
228     ;;;
229 pw 1.30 (declaim (maybe-inline map-allocated-objects))
230 rtoy 1.36 #+nil
231 ram 1.1 (defun map-allocated-objects (fun space)
232     (declare (type function fun) (type spaces space))
233 ram 1.10 (without-gcing
234     (multiple-value-bind (start end)
235     (space-bounds space)
236 ram 1.14 (declare (type system-area-pointer start end))
237 ram 1.10 (declare (optimize (speed 3) (safety 0)))
238 rtoy 1.33 (iterate step ((current start))
239     (flet ((next (size)
240     (let ((c (etypecase size
241     (fixnum (sap+ current size))
242     (memory-size (sap+ current size)))))
243     (cond ((sap< c end)
244     (step c))
245     (t
246     (assert (sap= c end)))))))
247 ram 1.10 (let* ((header (sap-ref-32 current 0))
248     (header-type (logand header #xFF))
249     (info (svref *room-info* header-type)))
250     (cond
251     ((or (not info)
252     (eq (room-info-kind info) :lowtag))
253     (let ((size (* cons-size word-bytes)))
254     (funcall fun
255     (make-lisp-obj (logior (sap-int current)
256     list-pointer-type))
257     list-pointer-type
258     size)
259 rtoy 1.33 (next size)))
260 ram 1.10 ((eql header-type closure-header-type)
261     (let* ((obj (make-lisp-obj (logior (sap-int current)
262     function-pointer-type)))
263     (size (round-to-dualword
264     (* (the fixnum (1+ (get-closure-length obj)))
265     word-bytes))))
266     (funcall fun obj header-type size)
267 rtoy 1.33 (next size)))
268 ram 1.19 ((eq (room-info-kind info) :instance)
269 ram 1.10 (let* ((obj (make-lisp-obj
270 ram 1.19 (logior (sap-int current) instance-pointer-type)))
271 ram 1.10 (size (round-to-dualword
272 ram 1.19 (* (+ (%instance-length obj) 1) word-bytes))))
273 toy 1.31 (declare (type memory-size size))
274 ram 1.10 (funcall fun obj header-type size)
275     (assert (zerop (logand size lowtag-mask)))
276     #+nil
277     (when (> size 200000) (break "Implausible size, prev ~S" prev))
278 ram 1.14 #+nil
279 ram 1.10 (setq prev current)
280 rtoy 1.33 (next size)))
281 ram 1.10 (t
282     (let* ((obj (make-lisp-obj
283     (logior (sap-int current) other-pointer-type)))
284     (size (ecase (room-info-kind info)
285     (:fixed
286     (assert (or (eql (room-info-length info)
287     (1+ (get-header-data obj)))
288     (floatp obj)))
289     (round-to-dualword
290     (* (room-info-length info) word-bytes)))
291     ((:vector :string)
292     (vector-total-size obj info))
293     (:header
294     (round-to-dualword
295     (* (1+ (get-header-data obj)) word-bytes)))
296     (:code
297     (+ (the fixnum
298     (* (get-header-data obj) word-bytes))
299     (round-to-dualword
300 wlott 1.17 (* (the fixnum (%code-code-size obj))
301 ram 1.10 word-bytes)))))))
302 toy 1.31 (declare (type memory-size size))
303 ram 1.10 (funcall fun obj header-type size)
304     (assert (zerop (logand size lowtag-mask)))
305     #+nil
306     (when (> size 200000)
307     (break "Implausible size, prev ~S" prev))
308 ram 1.14 #+nil
309 ram 1.10 (setq prev current)
310 rtoy 1.33 (next size))))))
311 ram 1.14
312     #+nil
313 ram 1.10 prev))))
314 ram 1.1
315 rtoy 1.36 (defun map-allocated-objects (fun space)
316     (declare (type function fun) (type spaces space))
317     (without-gcing
318     (multiple-value-bind (start end)
319     (space-bounds space)
320     (declare (type system-area-pointer start end))
321     (declare (optimize (speed 3) (safety 0)))
322     (let ((skip-tests-until-addr 0)
323     (current start))
324     (declare (type (unsigned-byte 31) skip-tests-until-addr))
325     (labels
326     ((maybe-finish-mapping ()
327     (unless (sap< current end)
328     (return-from map-allocated-objects)))
329     ;; GENCGC doesn't allocate linearly, which means that the
330     ;; dynamic space can contain large blocks of zeros that
331     ;; get accounted as conses in ROOM (and slow down other
332     ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
333     ;; check the GC page structure for the current address.
334     ;; If the page is free or the address is beyond the page-
335     ;; internal allocation offset (bytes-used) skip to the
336     ;; next page immediately.
337     (maybe-skip-page ()
338     #+gencgc
339     (when (eq space :dynamic)
340     (let ((tested (>= (sap-int current) skip-tests-until-addr)))
341     (loop with page-mask = (1- gencgc-page-size)
342     for addr of-type (unsigned-byte 32) = (sap-int current)
343     while (>= addr skip-tests-until-addr)
344     do
345     (multiple-value-bind (ret flags bytes-used)
346     (get-page-table-info (find-page-index addr))
347     (declare (ignore ret))
348     (let ((alloc-flag (logand flags #x40)))
349     ;; If the page is not free and the current
350     ;; pointer is still below the allocation
351     ;; offset of the page
352     (when (and (not (zerop alloc-flag))
353     (<= (logand page-mask addr)
354     bytes-used))
355     ;; Don't bother testing again until we get
356     ;; past that allocation offset
357     (setf skip-tests-until-addr
358     (+ (logandc2 addr page-mask)
359     (the fixnum bytes-used)))
360     ;; And then continue with the scheduled mapping
361     (return-from maybe-skip-page))
362     ;; Move CURRENT to start of next page
363     (setf current (int-sap (+ (logandc2 addr page-mask)
364     gencgc-page-size)))
365     (maybe-finish-mapping)))))))
366     (next (size)
367     (let ((c (etypecase size
368     (fixnum (sap+ current size))
369     (memory-size (sap+ current size)))))
370     (setf current c))))
371     (declare (inline next))
372     (loop
373     (maybe-finish-mapping)
374     (maybe-skip-page)
375     (let* ((header (sap-ref-32 current 0))
376     (header-type (logand header #xFF))
377     (info (svref *room-info* header-type)))
378     (cond
379     ((or (not info)
380     (eq (room-info-kind info) :lowtag))
381     (let ((size (* cons-size word-bytes)))
382     (funcall fun
383     (make-lisp-obj (logior (sap-int current)
384     list-pointer-type))
385     list-pointer-type
386     size)
387     (next size)))
388     ((eql header-type closure-header-type)
389     (let* ((obj (make-lisp-obj (logior (sap-int current)
390     function-pointer-type)))
391     (size (round-to-dualword
392     (* (the fixnum (1+ (get-closure-length obj)))
393     word-bytes))))
394     (funcall fun obj header-type size)
395     (next size)))
396     ((eq (room-info-kind info) :instance)
397     (let* ((obj (make-lisp-obj
398     (logior (sap-int current) instance-pointer-type)))
399     (size (round-to-dualword
400     (* (+ (%instance-length obj) 1) word-bytes))))
401     (declare (type memory-size size))
402     (funcall fun obj header-type size)
403     (assert (zerop (logand size lowtag-mask)))
404     (next size)))
405     (t
406     (let* ((obj (make-lisp-obj
407     (logior (sap-int current) other-pointer-type)))
408     (size (ecase (room-info-kind info)
409     (:fixed
410     (assert (or (eql (room-info-length info)
411     (1+ (get-header-data obj)))
412     (floatp obj)))
413     (round-to-dualword
414     (* (room-info-length info) word-bytes)))
415     ((:vector :string)
416     (vector-total-size obj info))
417     (:header
418     (round-to-dualword
419     (* (1+ (get-header-data obj)) word-bytes)))
420     (:code
421     (+ (the fixnum
422     (* (get-header-data obj) word-bytes))
423     (round-to-dualword
424     (* (the fixnum (%code-code-size obj))
425     word-bytes)))))))
426     (declare (type memory-size size))
427     (funcall fun obj header-type size)
428     (assert (zerop (logand size lowtag-mask)))
429     (next size)))))))))))
430    
431 ram 1.1
432     ;;;; MEMORY-USAGE:
433    
434     ;;; TYPE-BREAKDOWN -- Interface
435     ;;;
436     ;;; Return a list of 3-lists (bytes object type-name) for the objects
437     ;;; allocated in Space.
438     ;;;
439     (defun type-breakdown (space)
440 toy 1.31 (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte 32)))
441     (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte 32))))
442 ram 1.1 (map-allocated-objects
443     #'(lambda (obj type size)
444 toy 1.31 (declare (type memory-size size) (optimize (speed 3) (safety 0)) (ignore obj))
445 wlott 1.3 (incf (aref sizes type) size)
446     (incf (aref counts type)))
447 ram 1.1 space)
448    
449     (let ((totals (make-hash-table :test #'eq)))
450     (dotimes (i 256)
451     (let ((total-count (aref counts i)))
452     (unless (zerop total-count)
453     (let* ((total-size (aref sizes i))
454     (name (room-info-name (aref *room-info* i)))
455     (found (gethash name totals)))
456     (cond (found
457     (incf (first found) total-size)
458     (incf (second found) total-count))
459     (t
460     (setf (gethash name totals)
461     (list total-size total-count name))))))))
462    
463     (collect ((totals-list))
464     (maphash #'(lambda (k v)
465     (declare (ignore k))
466     (totals-list v))
467     totals)
468     (sort (totals-list) #'> :key #'first)))))
469    
470    
471     ;;; PRINT-SUMMARY -- Internal
472     ;;;
473     ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
474     ;;; (space-name . totals-for-space), where totals-for-space is the list
475     ;;; returned by TYPE-BREAKDOWN.
476     ;;;
477     (defun print-summary (spaces totals)
478     (let ((summary (make-hash-table :test #'eq)))
479     (dolist (space-total totals)
480     (dolist (total (cdr space-total))
481     (push (cons (car space-total) total)
482     (gethash (third total) summary))))
483    
484     (collect ((summary-totals))
485     (maphash #'(lambda (k v)
486     (declare (ignore k))
487     (let ((sum 0))
488 toy 1.31 (declare (type memory-size sum))
489 ram 1.1 (dolist (space-total v)
490     (incf sum (first (cdr space-total))))
491     (summary-totals (cons sum v))))
492     summary)
493    
494 rtoy 1.40 (format t (intl:gettext "~2&Summary of spaces: ~(~{~A ~}~)~%") spaces)
495 ram 1.1 (let ((summary-total-bytes 0)
496     (summary-total-objects 0))
497 toy 1.31 (declare (type memory-size summary-total-bytes summary-total-objects))
498 ram 1.1 (dolist (space-totals
499     (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
500     (let ((total-objects 0)
501     (total-bytes 0)
502     name)
503 toy 1.31 (declare (fixnum total-objects)
504     (type memory-size total-bytes))
505 ram 1.1 (collect ((spaces))
506     (dolist (space-total space-totals)
507     (let ((total (cdr space-total)))
508     (setq name (third total))
509     (incf total-bytes (first total))
510     (incf total-objects (second total))
511     (spaces (cons (car space-total) (first total)))))
512 rtoy 1.38 (format t (intl:ngettext "~%~A:~% ~:D bytes, ~:D object"
513     "~%~A:~% ~:D bytes, ~:D objects"
514     total-objects)
515 ram 1.1 name total-bytes total-objects)
516     (dolist (space (spaces))
517     (format t ", ~D% ~(~A~)"
518     (round (* (cdr space) 100) total-bytes)
519     (car space)))
520     (format t ".~%")
521     (incf summary-total-bytes total-bytes)
522     (incf summary-total-objects total-objects))))
523 rtoy 1.40 (format t (intl:gettext "~%Summary total:~% ~:D bytes, ~:D objects.~%")
524 ram 1.1 summary-total-bytes summary-total-objects)))))
525    
526    
527 ram 1.10 ;;; REPORT-SPACE-TOTAL -- Internal
528     ;;;
529     ;;; Report object usage for a single space.
530     ;;;
531     (defun report-space-total (space-total cutoff)
532     (declare (list space-total) (type (or single-float null) cutoff))
533 rtoy 1.40 (format t (intl:gettext "~2&Breakdown for ~(~A~) space:~%") (car space-total))
534 ram 1.10 (let* ((types (cdr space-total))
535     (total-bytes (reduce #'+ (mapcar #'first types)))
536     (total-objects (reduce #'+ (mapcar #'second types)))
537     (cutoff-point (if cutoff
538     (truncate (* (float total-bytes) cutoff))
539     0))
540     (reported-bytes 0)
541     (reported-objects 0))
542 toy 1.31 (declare (fixnum total-objects cutoff-point reported-objects)
543     (type memory-size total-bytes reported-bytes))
544 ram 1.10 (loop for (bytes objects name) in types do
545     (when (<= bytes cutoff-point)
546 rtoy 1.38 (format t (intl:ngettext " ~13:D bytes for ~9:D other object.~%"
547     " ~13:D bytes for ~9:D other objects.~%"
548     (- total-objects reported-objects))
549 ram 1.10 (- total-bytes reported-bytes)
550     (- total-objects reported-objects))
551     (return))
552     (incf reported-bytes bytes)
553     (incf reported-objects objects)
554 rtoy 1.38 (format t (intl:ngettext " ~13:D bytes for ~9:D ~(~A~) object.~%"
555     " ~13:D bytes for ~9:D ~(~A~) objects.~%"
556     objects)
557 ram 1.10 bytes objects name))
558 rtoy 1.38 (format t (intl:ngettext " ~13:D bytes for ~9:D ~(~A~) object (space total.)~%"
559     " ~13:D bytes for ~9:D ~(~A~) objects (space total.)~%"
560     total-objects)
561 ram 1.10 total-bytes total-objects (car space-total))))
562    
563    
564 ram 1.1 ;;; MEMORY-USAGE -- Public
565     ;;;
566     (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
567 ram 1.10 (print-summary t) cutoff)
568 rtoy 1.39 "Print out information about the heap memory in use. :Print-Spaces is a list
569 ram 1.1 of the spaces to print detailed information for. :Count-Spaces is a list of
570     the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
571     and :Read-Only.) If :Print-Summary is true, then summary information will be
572 ram 1.10 printed. The defaults print only summary information for dynamic space.
573     If true, Cutoff is a fraction of the usage in a report below which types will
574     be combined as OTHER."
575     (declare (type (or single-float null) cutoff))
576 ram 1.1 (let* ((spaces (if (eq count-spaces t)
577     '(:static :dynamic :read-only)
578     count-spaces))
579     (totals (mapcar #'(lambda (space)
580     (cons space (type-breakdown space)))
581     spaces)))
582    
583     (dolist (space-total totals)
584     (when (or (eq print-spaces t)
585     (member (car space-total) print-spaces))
586 ram 1.10 (report-space-total space-total cutoff)))
587 ram 1.1
588     (when print-summary (print-summary spaces totals)))
589    
590     (values))
591    
592    
593     ;;; COUNT-NO-OPS -- Public
594     ;;;
595     (defun count-no-ops (space)
596 rtoy 1.39 "Print info about how much code and no-ops there are in Space."
597 ram 1.1 (declare (type spaces space))
598     (let ((code-words 0)
599     (no-ops 0)
600     (total-bytes 0))
601 wlott 1.4 (declare (fixnum code-words no-ops)
602     (type unsigned-byte total-bytes))
603 ram 1.1 (map-allocated-objects
604     #'(lambda (obj type size)
605 ram 1.14 (declare (fixnum size) (optimize (safety 0)))
606 ram 1.1 (when (eql type code-header-type)
607     (incf total-bytes size)
608 wlott 1.17 (let ((words (truly-the fixnum (%code-code-size obj)))
609 ram 1.1 (sap (truly-the system-area-pointer
610     (%primitive code-instructions obj))))
611     (incf code-words words)
612     (dotimes (i words)
613 wlott 1.15 (when (zerop (sap-ref-32 sap (* i vm:word-bytes)))
614     (incf no-ops))))))
615 ram 1.1 space)
616    
617     (format t
618 rtoy 1.40 (intl:gettext "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%")
619 ram 1.1 total-bytes code-words no-ops
620     (round (* no-ops 100) code-words)))
621    
622     (values))
623    
624    
625 wlott 1.4 ;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE -- Public
626     ;;;
627     (defun descriptor-vs-non-descriptor-storage (&rest spaces)
628     (let ((descriptor-words 0)
629     (non-descriptor-headers 0)
630     (non-descriptor-bytes 0))
631     (declare (type unsigned-byte descriptor-words non-descriptor-headers
632     non-descriptor-bytes))
633     (dolist (space (or spaces '(:read-only :static :dynamic)))
634     (declare (inline map-allocated-objects))
635     (map-allocated-objects
636     #'(lambda (obj type size)
637 ram 1.14 (declare (fixnum size) (optimize (safety 0)))
638 wlott 1.4 (case type
639     (#.code-header-type
640 wlott 1.17 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
641 wlott 1.4 (declare (type fixnum inst-words))
642     (incf non-descriptor-bytes (* inst-words word-bytes))
643     (incf descriptor-words
644     (- (truncate size word-bytes) inst-words))))
645     ((#.bignum-type
646     #.single-float-type
647     #.double-float-type
648 rtoy 1.35 #+double-double
649     #.double-double-float-type
650     #.complex-single-float-type
651     #.complex-double-float-type
652     #+double-double
653     #.complex-double-double-float-type
654 wlott 1.4 #.simple-string-type
655     #.simple-bit-vector-type
656     #.simple-array-unsigned-byte-2-type
657     #.simple-array-unsigned-byte-4-type
658     #.simple-array-unsigned-byte-8-type
659     #.simple-array-unsigned-byte-16-type
660     #.simple-array-unsigned-byte-32-type
661 dtc 1.27 #.simple-array-signed-byte-8-type
662     #.simple-array-signed-byte-16-type
663     #.simple-array-signed-byte-30-type
664     #.simple-array-signed-byte-32-type
665 wlott 1.4 #.simple-array-single-float-type
666 dtc 1.26 #.simple-array-double-float-type
667 rtoy 1.35 #+double-double
668     #.simple-array-double-double-float-type
669 dtc 1.27 #.simple-array-complex-single-float-type
670 rtoy 1.35 #.simple-array-complex-double-float-type
671     #+double-double
672     #.simple-array-complex-double-double-float-type)
673 wlott 1.4 (incf non-descriptor-headers)
674     (incf non-descriptor-bytes (- size word-bytes)))
675     ((#.list-pointer-type
676 ram 1.19 #.instance-pointer-type
677 wlott 1.4 #.ratio-type
678     #.complex-type
679     #.simple-array-type
680     #.simple-vector-type
681     #.complex-string-type
682     #.complex-bit-vector-type
683     #.complex-vector-type
684     #.complex-array-type
685     #.closure-header-type
686     #.funcallable-instance-header-type
687     #.value-cell-header-type
688     #.symbol-header-type
689     #.sap-type
690     #.weak-pointer-type
691 rtoy 1.35 #.instance-header-type
692     #.fdefn-type
693     #+gencgc
694     #.scavenger-hook-type)
695 wlott 1.4 (incf descriptor-words (truncate size word-bytes)))
696     (t
697 rtoy 1.40 (error (intl:gettext "Bogus type: ~D") type))))
698 wlott 1.4 space))
699 rtoy 1.40 (format t (intl:gettext "~:D words allocated for descriptor objects.~%")
700 wlott 1.4 descriptor-words)
701 rtoy 1.40 (format t (intl:gettext "~:D bytes data/~:D words header for non-descriptor objects.~%")
702 wlott 1.4 non-descriptor-bytes non-descriptor-headers)
703     (values)))
704    
705    
706 ram 1.19 ;;; INSTANCE-USAGE -- Public
707 ram 1.1 ;;;
708 ram 1.19 (defun instance-usage (space &key (top-n 15))
709 ram 1.1 (declare (type spaces space) (type (or fixnum null) top-n))
710 rtoy 1.39 "Print a breakdown by instance type of all the instances allocated in
711 ram 1.1 Space. If TOP-N is true, print only information for the the TOP-N types with
712     largest usage."
713 rtoy 1.40 (format t (intl:gettext "~2&~@[Top ~D ~]~(~A~) instance types:~%") top-n space)
714 ram 1.1 (let ((totals (make-hash-table :test #'eq))
715     (total-objects 0)
716     (total-bytes 0))
717 toy 1.31 (declare (fixnum total-objects)
718     (type memory-size total-bytes))
719 ram 1.1 (map-allocated-objects
720     #'(lambda (obj type size)
721 toy 1.31 (declare (type memory-size size) (optimize (speed 3) (safety 0)))
722 ram 1.19 (when (eql type instance-header-type)
723 ram 1.1 (incf total-objects)
724     (incf total-bytes size)
725 ram 1.19 (let* ((class (layout-class (%instance-ref obj 0)))
726     (found (gethash class totals)))
727 ram 1.1 (cond (found
728     (incf (the fixnum (car found)))
729     (incf (the fixnum (cdr found)) size))
730     (t
731 ram 1.19 (setf (gethash class totals) (cons 1 size)))))))
732 ram 1.1 space)
733    
734     (collect ((totals-list))
735 ram 1.19 (maphash #'(lambda (class what)
736     (totals-list (cons (prin1-to-string
737     (class-proper-name class))
738     what)))
739 ram 1.1 totals)
740     (let ((sorted (sort (totals-list) #'> :key #'cddr))
741     (printed-bytes 0)
742     (printed-objects 0))
743 toy 1.31 (declare (type memory-size printed-bytes printed-objects))
744 ram 1.1 (dolist (what (if top-n
745     (subseq sorted 0 (min (length sorted) top-n))
746     sorted))
747     (let ((bytes (cddr what))
748     (objects (cadr what)))
749     (incf printed-bytes bytes)
750     (incf printed-objects objects)
751 rtoy 1.38 (format t (intl:ngettext " ~32A: ~7:D bytes, ~5D object.~%"
752     " ~32A: ~7:D bytes, ~5D objects.~%"
753     objects)
754     (car what)
755 ram 1.1 bytes objects)))
756    
757     (let ((residual-objects (- total-objects printed-objects))
758     (residual-bytes (- total-bytes printed-bytes)))
759     (unless (zerop residual-objects)
760 rtoy 1.38 (format t (intl:ngettext " Other types: ~:D bytes, ~D: object~:P.~%"
761     " Other types: ~:D bytes, ~D: object~:P.~%"
762     residual-objects)
763 ram 1.1 residual-bytes residual-objects))))
764    
765 rtoy 1.38 (format t (intl:ngettext " ~:(~A~) instance total: ~:D bytes, ~:D object.~%"
766     " ~:(~A~) instance total: ~:D bytes, ~:D objects.~%"
767     total-objects)
768 ram 1.10 space total-bytes total-objects)))
769 ram 1.1
770 wlott 1.2 (values))
771    
772    
773     ;;; FIND-HOLES -- Public
774     ;;;
775     (defun find-holes (&rest spaces)
776     (dolist (space (or spaces '(:read-only :static :dynamic)))
777 rtoy 1.40 (format t (intl:gettext "In ~A space:~%") space)
778 wlott 1.2 (let ((start-addr nil)
779     (total-bytes 0))
780     (declare (type (or null (unsigned-byte 32)) start-addr)
781     (type (unsigned-byte 32) total-bytes))
782     (map-allocated-objects
783     #'(lambda (object typecode bytes)
784     (declare (ignore typecode)
785     (type (unsigned-byte 32) bytes))
786     (if (and (consp object)
787     (eql (car object) 0)
788     (eql (cdr object) 0))
789     (if start-addr
790     (incf total-bytes bytes)
791     (setf start-addr (di::get-lisp-obj-address object)
792     total-bytes bytes))
793     (when start-addr
794 rtoy 1.40 (format t (intl:gettext "~D bytes at #x~X~%") total-bytes start-addr)
795 wlott 1.2 (setf start-addr nil))))
796     space)
797     (when start-addr
798 rtoy 1.40 (format t (intl:gettext "~D bytes at #x~X~%") total-bytes start-addr))))
799 ram 1.6 (values))
800    
801    
802     ;;; Print allocated objects:
803    
804     (defun print-allocated-objects (space &key (percent 0) (pages 5)
805 ram 1.9 type larger smaller count
806 ram 1.6 (stream *standard-output*))
807     (declare (type (integer 0 99) percent) (type c::index pages)
808 ram 1.9 (type stream stream) (type spaces space)
809     (type (or c::index null) type larger smaller count))
810 ram 1.6 (multiple-value-bind (start-sap end-sap)
811     (space-bounds space)
812     (let* ((space-start (sap-int start-sap))
813     (space-end (sap-int end-sap))
814     (space-size (- space-end space-start))
815 ram 1.11 (pagesize (system:get-page-size))
816 ram 1.6 (start (+ space-start (round (* space-size percent) 100)))
817 ram 1.20 (printed-conses (make-hash-table :test #'eq))
818 ram 1.6 (pages-so-far 0)
819 ram 1.9 (count-so-far 0)
820 ram 1.6 (last-page 0))
821     (declare (type (unsigned-byte 32) last-page start)
822 ram 1.9 (fixnum pages-so-far count-so-far pagesize))
823 ram 1.20 (labels ((note-conses (x)
824     (unless (or (atom x) (gethash x printed-conses))
825     (setf (gethash x printed-conses) t)
826     (note-conses (car x))
827     (note-conses (cdr x)))))
828     (map-allocated-objects
829     #'(lambda (obj obj-type size)
830     (declare (optimize (safety 0)))
831     (let ((addr (get-lisp-obj-address obj)))
832     (when (>= addr start)
833     (when (if count
834     (> count-so-far count)
835     (> pages-so-far pages))
836     (return-from print-allocated-objects (values)))
837    
838     (unless count
839 dtc 1.29 (let ((this-page (* (the (values (unsigned-byte 32) t)
840     (truncate addr pagesize))
841 ram 1.20 pagesize)))
842     (declare (type (unsigned-byte 32) this-page))
843     (when (/= this-page last-page)
844     (when (< pages-so-far pages)
845     (format stream "~2&**** Page ~D, address ~X:~%"
846     pages-so-far addr))
847     (setq last-page this-page)
848     (incf pages-so-far))))
849    
850     (when (and (or (not type) (eql obj-type type))
851     (or (not smaller) (<= size smaller))
852     (or (not larger) (>= size larger)))
853     (incf count-so-far)
854     (case type
855     (#.code-header-type
856     (let ((dinfo (%code-debug-info obj)))
857     (format stream "~&Code object: ~S~%"
858     (if dinfo
859     (c::compiled-debug-info-name dinfo)
860     "No debug info."))))
861     (#.symbol-header-type
862     (format stream "~&~S~%" obj))
863     (#.list-pointer-type
864     (unless (gethash obj printed-conses)
865     (note-conses obj)
866     (let ((*print-circle* t)
867     (*print-level* 5)
868     (*print-length* 10))
869     (format stream "~&~S~%" obj))))
870     (t
871     (fresh-line stream)
872     (let ((str (write-to-string obj :level 5 :length 10
873     :pretty nil)))
874     (unless (eql type instance-header-type)
875     (format stream "~S: " (type-of obj)))
876     (format stream "~A~%"
877     (subseq str 0 (min (length str) 60))))))))))
878     space))))
879     (values))
880    
881    
882     ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
883    
884     (defvar *ignore-after* nil)
885    
886     (defun maybe-cons (space x stuff)
887     (if (or (not (eq space :dynamic))
888     (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
889     (cons x stuff)
890     stuff))
891    
892     (defun list-allocated-objects (space &key type larger smaller count
893     test)
894     (declare (type spaces space)
895     (type (or c::index null) larger smaller type count)
896     (type (or function null) test)
897     (inline map-allocated-objects))
898     (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
899     (collect ((counted 0 1+))
900     (let ((res ()))
901 ram 1.6 (map-allocated-objects
902 ram 1.9 #'(lambda (obj obj-type size)
903 ram 1.14 (declare (optimize (safety 0)))
904 ram 1.20 (when (and (or (not type) (eql obj-type type))
905     (or (not smaller) (<= size smaller))
906     (or (not larger) (>= size larger))
907     (or (not test) (funcall test obj)))
908     (setq res (maybe-cons space obj res))
909     (when (and count (>= (counted) count))
910     (return-from list-allocated-objects res))))
911     space)
912     res)))
913 ram 1.9
914 ram 1.20 (defun list-referencing-objects (space object)
915     (declare (type spaces space) (inline map-allocated-objects))
916     (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
917     (let ((res ()))
918     (flet ((res (x)
919     (setq res (maybe-cons space x res))))
920     (map-allocated-objects
921     #'(lambda (obj obj-type size)
922     (declare (optimize (safety 0)) (ignore obj-type size))
923     (typecase obj
924     (cons
925     (when (or (eq (car obj) object) (eq (cdr obj) object))
926     (res obj)))
927     (instance
928     (dotimes (i (%instance-length obj))
929     (when (eq (%instance-ref obj i) object)
930     (res obj)
931     (return))))
932     (simple-vector
933     (dotimes (i (length obj))
934     (when (eq (svref obj i) object)
935     (res obj)
936     (return))))
937     (symbol
938     (when (or (eq (symbol-name obj) object)
939     (eq (symbol-package obj) object)
940     (eq (symbol-plist obj) object)
941     (eq (symbol-value obj) object))
942     (res obj)))))
943     space))
944     res))
945    
946 ram 1.7
947     ;;;; Misc:
948    
949     (defun uninterned-symbol-count (space)
950     (declare (type spaces space))
951     (let ((total 0)
952     (uninterned 0))
953     (map-allocated-objects
954     #'(lambda (obj type size)
955     (declare (ignore type size))
956     (when (symbolp obj)
957     (incf total)
958     (unless (symbol-package obj)
959     (incf uninterned))))
960     space)
961     (values uninterned (float (/ uninterned total)))))
962    
963 ram 1.8
964     (defun code-breakdown (space &key (how :package))
965     (declare (type spaces space) (type (member :file :package) how))
966 ram 1.21 (let ((packages (make-hash-table :test #'equal)))
967 ram 1.7 (map-allocated-objects
968     #'(lambda (obj type size)
969     (when (eql type code-header-type)
970 ram 1.22 (let* ((dinfo (let ((x (%code-debug-info obj)))
971 ram 1.23 (when (typep x 'c::debug-info) x)))
972     (package (if (typep dinfo 'c::compiled-debug-info)
973 ram 1.21 (c::compiled-debug-info-package dinfo)
974     "UNKNOWN"))
975     (pkg-info (or (gethash package packages)
976     (setf (gethash package packages)
977     (make-hash-table :test #'equal))))
978 ram 1.22 (file
979     (if dinfo
980 ram 1.23 (let ((src (c::debug-info-source dinfo)))
981 ram 1.22 (cond (src
982     (let ((source
983     (first
984 ram 1.23 (c::debug-info-source
985 ram 1.22 dinfo))))
986     (if (eq (c::debug-source-from source)
987     :file)
988     (c::debug-source-name source)
989     "FROM LISP")))
990     (t
991 rtoy 1.40 (warn (intl:gettext "No source for ~S") obj)
992 ram 1.22 "NO SOURCE")))
993     "UNKNOWN"))
994 ram 1.21 (file-info (or (gethash file pkg-info)
995     (setf (gethash file pkg-info)
996     (cons 0 0)))))
997     (incf (car file-info))
998     (incf (cdr file-info) size))))
999 ram 1.7 space)
1000    
1001 ram 1.21 (let ((res ()))
1002     (do-hash (pkg pkg-info packages)
1003     (let ((pkg-res ())
1004     (pkg-count 0)
1005     (pkg-size 0))
1006     (do-hash (file file-info pkg-info)
1007     (incf pkg-count (car file-info))
1008     (incf pkg-size (cdr file-info))
1009     (push (list file file-info) pkg-res))
1010     (push (cons pkg-count pkg-size) pkg-res)
1011     (push pkg pkg-res)
1012     (push pkg-res res)))
1013    
1014     (loop for (pkg (pkg-count . pkg-size) . files) in
1015     (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
1016 rtoy 1.38 (format t (intl:ngettext "~%Package ~A: ~32T~9:D bytes, ~9:D object.~%"
1017     "~%Package ~A: ~32T~9:D bytes, ~9:D objects.~%"
1018     pkg-count)
1019 ram 1.21 pkg pkg-size pkg-count)
1020     (when (eq how :file)
1021     (loop for (file (file-count . file-size)) in
1022     (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
1023 rtoy 1.38 (format t (intl:ngettext "~30@A: ~9:D bytes, ~9:D object.~%"
1024     "~30@A: ~9:D bytes, ~9:D objects.~%"
1025     file-count)
1026 ram 1.21 (file-namestring file) file-size file-count))))))
1027    
1028 ram 1.8 (values))
1029    
1030    
1031     ;;;; Histogram interface. Uses Scott's Hist package.
1032     #+nil
1033     (defun memory-histogram (space &key (low 4) (high 20)
1034     (bucket-size 1)
1035     (function
1036     #'(lambda (obj type size)
1037     (declare (ignore obj type) (fixnum size))
1038 ram 1.9 (integer-length (1- size))))
1039 ram 1.8 (type nil))
1040     (let ((function (if (eval:interpreted-function-p function)
1041     (compile nil function)
1042     function)))
1043     (hist:hist (low high bucket-size)
1044     (map-allocated-objects
1045     #'(lambda (obj this-type size)
1046     (when (or (not type) (eql this-type type))
1047     (hist:hist-record (funcall function obj type size))))
1048     space)))
1049     (values))
1050    
1051     ;;; Return the number of fbound constants in a code object.
1052     ;;;
1053     (defun code-object-calls (obj)
1054     (loop for i from code-constants-offset below (get-header-data obj)
1055     count (find-code-object (code-header-ref obj i))))
1056    
1057     ;;; Return the number of calls in Obj to functions with <= N calls. Calls is
1058     ;;; an eq hashtable translating code objects to the number of references.
1059     ;;;
1060     (defun code-object-leaf-calls (obj n calls)
1061     (loop for i from code-constants-offset below (get-header-data obj)
1062     count (let ((code (find-code-object (code-header-ref obj i))))
1063     (and code (<= (gethash code calls 0) n)))))
1064    
1065     #+nil
1066     (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
1067     (function #'identity))
1068 rtoy 1.38 _N"Given a hashtable, print a histogram of the contents. Function should give
1069 ram 1.8 the value to plot when applied to the hashtable values."
1070     (let ((function (if (eval:interpreted-function-p function)
1071     (compile nil function)
1072     function)))
1073     (hist:hist (low high bucket-size)
1074     (loop for count being each hash-value in table do
1075     (hist:hist-record (funcall function count))))))
1076    
1077     (defun report-top-n (table &key (top-n 20) (function #'identity))
1078 rtoy 1.39 "Report the Top-N entries in the hashtable Table, when sorted by Function
1079 ram 1.8 applied to the hash value. If Top-N is NIL, report all entries."
1080     (let ((function (if (eval:interpreted-function-p function)
1081     (compile nil function)
1082     function)))
1083     (collect ((totals-list)
1084     (total-val 0 +))
1085     (maphash #'(lambda (name what)
1086     (let ((val (funcall function what)))
1087     (totals-list (cons name val))
1088     (total-val val)))
1089     table)
1090     (let ((sorted (sort (totals-list) #'> :key #'cdr))
1091     (printed 0))
1092     (declare (fixnum printed))
1093     (dolist (what (if top-n
1094     (subseq sorted 0 (min (length sorted) top-n))
1095     sorted))
1096     (let ((val (cdr what)))
1097     (incf printed val)
1098     (format t "~8:D: ~S~%" val (car what))))
1099    
1100     (let ((residual (- (total-val) printed)))
1101     (unless (zerop residual)
1102 rtoy 1.40 (format t (intl:gettext "~8:D: Other~%") residual))))
1103 ram 1.8
1104 rtoy 1.40 (format t (intl:gettext "~8:D: Total~%") (total-val))))
1105 ram 1.8 (values))
1106    
1107    
1108     ;;; Given any Lisp object, return the associated code object, or NIL.
1109     ;;;
1110     (defun find-code-object (const)
1111     (flet ((frob (def)
1112     (function-code-header
1113     (ecase (get-type def)
1114     ((#.closure-header-type
1115     #.funcallable-instance-header-type)
1116     (%closure-function def))
1117     (#.function-header-type
1118     def)))))
1119     (typecase const
1120     (function (frob const))
1121     (symbol
1122     (if (fboundp const)
1123     (frob (symbol-function const))
1124     nil))
1125     (t nil))))
1126    
1127    
1128     (defun find-caller-counts (space)
1129 rtoy 1.39 "Return a hashtable mapping each function in for which a call appears in
1130 ram 1.8 Space to the number of times such a call appears."
1131     (let ((counts (make-hash-table :test #'eq)))
1132     (map-allocated-objects
1133     #'(lambda (obj type size)
1134     (declare (ignore size))
1135     (when (eql type code-header-type)
1136     (loop for i from code-constants-offset below (get-header-data obj)
1137     do (let ((code (find-code-object (code-header-ref obj i))))
1138     (when code
1139     (incf (gethash code counts 0)))))))
1140     space)
1141     counts))
1142    
1143     (defun find-high-callers (space &key (above 10) table (threshold 2))
1144 rtoy 1.39 "Return a hashtable translating code objects to function constant counts for
1145 ram 1.8 all code objects in Space with more than Above function constants."
1146     (let ((counts (make-hash-table :test #'eq)))
1147     (map-allocated-objects
1148     #'(lambda (obj type size)
1149     (declare (ignore size))
1150     (when (eql type code-header-type)
1151     (let ((count (if table
1152     (code-object-leaf-calls obj threshold table)
1153     (code-object-calls obj))))
1154     (when (> count above)
1155     (setf (gethash obj counts) count)))))
1156     space)
1157     counts))

  ViewVC Help
Powered by ViewVC 1.1.5