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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5