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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Sep 27 06:11:22 1990 UTC (23 years, 6 months ago) by wlott
Branch: MAIN
Changes since 1.1: +41 -6 lines
Fixed vector-total-size to return the correct value for strings.
Wrote FIND-HOLES, which finds any holes in the heap.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: VM -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; Spice Lisp is currently incomplete and under active development.
7     ;;; If you want to use this code or any part of Spice Lisp, please contact
8     ;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU).
9     ;;; **********************************************************************
10     ;;;
11 wlott 1.2 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/room.lisp,v 1.2 1990/09/27 06:11:22 wlott Exp $
12 ram 1.1 ;;;
13     ;;; Heap grovelling memory usage stuff.
14     ;;;
15     (in-package "VM")
16     (use-package "SYSTEM")
17     (in-package "C")
18     (import '(function-code-header make-lisp-obj dynamic-space-free-pointer
19     code-code-size vector-length)
20     "VM")
21     (in-package "LISP")
22     (import '(
23     dynamic-0-space-start dynamic-1-space-start read-only-space-start
24     static-space-start current-dynamic-space-start
25     *static-space-free-pointer* *read-only-space-free-pointer*)
26     "VM")
27     (in-package "VM")
28    
29    
30     ;;;; Type format database.
31    
32     (defstruct room-info
33     ;;
34     ;; The name of this type.
35     (name nil :type symbol)
36     ;;
37     ;; Kind of type (how we determine length).
38 wlott 1.2 (kind nil :type (member :lowtag :fixed :header :vector
39     :string :code :closure))
40 ram 1.1 ;;
41     ;; Length if fixed-length, shift amount for element size if :vector.
42     (length nil :type (or fixnum null)))
43    
44     (defvar *room-info* (make-array 256 :initial-element nil))
45    
46    
47     (dolist (obj *primitive-objects*)
48     (let ((header (primitive-object-header obj))
49     (lowtag (primitive-object-lowtag obj))
50     (name (primitive-object-name obj))
51     (variable (primitive-object-variable-length obj))
52     (size (primitive-object-size obj)))
53     (cond
54     ((not lowtag))
55     ((not header)
56     (let ((info (make-room-info :name name :kind :lowtag))
57     (lowtag (symbol-value lowtag)))
58     (declare (fixnum lowtag))
59     (dotimes (i 32)
60     (setf (svref *room-info* (logior lowtag (ash i 3))) info))))
61     (variable)
62     (t
63     (setf (svref *room-info* (symbol-value header))
64     (make-room-info :name name :kind :fixed :length size))))))
65    
66     (dolist (code (list complex-string-type simple-array-type
67     complex-bit-vector-type complex-vector-type
68     complex-array-type))
69     (setf (svref *room-info* code)
70     (make-room-info :name 'array-header :kind :header)))
71    
72     (setf (svref *room-info* bignum-type)
73     (make-room-info :name 'bignum :kind :header))
74    
75     (setf (svref *room-info* closure-header-type)
76     (make-room-info :name 'closure :kind :closure))
77    
78 wlott 1.2 (dolist (stuff '((simple-bit-vector-type . -3)
79 ram 1.1 (simple-vector-type . 2)
80     (simple-array-unsigned-byte-2-type . -2)
81     (simple-array-unsigned-byte-4-type . -1)
82     (simple-array-unsigned-byte-8-type . 0)
83     (simple-array-unsigned-byte-16-type . 1)
84     (simple-array-unsigned-byte-32-type . 2)
85     (simple-array-single-float-type . 2)
86     (simple-array-double-float-type . 3)))
87     (let ((name (car stuff))
88     (size (cdr stuff)))
89     (setf (svref *room-info* (symbol-value name))
90     (make-room-info :name name :kind :vector :length size))))
91    
92 wlott 1.2 (setf (svref *room-info* simple-string-type)
93     (make-room-info :name 'simple-string-type :kind :string :length 0))
94    
95 ram 1.1 (setf (svref *room-info* code-header-type)
96     (make-room-info :name 'code :kind :code))
97    
98     (deftype spaces () '(member :static :dynamic :read-only))
99    
100    
101     ;;;; MAP-ALLOCATED-OBJECTS:
102    
103     (proclaim '(type fixnum *static-space-free-pointer*
104     *read-only-space-free-pointer* ))
105    
106     (defun space-bounds (space)
107     (declare (type spaces space))
108     (ecase space
109     (:static
110     (values (int-sap (static-space-start))
111     (int-sap (* *static-space-free-pointer* word-bytes))))
112     (:read-only
113     (values (int-sap (read-only-space-start))
114     (int-sap (* *read-only-space-free-pointer* word-bytes))))
115     (:dynamic
116     (values (int-sap (current-dynamic-space-start))
117     (dynamic-space-free-pointer)))))
118    
119    
120     ;;; ROUND-TO-DUALWORD -- Internal
121     ;;;
122     ;;; Round Size (in bytes) up to the next dualword (eight byte) boundry.
123     ;;;
124     (proclaim '(inline round-to-dualword))
125     (defun round-to-dualword (size)
126     (declare (fixnum size))
127     (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
128    
129    
130     ;;; VECTOR-TOTAL-SIZE -- Internal
131     ;;;
132     ;;; Return the total size of a vector in bytes, including any pad.
133     ;;;
134     (proclaim '(inline vector-total-size))
135     (defun vector-total-size (obj info)
136     (let ((shift (room-info-length info))
137 wlott 1.2 (len (+ (vector-length obj)
138     (ecase (room-info-kind info)
139     (:vector 0)
140     (:string 1)))))
141 ram 1.1 (declare (type (integer -3 3) shift))
142     (round-to-dualword
143     (+ (* vector-data-offset word-bytes)
144     (the fixnum
145     (if (minusp shift)
146     (ash (the fixnum
147     (+ len (the fixnum
148     (1- (the fixnum (ash 1 (- shift)))))))
149     shift)
150     (ash len shift)))))))
151    
152    
153     ;;; MAP-ALLOCATED-OBJECTS -- Interface
154     ;;;
155     ;;; Iterate over all the objects allocated in Space, calling Fun with the
156     ;;; object, the object's type code, and the objects total size in bytes,
157     ;;; including any header and padding.
158     ;;;
159     (proclaim '(maybe-inline map-allocated-objects))
160     (defun map-allocated-objects (fun space)
161     (declare (type function fun) (type spaces space))
162     (multiple-value-bind (start end)
163     (space-bounds space)
164     (declare (optimize (speed 3) (safety 0)))
165     (let ((current start)
166     (prev nil))
167     (loop
168     (let* ((header (sap-ref-32 current 0))
169     (header-type (logand header #xFF))
170     (info (svref *room-info* header-type)))
171     (cond
172     ((or (not info)
173     (eq (room-info-kind info) :lowtag))
174     (let ((size (* cons-size word-bytes)))
175     (funcall fun
176     (make-lisp-obj (logior (sap-int current)
177     list-pointer-type))
178     list-pointer-type
179     size)
180     (setq current (sap+ current size))))
181     ((eql header-type closure-header-type)
182     (let* ((obj (make-lisp-obj (logior (sap-int current)
183     function-pointer-type)))
184     (size (round-to-dualword
185     (* (the fixnum (1+ (get-closure-length obj)))
186     word-bytes))))
187     (funcall fun obj header-type size)
188     (setq current (sap+ current size))))
189     (t
190     (let* ((obj (make-lisp-obj
191     (logior (sap-int current) other-pointer-type)))
192     (size (ecase (room-info-kind info)
193     (:fixed
194     (assert (or (eql (room-info-length info)
195     (1+ (get-header-data obj)))
196     (floatp obj)))
197     (round-to-dualword
198     (* (room-info-length info) word-bytes)))
199 wlott 1.2 ((:vector :string)
200 ram 1.1 (vector-total-size obj info))
201     (:header
202     (round-to-dualword
203     (* (1+ (get-header-data obj)) word-bytes)))
204     (:code
205     (+ (the fixnum
206     (* (get-header-data obj) word-bytes))
207     (round-to-dualword
208     (* (the fixnum
209     (%primitive code-code-size obj))
210     word-bytes)))))))
211     (declare (fixnum size))
212     (funcall fun obj header-type size)
213     (assert (zerop (logand size lowtag-mask)))
214     (when (> size 200000) (break "Implausible size, prev ~S" prev))
215     (setq prev current)
216     (setq current (sap+ current size))))))
217     (unless (pointer< current end)
218     (assert (not (pointer> current end)))
219     (return)))
220    
221     prev)))
222    
223    
224     ;;;; MEMORY-USAGE:
225    
226     ;;; TYPE-BREAKDOWN -- Interface
227     ;;;
228     ;;; Return a list of 3-lists (bytes object type-name) for the objects
229     ;;; allocated in Space.
230     ;;;
231     (defun type-breakdown (space)
232     (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
233     (counts (make-array 256 :initial-element 0 :element-type 'fixnum))
234     (structure-count 0)
235     (structure-size 0))
236     (declare (fixnum structure-size structure-count))
237     (map-allocated-objects
238     #'(lambda (obj type size)
239     (declare (fixnum size) (optimize (speed 3) (safety 0)))
240     (cond ((and (eql type simple-vector-type)
241     (eql (get-header-data obj) vector-structure-subtype))
242     (incf structure-count)
243     (incf structure-size size))
244     (t
245     (incf (aref sizes type) size)
246     (incf (aref counts type)))))
247     space)
248    
249     (let ((totals (make-hash-table :test #'eq)))
250     (dotimes (i 256)
251     (let ((total-count (aref counts i)))
252     (unless (zerop total-count)
253     (let* ((total-size (aref sizes i))
254     (name (room-info-name (aref *room-info* i)))
255     (found (gethash name totals)))
256     (cond (found
257     (incf (first found) total-size)
258     (incf (second found) total-count))
259     (t
260     (setf (gethash name totals)
261     (list total-size total-count name))))))))
262    
263     (collect ((totals-list))
264     (maphash #'(lambda (k v)
265     (declare (ignore k))
266     (totals-list v))
267     totals)
268     (totals-list (list structure-size structure-count 'structure))
269     (sort (totals-list) #'> :key #'first)))))
270    
271    
272     ;;; PRINT-SUMMARY -- Internal
273     ;;;
274     ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
275     ;;; (space-name . totals-for-space), where totals-for-space is the list
276     ;;; returned by TYPE-BREAKDOWN.
277     ;;;
278     (defun print-summary (spaces totals)
279     (let ((summary (make-hash-table :test #'eq)))
280     (dolist (space-total totals)
281     (dolist (total (cdr space-total))
282     (push (cons (car space-total) total)
283     (gethash (third total) summary))))
284    
285     (collect ((summary-totals))
286     (maphash #'(lambda (k v)
287     (declare (ignore k))
288     (let ((sum 0))
289     (declare (fixnum sum))
290     (dolist (space-total v)
291     (incf sum (first (cdr space-total))))
292     (summary-totals (cons sum v))))
293     summary)
294    
295     (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
296     (let ((summary-total-bytes 0)
297     (summary-total-objects 0))
298     (declare (fixnum summary-total-bytes summary-total-objects))
299     (dolist (space-totals
300     (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
301     (let ((total-objects 0)
302     (total-bytes 0)
303     name)
304     (declare (fixnum total-objects total-bytes))
305     (collect ((spaces))
306     (dolist (space-total space-totals)
307     (let ((total (cdr space-total)))
308     (setq name (third total))
309     (incf total-bytes (first total))
310     (incf total-objects (second total))
311     (spaces (cons (car space-total) (first total)))))
312     (format t "~%~A:~% ~:D bytes, ~:D object~:P"
313     name total-bytes total-objects)
314     (dolist (space (spaces))
315     (format t ", ~D% ~(~A~)"
316     (round (* (cdr space) 100) total-bytes)
317     (car space)))
318     (format t ".~%")
319     (incf summary-total-bytes total-bytes)
320     (incf summary-total-objects total-objects))))
321     (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
322     summary-total-bytes summary-total-objects)))))
323    
324    
325     ;;; MEMORY-USAGE -- Public
326     ;;;
327     (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
328     (print-summary t))
329     "Print out information about the heap memory in use. :Print-Spaces is a list
330     of the spaces to print detailed information for. :Count-Spaces is a list of
331     the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
332     and :Read-Only.) If :Print-Summary is true, then summary information will be
333     printed. The defaults print only summary information for dynamic space."
334     (let* ((spaces (if (eq count-spaces t)
335     '(:static :dynamic :read-only)
336     count-spaces))
337     (totals (mapcar #'(lambda (space)
338     (cons space (type-breakdown space)))
339     spaces)))
340    
341     (dolist (space-total totals)
342     (when (or (eq print-spaces t)
343     (member (car space-total) print-spaces))
344     (format t "~2&Breakdown for ~(~A~) space:~2%" (car space-total))
345     (let ((total-objects 0)
346     (total-bytes 0))
347     (declare (fixnum total-objects total-bytes))
348     (dolist (total (cdr space-total))
349     (incf total-bytes (first total))
350     (incf total-objects (second total))
351     (format t "~%~A:~% ~:D bytes, ~:D object~:P.~%"
352     (third total) (first total) (second total)))
353     (format t "~%Space total:~% ~:D bytes, ~:D object~:P.~%"
354     total-bytes total-objects))))
355    
356     (when print-summary (print-summary spaces totals)))
357    
358     (values))
359    
360    
361     ;;; COUNT-NO-OPS -- Public
362     ;;;
363     (defun count-no-ops (space)
364     "Print info about how much code and no-ops there are in Space."
365     (declare (type spaces space))
366     (let ((code-words 0)
367     (no-ops 0)
368     (total-bytes 0))
369     (declare (fixnum code-words no-ops))
370     (map-allocated-objects
371     #'(lambda (obj type size)
372     (declare (fixnum size) (optimize (speed 3) (safety 0)))
373     (when (eql type code-header-type)
374     (incf total-bytes size)
375     (let ((words (truly-the fixnum (%primitive code-code-size obj)))
376     (sap (truly-the system-area-pointer
377     (%primitive code-instructions obj))))
378     (incf code-words words)
379     (dotimes (i words)
380     (when (zerop (sap-ref-32 sap i)) (incf no-ops))))))
381     space)
382    
383     (format t
384     "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
385     total-bytes code-words no-ops
386     (round (* no-ops 100) code-words)))
387    
388     (values))
389    
390    
391     ;;; STRUCTURE-USAGE -- Public
392     ;;;
393     (defun structure-usage (space &key (top-n 15))
394     (declare (type spaces space) (type (or fixnum null) top-n))
395     "Print a breakdown by structure type of all the structures allocated in
396     Space. If TOP-N is true, print only information for the the TOP-N types with
397     largest usage."
398     (let ((totals (make-hash-table :test #'eq))
399     (total-objects 0)
400     (total-bytes 0))
401     (declare (fixnum total-objects total-bytes))
402     (map-allocated-objects
403     #'(lambda (obj type size)
404     (declare (fixnum size) (optimize (speed 3) (safety 0)))
405     (when (and (eql type simple-vector-type)
406     (eql (get-header-data obj) vector-structure-subtype))
407     (incf total-objects)
408     (incf total-bytes size)
409     (let* ((name (svref obj 0))
410     (found (gethash name totals)))
411     (cond (found
412     (incf (the fixnum (car found)))
413     (incf (the fixnum (cdr found)) size))
414     (t
415     (setf (gethash name totals) (cons 1 size)))))))
416     space)
417    
418     (collect ((totals-list))
419     (maphash #'(lambda (name what)
420     (totals-list (cons name what)))
421     totals)
422     (let ((sorted (sort (totals-list) #'> :key #'cddr))
423     (printed-bytes 0)
424     (printed-objects 0))
425     (declare (fixnum printed-bytes printed-objects))
426     (dolist (what (if top-n
427     (subseq sorted 0 (min (length sorted) top-n))
428     sorted))
429     (let ((bytes (cddr what))
430     (objects (cadr what)))
431     (incf printed-bytes bytes)
432     (incf printed-objects objects)
433     (format t "~S: ~:D bytes, ~D object~:P.~%" (car what)
434     bytes objects)))
435    
436     (let ((residual-objects (- total-objects printed-objects))
437     (residual-bytes (- total-bytes printed-bytes)))
438     (unless (zerop residual-objects)
439     (format t "Other types: ~:D bytes, ~D: object~:P.~%"
440     residual-bytes residual-objects))))
441    
442     (format t "Structure total: ~:D bytes, ~:D object~:P.~%"
443     total-bytes total-objects)))
444    
445 wlott 1.2 (values))
446    
447    
448     ;;; FIND-HOLES -- Public
449     ;;;
450     (defun find-holes (&rest spaces)
451     (dolist (space (or spaces '(:read-only :static :dynamic)))
452     (format t "In ~A space:~%" space)
453     (let ((start-addr nil)
454     (total-bytes 0))
455     (declare (type (or null (unsigned-byte 32)) start-addr)
456     (type (unsigned-byte 32) total-bytes))
457     (map-allocated-objects
458     #'(lambda (object typecode bytes)
459     (declare (ignore typecode)
460     (type (unsigned-byte 32) bytes))
461     (if (and (consp object)
462     (eql (car object) 0)
463     (eql (cdr object) 0))
464     (if start-addr
465     (incf total-bytes bytes)
466     (setf start-addr (di::get-lisp-obj-address object)
467     total-bytes bytes))
468     (when start-addr
469     (format t "~D bytes at #x~X~%" total-bytes start-addr)
470     (setf start-addr nil))))
471     space)
472     (when start-addr
473     (format t "~D bytes at #x~X~%" total-bytes start-addr))))
474 ram 1.1 (values))

  ViewVC Help
Powered by ViewVC 1.1.5