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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5