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

Contents of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5