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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5