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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (hide annotations)
Thu Jul 20 16:19:35 2006 UTC (7 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, snapshot-2006-12, sse2-base, sse2-packed-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, snapshot-2007-01, snapshot-2007-02, release-19e, release-19d, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, release-19d-base, release-19e-pre1, release-19e-pre2, release-19d-pre2, release-19d-pre1, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, portable-clx-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, release-19d-branch, sse2-packed-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, unicode-utf16-extfmt-branch
Changes since 1.35: +151 -1 lines
Port sbcl's changes to room to handle gencgc allocation better.

lisp/gencgc.c:
o Make last_free_page non-static so Lisp can see it.
o Add get_page_table_info so Lisp can easily get at the flags and
  bytes_used slots of a page table entry.

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

  ViewVC Help
Powered by ViewVC 1.1.5