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

Diff of /src/code/room.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by ram, Tue Apr 23 17:01:34 1991 UTC revision 1.10 by ram, Sat May 4 16:58:11 1991 UTC
# Line 11  Line 11 
11  ;;;  ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
 ;;; $Header$  
 ;;;  
14  ;;; Heap grovelling memory usage stuff.  ;;; Heap grovelling memory usage stuff.
15  ;;;  ;;;
16  (in-package "VM")  (in-package "VM")
# Line 122  Line 120 
120       (values (int-sap (current-dynamic-space-start))       (values (int-sap (current-dynamic-space-start))
121               (dynamic-space-free-pointer)))))               (dynamic-space-free-pointer)))))
122    
123    ;;; SPACE-BYTES  --  Internal
124    ;;;
125    ;;;    Return the total number of bytes used in Space.
126    ;;;
127    (defun space-bytes (space)
128      (multiple-value-bind (start end)
129                           (space-bounds space)
130        (- (sap-int end) (sap-int start))))
131    
132  ;;; ROUND-TO-DUALWORD  --  Internal  ;;; ROUND-TO-DUALWORD  --  Internal
133  ;;;  ;;;
# Line 165  Line 171 
171  (proclaim '(maybe-inline map-allocated-objects))  (proclaim '(maybe-inline map-allocated-objects))
172  (defun map-allocated-objects (fun space)  (defun map-allocated-objects (fun space)
173    (declare (type function fun) (type spaces space))    (declare (type function fun) (type spaces space))
174    (multiple-value-bind (start end)    (without-gcing
175                         (space-bounds space)      (multiple-value-bind (start end)
176      (declare (optimize (speed 3) (safety 0)))                           (space-bounds space)
177      (let ((current start)        (declare (optimize (speed 3) (safety 0)))
178            (prev nil))        (let ((current start)
179        (loop              (prev nil))
180          (let* ((header (sap-ref-32 current 0))          (loop
181                 (header-type (logand header #xFF))            (let* ((header (sap-ref-32 current 0))
182                 (info (svref *room-info* header-type)))                   (header-type (logand header #xFF))
183            (cond                   (info (svref *room-info* header-type)))
184             ((or (not info)              (cond
185                  (eq (room-info-kind info) :lowtag))               ((or (not info)
186              (let ((size (* cons-size word-bytes)))                    (eq (room-info-kind info) :lowtag))
187                (funcall fun                (let ((size (* cons-size word-bytes)))
188                         (make-lisp-obj (logior (sap-int current)                  (funcall fun
189                                                list-pointer-type))                           (make-lisp-obj (logior (sap-int current)
190                         list-pointer-type                                                  list-pointer-type))
191                         size)                           list-pointer-type
192                (setq current (sap+ current size))))                           size)
193             ((eql header-type closure-header-type)                  (setq current (sap+ current size))))
194              (let* ((obj (make-lisp-obj (logior (sap-int current)               ((eql header-type closure-header-type)
195                                                 function-pointer-type)))                (let* ((obj (make-lisp-obj (logior (sap-int current)
196                     (size (round-to-dualword                                                   function-pointer-type)))
197                            (* (the fixnum (1+ (get-closure-length obj)))                       (size (round-to-dualword
198                               word-bytes))))                              (* (the fixnum (1+ (get-closure-length obj)))
199                (funcall fun obj header-type size)                                 word-bytes))))
200                (setq current (sap+ current size))))                  (funcall fun obj header-type size)
201             ((eq (room-info-kind info) :structure)                  (setq current (sap+ current size))))
202              (let* ((obj (make-lisp-obj               ((eq (room-info-kind info) :structure)
203                           (logior (sap-int current) structure-pointer-type)))                (let* ((obj (make-lisp-obj
204                     (size (round-to-dualword                             (logior (sap-int current) structure-pointer-type)))
205                            (* (+ (c::structure-length obj) 1) word-bytes))))                       (size (round-to-dualword
206                (declare (fixnum size))                              (* (+ (c::structure-length obj) 1) word-bytes))))
207                (funcall fun obj header-type size)                  (declare (fixnum size))
208                (assert (zerop (logand size lowtag-mask)))                  (funcall fun obj header-type size)
209                (when (> size 200000) (break "Implausible size, prev ~S" prev))                  (assert (zerop (logand size lowtag-mask)))
210                (setq prev current)                  #+nil
211                (setq current (sap+ current size))))                  (when (> size 200000) (break "Implausible size, prev ~S" prev))
212             (t                  (setq prev current)
213              (let* ((obj (make-lisp-obj                  (setq current (sap+ current size))))
214                           (logior (sap-int current) other-pointer-type)))               (t
215                     (size (ecase (room-info-kind info)                (let* ((obj (make-lisp-obj
216                             (:fixed                             (logior (sap-int current) other-pointer-type)))
217                              (assert (or (eql (room-info-length info)                       (size (ecase (room-info-kind info)
218                                               (1+ (get-header-data obj)))                               (:fixed
219                                          (floatp obj)))                                (assert (or (eql (room-info-length info)
220                              (round-to-dualword                                                 (1+ (get-header-data obj)))
221                               (* (room-info-length info) word-bytes)))                                            (floatp obj)))
222                             ((:vector :string)                                (round-to-dualword
223                              (vector-total-size obj info))                                 (* (room-info-length info) word-bytes)))
224                             (:header                               ((:vector :string)
225                              (round-to-dualword                                (vector-total-size obj info))
226                               (* (1+ (get-header-data obj)) word-bytes)))                               (:header
227                             (:code                                (round-to-dualword
228                              (+ (the fixnum                                 (* (1+ (get-header-data obj)) word-bytes)))
229                                      (* (get-header-data obj) word-bytes))                               (:code
230                                 (round-to-dualword                                (+ (the fixnum
231                                  (* (the fixnum                                        (* (get-header-data obj) word-bytes))
232                                          (%primitive code-code-size obj))                                   (round-to-dualword
233                                     word-bytes)))))))                                    (* (the fixnum
234                (declare (fixnum size))                                            (%primitive code-code-size obj))
235                (funcall fun obj header-type size)                                       word-bytes)))))))
236                (assert (zerop (logand size lowtag-mask)))                  (declare (fixnum size))
237                (when (> size 200000) (break "Implausible size, prev ~S" prev))                  (funcall fun obj header-type size)
238                (setq prev current)                  (assert (zerop (logand size lowtag-mask)))
239                (setq current (sap+ current size))))))                  #+nil
240          (unless (pointer< current end)                  (when (> size 200000)
241            (assert (not (pointer> current end)))                    (break "Implausible size, prev ~S" prev))
242            (return)))                  (setq prev current)
243                    (setq current (sap+ current size))))))
244        prev)))            (unless (pointer< current end)
245                (assert (not (pointer> current end)))
246                (return)))
247    
248            prev))))
249    
250    
251  ;;;; MEMORY-USAGE:  ;;;; MEMORY-USAGE:
# Line 330  Line 340 
340                  summary-total-bytes summary-total-objects)))))                  summary-total-bytes summary-total-objects)))))
341    
342    
343    ;;; REPORT-SPACE-TOTAL  --  Internal
344    ;;;
345    ;;;    Report object usage for a single space.
346    ;;;
347    (defun report-space-total (space-total cutoff)
348      (declare (list space-total) (type (or single-float null) cutoff))
349      (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
350      (let* ((types (cdr space-total))
351             (total-bytes (reduce #'+ (mapcar #'first types)))
352             (total-objects (reduce #'+ (mapcar #'second types)))
353             (cutoff-point (if cutoff
354                               (truncate (* (float total-bytes) cutoff))
355                               0))
356             (reported-bytes 0)
357             (reported-objects 0))
358        (declare (fixnum total-objects total-bytes cutoff-point reported-objects
359                         reported-bytes))
360        (loop for (bytes objects name) in types do
361          (when (<= bytes cutoff-point)
362            (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
363                    (- total-bytes reported-bytes)
364                    (- total-objects reported-objects))
365            (return))
366          (incf reported-bytes bytes)
367          (incf reported-objects objects)
368          (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
369                  bytes objects name))
370        (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
371                total-bytes total-objects (car space-total))))
372    
373    
374  ;;; MEMORY-USAGE  --  Public  ;;; MEMORY-USAGE  --  Public
375  ;;;  ;;;
376  (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))  (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
377                            (print-summary t))                            (print-summary t) cutoff)
378    "Print out information about the heap memory in use.  :Print-Spaces is a list    "Print out information about the heap memory in use.  :Print-Spaces is a list
379    of the spaces to print detailed information for.  :Count-Spaces is a list of    of the spaces to print detailed information for.  :Count-Spaces is a list of
380    the spaces to scan.  For either one, T means all spaces (:Static, :Dyanmic    the spaces to scan.  For either one, T means all spaces (:Static, :Dyanmic
381    and :Read-Only.)  If :Print-Summary is true, then summary information will be    and :Read-Only.)  If :Print-Summary is true, then summary information will be
382    printed.  The defaults print only summary information for dynamic space."    printed.  The defaults print only summary information for dynamic space.
383      If true, Cutoff is a fraction of the usage in a report below which types will
384      be combined as OTHER."
385      (declare (type (or single-float null) cutoff))
386    (let* ((spaces (if (eq count-spaces t)    (let* ((spaces (if (eq count-spaces t)
387                       '(:static :dynamic :read-only)                       '(:static :dynamic :read-only)
388                       count-spaces))                       count-spaces))
# Line 349  Line 393 
393      (dolist (space-total totals)      (dolist (space-total totals)
394        (when (or (eq print-spaces t)        (when (or (eq print-spaces t)
395                  (member (car space-total) print-spaces))                  (member (car space-total) print-spaces))
396          (format t "~2&Breakdown for ~(~A~) space:~2%" (car space-total))          (report-space-total space-total cutoff)))
         (let ((total-objects 0)  
               (total-bytes 0))  
           (declare (fixnum total-objects total-bytes))  
           (dolist (total (cdr space-total))  
             (incf total-bytes (first total))  
             (incf total-objects (second total))  
             (format t "~%~A:~%    ~:D bytes, ~:D object~:P.~%"  
                     (third total) (first total) (second total)))  
           (format t "~%Space total:~%    ~:D bytes, ~:D object~:P.~%"  
                   total-bytes total-objects))))  
397    
398      (when print-summary (print-summary spaces totals)))      (when print-summary (print-summary spaces totals)))
399    
# Line 467  Line 501 
501    "Print a breakdown by structure type of all the structures allocated in    "Print a breakdown by structure type of all the structures allocated in
502    Space.  If TOP-N is true, print only information for the the TOP-N types with    Space.  If TOP-N is true, print only information for the the TOP-N types with
503    largest usage."    largest usage."
504      (format t "~2&~@[Top ~D ~]~(~A~) structure types:~%" top-n space)
505    (let ((totals (make-hash-table :test #'eq))    (let ((totals (make-hash-table :test #'eq))
506          (total-objects 0)          (total-objects 0)
507          (total-bytes 0))          (total-bytes 0))
# Line 501  Line 536 
536                  (objects (cadr what)))                  (objects (cadr what)))
537              (incf printed-bytes bytes)              (incf printed-bytes bytes)
538              (incf printed-objects objects)              (incf printed-objects objects)
539              (format t "~S: ~:D bytes, ~D object~:P.~%" (car what)              (format t "  ~S: ~:D bytes, ~D object~:P.~%" (car what)
540                      bytes objects)))                      bytes objects)))
541    
542          (let ((residual-objects (- total-objects printed-objects))          (let ((residual-objects (- total-objects printed-objects))
543                (residual-bytes (- total-bytes printed-bytes)))                (residual-bytes (- total-bytes printed-bytes)))
544            (unless (zerop residual-objects)            (unless (zerop residual-objects)
545              (format t "Other types: ~:D bytes, ~D: object~:P.~%"              (format t "  Other types: ~:D bytes, ~D: object~:P.~%"
546                      residual-bytes residual-objects))))                      residual-bytes residual-objects))))
547    
548        (format t "Structure total: ~:D bytes, ~:D object~:P.~%"        (format t "  ~:(~A~) structure total: ~:D bytes, ~:D object~:P.~%"
549                total-bytes total-objects)))                space total-bytes total-objects)))
550    
551    (values))    (values))
552    

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

  ViewVC Help
Powered by ViewVC 1.1.5