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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37.10.3 - (hide annotations)
Tue Mar 2 00:39:17 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-branch
Changes since 1.37.10.2: +10 -4 lines
code/macros.lisp:
code/room.lisp:
o Change some strings with ~P to call NGETTEXT so plurals can be
  translated correctly.

i18n/local/cmucl.pot:
o Regenerated.

i18n/locale/ko/LC_MESSAGES/cmucl.po:
o Re-merged.
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.10.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/room.lisp,v 1.37.10.3 2010/03/02 00:39:17 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 rtoy 1.37.10.1 (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.37.10.2 (format t _"~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.37.10.2 (format t _"~%~A:~% ~:D bytes, ~:D object~:P"
513 ram 1.1 name total-bytes total-objects)
514     (dolist (space (spaces))
515     (format t ", ~D% ~(~A~)"
516     (round (* (cdr space) 100) total-bytes)
517     (car space)))
518     (format t ".~%")
519     (incf summary-total-bytes total-bytes)
520     (incf summary-total-objects total-objects))))
521 rtoy 1.37.10.2 (format t _"~%Summary total:~% ~:D bytes, ~:D objects.~%"
522 ram 1.1 summary-total-bytes summary-total-objects)))))
523    
524    
525 ram 1.10 ;;; REPORT-SPACE-TOTAL -- Internal
526     ;;;
527     ;;; Report object usage for a single space.
528     ;;;
529     (defun report-space-total (space-total cutoff)
530     (declare (list space-total) (type (or single-float null) cutoff))
531 rtoy 1.37.10.2 (format t _"~2&Breakdown for ~(~A~) space:~%" (car space-total))
532 ram 1.10 (let* ((types (cdr space-total))
533     (total-bytes (reduce #'+ (mapcar #'first types)))
534     (total-objects (reduce #'+ (mapcar #'second types)))
535     (cutoff-point (if cutoff
536     (truncate (* (float total-bytes) cutoff))
537     0))
538     (reported-bytes 0)
539     (reported-objects 0))
540 toy 1.31 (declare (fixnum total-objects cutoff-point reported-objects)
541     (type memory-size total-bytes reported-bytes))
542 ram 1.10 (loop for (bytes objects name) in types do
543     (when (<= bytes cutoff-point)
544 rtoy 1.37.10.3 (format t (intl:ngettext " ~13:D bytes for ~9:D other object.~%"
545     " ~13:D bytes for ~9:D other objects.~%"
546     (- total-objects reported-objects))
547 ram 1.10 (- total-bytes reported-bytes)
548     (- total-objects reported-objects))
549     (return))
550     (incf reported-bytes bytes)
551     (incf reported-objects objects)
552 rtoy 1.37.10.3 (format t (intl:ngettext " ~13:D bytes for ~9:D ~(~A~) object.~%"
553     " ~13:D bytes for ~9:D ~(~A~) objects.~%"
554     objects)
555 ram 1.10 bytes objects name))
556 rtoy 1.37.10.3 (format t (intl:ngettext " ~13:D bytes for ~9:D ~(~A~) object (space total.)~%"
557     " ~13:D bytes for ~9:D ~(~A~) objects (space total.)~%"
558     total-objects)
559 ram 1.10 total-bytes total-objects (car space-total))))
560    
561    
562 ram 1.1 ;;; MEMORY-USAGE -- Public
563     ;;;
564     (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
565 ram 1.10 (print-summary t) cutoff)
566 rtoy 1.37.10.2 _N"Print out information about the heap memory in use. :Print-Spaces is a list
567 ram 1.1 of the spaces to print detailed information for. :Count-Spaces is a list of
568     the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
569     and :Read-Only.) If :Print-Summary is true, then summary information will be
570 ram 1.10 printed. The defaults print only summary information for dynamic space.
571     If true, Cutoff is a fraction of the usage in a report below which types will
572     be combined as OTHER."
573     (declare (type (or single-float null) cutoff))
574 ram 1.1 (let* ((spaces (if (eq count-spaces t)
575     '(:static :dynamic :read-only)
576     count-spaces))
577     (totals (mapcar #'(lambda (space)
578     (cons space (type-breakdown space)))
579     spaces)))
580    
581     (dolist (space-total totals)
582     (when (or (eq print-spaces t)
583     (member (car space-total) print-spaces))
584 ram 1.10 (report-space-total space-total cutoff)))
585 ram 1.1
586     (when print-summary (print-summary spaces totals)))
587    
588     (values))
589    
590    
591     ;;; COUNT-NO-OPS -- Public
592     ;;;
593     (defun count-no-ops (space)
594 rtoy 1.37.10.2 _N"Print info about how much code and no-ops there are in Space."
595 ram 1.1 (declare (type spaces space))
596     (let ((code-words 0)
597     (no-ops 0)
598     (total-bytes 0))
599 wlott 1.4 (declare (fixnum code-words no-ops)
600     (type unsigned-byte total-bytes))
601 ram 1.1 (map-allocated-objects
602     #'(lambda (obj type size)
603 ram 1.14 (declare (fixnum size) (optimize (safety 0)))
604 ram 1.1 (when (eql type code-header-type)
605     (incf total-bytes size)
606 wlott 1.17 (let ((words (truly-the fixnum (%code-code-size obj)))
607 ram 1.1 (sap (truly-the system-area-pointer
608     (%primitive code-instructions obj))))
609     (incf code-words words)
610     (dotimes (i words)
611 wlott 1.15 (when (zerop (sap-ref-32 sap (* i vm:word-bytes)))
612     (incf no-ops))))))
613 ram 1.1 space)
614    
615     (format t
616 rtoy 1.37.10.2 _"~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
617 ram 1.1 total-bytes code-words no-ops
618     (round (* no-ops 100) code-words)))
619    
620     (values))
621    
622    
623 wlott 1.4 ;;; DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE -- Public
624     ;;;
625     (defun descriptor-vs-non-descriptor-storage (&rest spaces)
626     (let ((descriptor-words 0)
627     (non-descriptor-headers 0)
628     (non-descriptor-bytes 0))
629     (declare (type unsigned-byte descriptor-words non-descriptor-headers
630     non-descriptor-bytes))
631     (dolist (space (or spaces '(:read-only :static :dynamic)))
632     (declare (inline map-allocated-objects))
633     (map-allocated-objects
634     #'(lambda (obj type size)
635 ram 1.14 (declare (fixnum size) (optimize (safety 0)))
636 wlott 1.4 (case type
637     (#.code-header-type
638 wlott 1.17 (let ((inst-words (truly-the fixnum (%code-code-size obj))))
639 wlott 1.4 (declare (type fixnum inst-words))
640     (incf non-descriptor-bytes (* inst-words word-bytes))
641     (incf descriptor-words
642     (- (truncate size word-bytes) inst-words))))
643     ((#.bignum-type
644     #.single-float-type
645     #.double-float-type
646 rtoy 1.35 #+double-double
647     #.double-double-float-type
648     #.complex-single-float-type
649     #.complex-double-float-type
650     #+double-double
651     #.complex-double-double-float-type
652 wlott 1.4 #.simple-string-type
653     #.simple-bit-vector-type
654     #.simple-array-unsigned-byte-2-type
655     #.simple-array-unsigned-byte-4-type
656     #.simple-array-unsigned-byte-8-type
657     #.simple-array-unsigned-byte-16-type
658     #.simple-array-unsigned-byte-32-type
659 dtc 1.27 #.simple-array-signed-byte-8-type
660     #.simple-array-signed-byte-16-type
661     #.simple-array-signed-byte-30-type
662     #.simple-array-signed-byte-32-type
663 wlott 1.4 #.simple-array-single-float-type
664 dtc 1.26 #.simple-array-double-float-type
665 rtoy 1.35 #+double-double
666     #.simple-array-double-double-float-type
667 dtc 1.27 #.simple-array-complex-single-float-type
668 rtoy 1.35 #.simple-array-complex-double-float-type
669     #+double-double
670     #.simple-array-complex-double-double-float-type)
671 wlott 1.4 (incf non-descriptor-headers)
672     (incf non-descriptor-bytes (- size word-bytes)))
673     ((#.list-pointer-type
674 ram 1.19 #.instance-pointer-type
675 wlott 1.4 #.ratio-type
676     #.complex-type
677     #.simple-array-type
678     #.simple-vector-type
679     #.complex-string-type
680     #.complex-bit-vector-type
681     #.complex-vector-type
682     #.complex-array-type
683     #.closure-header-type
684     #.funcallable-instance-header-type
685     #.value-cell-header-type
686     #.symbol-header-type
687     #.sap-type
688     #.weak-pointer-type
689 rtoy 1.35 #.instance-header-type
690     #.fdefn-type
691     #+gencgc
692     #.scavenger-hook-type)
693 wlott 1.4 (incf descriptor-words (truncate size word-bytes)))
694     (t
695 rtoy 1.37.10.2 (error _"Bogus type: ~D" type))))
696 wlott 1.4 space))
697 rtoy 1.37.10.2 (format t _"~:D words allocated for descriptor objects.~%"
698 wlott 1.4 descriptor-words)
699 rtoy 1.37.10.2 (format t _"~:D bytes data/~:D words header for non-descriptor objects.~%"
700 wlott 1.4 non-descriptor-bytes non-descriptor-headers)
701     (values)))
702    
703    
704 ram 1.19 ;;; INSTANCE-USAGE -- Public
705 ram 1.1 ;;;
706 ram 1.19 (defun instance-usage (space &key (top-n 15))
707 ram 1.1 (declare (type spaces space) (type (or fixnum null) top-n))
708 rtoy 1.37.10.2 _N"Print a breakdown by instance type of all the instances allocated in
709 ram 1.1 Space. If TOP-N is true, print only information for the the TOP-N types with
710     largest usage."
711 rtoy 1.37.10.2 (format t _"~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
712 ram 1.1 (let ((totals (make-hash-table :test #'eq))
713     (total-objects 0)
714     (total-bytes 0))
715 toy 1.31 (declare (fixnum total-objects)
716     (type memory-size total-bytes))
717 ram 1.1 (map-allocated-objects
718     #'(lambda (obj type size)
719 toy 1.31 (declare (type memory-size size) (optimize (speed 3) (safety 0)))
720 ram 1.19 (when (eql type instance-header-type)
721 ram 1.1 (incf total-objects)
722     (incf total-bytes size)
723 ram 1.19 (let* ((class (layout-class (%instance-ref obj 0)))
724     (found (gethash class totals)))
725 ram 1.1 (cond (found
726     (incf (the fixnum (car found)))
727     (incf (the fixnum (cdr found)) size))
728     (t
729 ram 1.19 (setf (gethash class totals) (cons 1 size)))))))
730 ram 1.1 space)
731    
732     (collect ((totals-list))
733 ram 1.19 (maphash #'(lambda (class what)
734     (totals-list (cons (prin1-to-string
735     (class-proper-name class))
736     what)))
737 ram 1.1 totals)
738     (let ((sorted (sort (totals-list) #'> :key #'cddr))
739     (printed-bytes 0)
740     (printed-objects 0))
741 toy 1.31 (declare (type memory-size printed-bytes printed-objects))
742 ram 1.1 (dolist (what (if top-n
743     (subseq sorted 0 (min (length sorted) top-n))
744     sorted))
745     (let ((bytes (cddr what))
746     (objects (cadr what)))
747     (incf printed-bytes bytes)
748     (incf printed-objects objects)
749 rtoy 1.37.10.2 (format t _" ~32A: ~7:D bytes, ~5D object~:P.~%" (car what)
750 ram 1.1 bytes objects)))
751    
752     (let ((residual-objects (- total-objects printed-objects))
753     (residual-bytes (- total-bytes printed-bytes)))
754     (unless (zerop residual-objects)
755 rtoy 1.37.10.2 (format t _" Other types: ~:D bytes, ~D: object~:P.~%"
756 ram 1.1 residual-bytes residual-objects))))
757    
758 rtoy 1.37.10.2 (format t _" ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
759 ram 1.10 space total-bytes total-objects)))
760 ram 1.1
761 wlott 1.2 (values))
762    
763    
764     ;;; FIND-HOLES -- Public
765     ;;;
766     (defun find-holes (&rest spaces)
767     (dolist (space (or spaces '(:read-only :static :dynamic)))
768 rtoy 1.37.10.2 (format t _"In ~A space:~%" space)
769 wlott 1.2 (let ((start-addr nil)
770     (total-bytes 0))
771     (declare (type (or null (unsigned-byte 32)) start-addr)
772     (type (unsigned-byte 32) total-bytes))
773     (map-allocated-objects
774     #'(lambda (object typecode bytes)
775     (declare (ignore typecode)
776     (type (unsigned-byte 32) bytes))
777     (if (and (consp object)
778     (eql (car object) 0)
779     (eql (cdr object) 0))
780     (if start-addr
781     (incf total-bytes bytes)
782     (setf start-addr (di::get-lisp-obj-address object)
783     total-bytes bytes))
784     (when start-addr
785 rtoy 1.37.10.2 (format t _"~D bytes at #x~X~%" total-bytes start-addr)
786 wlott 1.2 (setf start-addr nil))))
787     space)
788     (when start-addr
789 rtoy 1.37.10.2 (format t _"~D bytes at #x~X~%" total-bytes start-addr))))
790 ram 1.6 (values))
791    
792    
793     ;;; Print allocated objects:
794    
795     (defun print-allocated-objects (space &key (percent 0) (pages 5)
796 ram 1.9 type larger smaller count
797 ram 1.6 (stream *standard-output*))
798     (declare (type (integer 0 99) percent) (type c::index pages)
799 ram 1.9 (type stream stream) (type spaces space)
800     (type (or c::index null) type larger smaller count))
801 ram 1.6 (multiple-value-bind (start-sap end-sap)
802     (space-bounds space)
803     (let* ((space-start (sap-int start-sap))
804     (space-end (sap-int end-sap))
805     (space-size (- space-end space-start))
806 ram 1.11 (pagesize (system:get-page-size))
807 ram 1.6 (start (+ space-start (round (* space-size percent) 100)))
808 ram 1.20 (printed-conses (make-hash-table :test #'eq))
809 ram 1.6 (pages-so-far 0)
810 ram 1.9 (count-so-far 0)
811 ram 1.6 (last-page 0))
812     (declare (type (unsigned-byte 32) last-page start)
813 ram 1.9 (fixnum pages-so-far count-so-far pagesize))
814 ram 1.20 (labels ((note-conses (x)
815     (unless (or (atom x) (gethash x printed-conses))
816     (setf (gethash x printed-conses) t)
817     (note-conses (car x))
818     (note-conses (cdr x)))))
819     (map-allocated-objects
820     #'(lambda (obj obj-type size)
821     (declare (optimize (safety 0)))
822     (let ((addr (get-lisp-obj-address obj)))
823     (when (>= addr start)
824     (when (if count
825     (> count-so-far count)
826     (> pages-so-far pages))
827     (return-from print-allocated-objects (values)))
828    
829     (unless count
830 dtc 1.29 (let ((this-page (* (the (values (unsigned-byte 32) t)
831     (truncate addr pagesize))
832 ram 1.20 pagesize)))
833     (declare (type (unsigned-byte 32) this-page))
834     (when (/= this-page last-page)
835     (when (< pages-so-far pages)
836     (format stream "~2&**** Page ~D, address ~X:~%"
837     pages-so-far addr))
838     (setq last-page this-page)
839     (incf pages-so-far))))
840    
841     (when (and (or (not type) (eql obj-type type))
842     (or (not smaller) (<= size smaller))
843     (or (not larger) (>= size larger)))
844     (incf count-so-far)
845     (case type
846     (#.code-header-type
847     (let ((dinfo (%code-debug-info obj)))
848     (format stream "~&Code object: ~S~%"
849     (if dinfo
850     (c::compiled-debug-info-name dinfo)
851     "No debug info."))))
852     (#.symbol-header-type
853     (format stream "~&~S~%" obj))
854     (#.list-pointer-type
855     (unless (gethash obj printed-conses)
856     (note-conses obj)
857     (let ((*print-circle* t)
858     (*print-level* 5)
859     (*print-length* 10))
860     (format stream "~&~S~%" obj))))
861     (t
862     (fresh-line stream)
863     (let ((str (write-to-string obj :level 5 :length 10
864     :pretty nil)))
865     (unless (eql type instance-header-type)
866     (format stream "~S: " (type-of obj)))
867     (format stream "~A~%"
868     (subseq str 0 (min (length str) 60))))))))))
869     space))))
870     (values))
871    
872    
873     ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
874    
875     (defvar *ignore-after* nil)
876    
877     (defun maybe-cons (space x stuff)
878     (if (or (not (eq space :dynamic))
879     (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
880     (cons x stuff)
881     stuff))
882    
883     (defun list-allocated-objects (space &key type larger smaller count
884     test)
885     (declare (type spaces space)
886     (type (or c::index null) larger smaller type count)
887     (type (or function null) test)
888     (inline map-allocated-objects))
889     (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
890     (collect ((counted 0 1+))
891     (let ((res ()))
892 ram 1.6 (map-allocated-objects
893 ram 1.9 #'(lambda (obj obj-type size)
894 ram 1.14 (declare (optimize (safety 0)))
895 ram 1.20 (when (and (or (not type) (eql obj-type type))
896     (or (not smaller) (<= size smaller))
897     (or (not larger) (>= size larger))
898     (or (not test) (funcall test obj)))
899     (setq res (maybe-cons space obj res))
900     (when (and count (>= (counted) count))
901     (return-from list-allocated-objects res))))
902     space)
903     res)))
904 ram 1.9
905 ram 1.20 (defun list-referencing-objects (space object)
906     (declare (type spaces space) (inline map-allocated-objects))
907     (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
908     (let ((res ()))
909     (flet ((res (x)
910     (setq res (maybe-cons space x res))))
911     (map-allocated-objects
912     #'(lambda (obj obj-type size)
913     (declare (optimize (safety 0)) (ignore obj-type size))
914     (typecase obj
915     (cons
916     (when (or (eq (car obj) object) (eq (cdr obj) object))
917     (res obj)))
918     (instance
919     (dotimes (i (%instance-length obj))
920     (when (eq (%instance-ref obj i) object)
921     (res obj)
922     (return))))
923     (simple-vector
924     (dotimes (i (length obj))
925     (when (eq (svref obj i) object)
926     (res obj)
927     (return))))
928     (symbol
929     (when (or (eq (symbol-name obj) object)
930     (eq (symbol-package obj) object)
931     (eq (symbol-plist obj) object)
932     (eq (symbol-value obj) object))
933     (res obj)))))
934     space))
935     res))
936    
937 ram 1.7
938     ;;;; Misc:
939    
940     (defun uninterned-symbol-count (space)
941     (declare (type spaces space))
942     (let ((total 0)
943     (uninterned 0))
944     (map-allocated-objects
945     #'(lambda (obj type size)
946     (declare (ignore type size))
947     (when (symbolp obj)
948     (incf total)
949     (unless (symbol-package obj)
950     (incf uninterned))))
951     space)
952     (values uninterned (float (/ uninterned total)))))
953    
954 ram 1.8
955     (defun code-breakdown (space &key (how :package))
956     (declare (type spaces space) (type (member :file :package) how))
957 ram 1.21 (let ((packages (make-hash-table :test #'equal)))
958 ram 1.7 (map-allocated-objects
959     #'(lambda (obj type size)
960     (when (eql type code-header-type)
961 ram 1.22 (let* ((dinfo (let ((x (%code-debug-info obj)))
962 ram 1.23 (when (typep x 'c::debug-info) x)))
963     (package (if (typep dinfo 'c::compiled-debug-info)
964 ram 1.21 (c::compiled-debug-info-package dinfo)
965     "UNKNOWN"))
966     (pkg-info (or (gethash package packages)
967     (setf (gethash package packages)
968     (make-hash-table :test #'equal))))
969 ram 1.22 (file
970     (if dinfo
971 ram 1.23 (let ((src (c::debug-info-source dinfo)))
972 ram 1.22 (cond (src
973     (let ((source
974     (first
975 ram 1.23 (c::debug-info-source
976 ram 1.22 dinfo))))
977     (if (eq (c::debug-source-from source)
978     :file)
979     (c::debug-source-name source)
980     "FROM LISP")))
981     (t
982 rtoy 1.37.10.2 (warn _"No source for ~S" obj)
983 ram 1.22 "NO SOURCE")))
984     "UNKNOWN"))
985 ram 1.21 (file-info (or (gethash file pkg-info)
986     (setf (gethash file pkg-info)
987     (cons 0 0)))))
988     (incf (car file-info))
989     (incf (cdr file-info) size))))
990 ram 1.7 space)
991    
992 ram 1.21 (let ((res ()))
993     (do-hash (pkg pkg-info packages)
994     (let ((pkg-res ())
995     (pkg-count 0)
996     (pkg-size 0))
997     (do-hash (file file-info pkg-info)
998     (incf pkg-count (car file-info))
999     (incf pkg-size (cdr file-info))
1000     (push (list file file-info) pkg-res))
1001     (push (cons pkg-count pkg-size) pkg-res)
1002     (push pkg pkg-res)
1003     (push pkg-res res)))
1004    
1005     (loop for (pkg (pkg-count . pkg-size) . files) in
1006     (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
1007 rtoy 1.37.10.2 (format t _"~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"
1008 ram 1.21 pkg pkg-size pkg-count)
1009     (when (eq how :file)
1010     (loop for (file (file-count . file-size)) in
1011     (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
1012 rtoy 1.37.10.2 (format t _"~30@A: ~9:D bytes, ~9:D object~:P.~%"
1013 ram 1.21 (file-namestring file) file-size file-count))))))
1014    
1015 ram 1.8 (values))
1016    
1017    
1018     ;;;; Histogram interface. Uses Scott's Hist package.
1019     #+nil
1020     (defun memory-histogram (space &key (low 4) (high 20)
1021     (bucket-size 1)
1022     (function
1023     #'(lambda (obj type size)
1024     (declare (ignore obj type) (fixnum size))
1025 ram 1.9 (integer-length (1- size))))
1026 ram 1.8 (type nil))
1027     (let ((function (if (eval:interpreted-function-p function)
1028     (compile nil function)
1029     function)))
1030     (hist:hist (low high bucket-size)
1031     (map-allocated-objects
1032     #'(lambda (obj this-type size)
1033     (when (or (not type) (eql this-type type))
1034     (hist:hist-record (funcall function obj type size))))
1035     space)))
1036     (values))
1037    
1038     ;;; Return the number of fbound constants in a code object.
1039     ;;;
1040     (defun code-object-calls (obj)
1041     (loop for i from code-constants-offset below (get-header-data obj)
1042     count (find-code-object (code-header-ref obj i))))
1043    
1044     ;;; Return the number of calls in Obj to functions with <= N calls. Calls is
1045     ;;; an eq hashtable translating code objects to the number of references.
1046     ;;;
1047     (defun code-object-leaf-calls (obj n calls)
1048     (loop for i from code-constants-offset below (get-header-data obj)
1049     count (let ((code (find-code-object (code-header-ref obj i))))
1050     (and code (<= (gethash code calls 0) n)))))
1051    
1052     #+nil
1053     (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
1054     (function #'identity))
1055 rtoy 1.37.10.2 _N"Given a hashtable, print a histogram of the contents. Function should give
1056 ram 1.8 the value to plot when applied to the hashtable values."
1057     (let ((function (if (eval:interpreted-function-p function)
1058     (compile nil function)
1059     function)))
1060     (hist:hist (low high bucket-size)
1061     (loop for count being each hash-value in table do
1062     (hist:hist-record (funcall function count))))))
1063    
1064     (defun report-top-n (table &key (top-n 20) (function #'identity))
1065 rtoy 1.37.10.2 _N"Report the Top-N entries in the hashtable Table, when sorted by Function
1066 ram 1.8 applied to the hash value. If Top-N is NIL, report all entries."
1067     (let ((function (if (eval:interpreted-function-p function)
1068     (compile nil function)
1069     function)))
1070     (collect ((totals-list)
1071     (total-val 0 +))
1072     (maphash #'(lambda (name what)
1073     (let ((val (funcall function what)))
1074     (totals-list (cons name val))
1075     (total-val val)))
1076     table)
1077     (let ((sorted (sort (totals-list) #'> :key #'cdr))
1078     (printed 0))
1079     (declare (fixnum printed))
1080     (dolist (what (if top-n
1081     (subseq sorted 0 (min (length sorted) top-n))
1082     sorted))
1083     (let ((val (cdr what)))
1084     (incf printed val)
1085     (format t "~8:D: ~S~%" val (car what))))
1086    
1087     (let ((residual (- (total-val) printed)))
1088     (unless (zerop residual)
1089 rtoy 1.37.10.2 (format t _"~8:D: Other~%" residual))))
1090 ram 1.8
1091 rtoy 1.37.10.2 (format t _"~8:D: Total~%" (total-val))))
1092 ram 1.8 (values))
1093    
1094    
1095     ;;; Given any Lisp object, return the associated code object, or NIL.
1096     ;;;
1097     (defun find-code-object (const)
1098     (flet ((frob (def)
1099     (function-code-header
1100     (ecase (get-type def)
1101     ((#.closure-header-type
1102     #.funcallable-instance-header-type)
1103     (%closure-function def))
1104     (#.function-header-type
1105     def)))))
1106     (typecase const
1107     (function (frob const))
1108     (symbol
1109     (if (fboundp const)
1110     (frob (symbol-function const))
1111     nil))
1112     (t nil))))
1113    
1114    
1115     (defun find-caller-counts (space)
1116 rtoy 1.37.10.2 _N"Return a hashtable mapping each function in for which a call appears in
1117 ram 1.8 Space to the number of times such a call appears."
1118     (let ((counts (make-hash-table :test #'eq)))
1119     (map-allocated-objects
1120     #'(lambda (obj type size)
1121     (declare (ignore size))
1122     (when (eql type code-header-type)
1123     (loop for i from code-constants-offset below (get-header-data obj)
1124     do (let ((code (find-code-object (code-header-ref obj i))))
1125     (when code
1126     (incf (gethash code counts 0)))))))
1127     space)
1128     counts))
1129    
1130     (defun find-high-callers (space &key (above 10) table (threshold 2))
1131 rtoy 1.37.10.2 _N"Return a hashtable translating code objects to function constant counts for
1132 ram 1.8 all code objects in Space with more than Above function constants."
1133     (let ((counts (make-hash-table :test #'eq)))
1134     (map-allocated-objects
1135     #'(lambda (obj type size)
1136     (declare (ignore size))
1137     (when (eql type code-header-type)
1138     (let ((count (if table
1139     (code-object-leaf-calls obj threshold table)
1140     (code-object-calls obj))))
1141     (when (> count above)
1142     (setf (gethash obj counts) count)))))
1143     space)
1144     counts))

  ViewVC Help
Powered by ViewVC 1.1.5