/[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.25.2.4 by pw, Sat Mar 23 18:50:10 2002 UTC revision 1.41 by rtoy, Sun Aug 21 07:43:38 2011 UTC
# Line 13  Line 13 
13  ;;;  ;;;
14  (in-package "VM")  (in-package "VM")
15  (use-package "SYSTEM")  (use-package "SYSTEM")
16    (intl:textdomain "cmucl")
17    
18  (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage  (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
19                         instance-usage find-holes print-allocated-objects                         instance-usage find-holes print-allocated-objects
20                         code-breakdown uninterned-symbol-count                         code-breakdown uninterned-symbol-count
# Line 91  Line 93 
93                   (simple-array-single-float-type . 2)                   (simple-array-single-float-type . 2)
94                   (simple-array-double-float-type . 3)                   (simple-array-double-float-type . 3)
95                   (simple-array-complex-single-float-type . 3)                   (simple-array-complex-single-float-type . 3)
96                   (simple-array-complex-double-float-type . 4)))                   (simple-array-complex-double-float-type . 4)
97                     #+double-double
98                     (simple-array-double-double-float-type . 4)
99                     #+double-double
100                     (simple-array-complex-double-double-float-type . 5)
101                     ))
102    (let ((name (car stuff))    (let ((name (car stuff))
103          (size (cdr stuff)))          (size (cdr stuff)))
104      (setf (svref *meta-room-info* (symbol-value name))      (setf (svref *meta-room-info* (symbol-value name))
105            (make-room-info :name name  :kind :vector  :length size))))            (make-room-info :name name  :kind :vector  :length size))))
106    
107    ;; For unicode, there are 2 bytes per character, not 1.
108  (setf (svref *meta-room-info* simple-string-type)  (setf (svref *meta-room-info* simple-string-type)
109        (make-room-info :name 'simple-string-type :kind :string :length 0))        (make-room-info :name 'simple-string-type :kind :string
110                          ;; Assumes char-bytes is a power of two!
111                          :length (1- (integer-length vm:char-bytes))))
112    
113  (setf (svref *meta-room-info* code-header-type)  (setf (svref *meta-room-info* code-header-type)
114        (make-room-info :name 'code  :kind :code))        (make-room-info :name 'code  :kind :code))
# Line 110  Line 120 
120    
121  (defparameter *room-info* '#.*meta-room-info*)  (defparameter *room-info* '#.*meta-room-info*)
122  (deftype spaces () '(member :static :dynamic :read-only))  (deftype spaces () '(member :static :dynamic :read-only))
123    ;; A type denoting the virtual address available to us.
124    (deftype memory-size () `(unsigned-byte #.vm:word-bits))
125    
126  ;;;; MAP-ALLOCATED-OBJECTS:  ;;;; MAP-ALLOCATED-OBJECTS:
127    
128  (declaim (type fixnum *static-space-free-pointer*  (declaim (type fixnum *static-space-free-pointer*
129                 *read-only-space-free-pointer* ))                 *read-only-space-free-pointer* ))
130    
131    #+gencgc
132    (eval-when (compile load eval)
133      ;; This had better match the value in gencgc.h!!!!
134      (defconstant gencgc-page-size
135        #+sparc (* 4 8192)
136        #+ppc (* 4 4096)
137        #-(or sparc ppc) 4096))
138    
139    #+gencgc
140    (def-alien-variable last-free-page c-call:unsigned-int)
141    
142  (defun space-bounds (space)  (defun space-bounds (space)
143    (declare (type spaces space))    (declare (type spaces space))
144    (ecase space    (ecase space
# Line 127  Line 149 
149       (values (int-sap (read-only-space-start))       (values (int-sap (read-only-space-start))
150               (int-sap (* *read-only-space-free-pointer* word-bytes))))               (int-sap (* *read-only-space-free-pointer* word-bytes))))
151      (:dynamic      (:dynamic
152         ;; DYNAMIC-SPACE-FREE-POINTER isn't quite right here for sparc
153         ;; and ppc with gencgc.  We really want the last free page, which
154         ;; is stored in *allocation-pointer* on x86, but sparc and ppc
155         ;; don't have *allocation-pointer*, so grab the value directly
156         ;; from last-free-page.
157       (values (int-sap (current-dynamic-space-start))       (values (int-sap (current-dynamic-space-start))
158                 #+(and gencgc (or sparc ppc))
159                 (int-sap (truly-the (unsigned-byte 32)
160                                     (+ (current-dynamic-space-start)
161                                        (the (unsigned-byte 32) (* gencgc-page-size last-free-page)))))
162                 #-(and gencgc (or sparc ppc))
163               (dynamic-space-free-pointer)))))               (dynamic-space-free-pointer)))))
164    
165  ;;; SPACE-BYTES  --  Internal  ;;; SPACE-BYTES  --  Internal
# Line 141  Line 173 
173    
174  ;;; ROUND-TO-DUALWORD  --  Internal  ;;; ROUND-TO-DUALWORD  --  Internal
175  ;;;  ;;;
176  ;;;    Round Size (in bytes) up to the next dualword (eight byte) boundry.  ;;;    Round Size (in bytes) up to the next dualword (eight/16 byte) boundry.
177  ;;;  ;;;
178  (declaim (inline round-to-dualword))  (declaim (inline round-to-dualword))
179  (defun round-to-dualword (size)  (defun round-to-dualword (size)
180    (declare (fixnum size))    (declare (type memory-size size))
181    (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))    #-amd64
182      (logandc2 (the memory-size (+ size lowtag-mask)) lowtag-mask)
183      ;; when we use 4-bit lowtag for amd64 we can get rid of this
184      #+amd64
185      (logandc2 (the memory-size (+ size 15)) 15))
186    
187    
188  ;;; VECTOR-TOTAL-SIZE  --  Internal  ;;; VECTOR-TOTAL-SIZE  --  Internal
# Line 163  Line 199 
199      (declare (type (integer -3 3) shift))      (declare (type (integer -3 3) shift))
200      (round-to-dualword      (round-to-dualword
201       (+ (* vector-data-offset word-bytes)       (+ (* vector-data-offset word-bytes)
202          (the fixnum          (the memory-size
203               (if (minusp shift)               (if (minusp shift)
204                   (ash (the fixnum                   (ash (the memory-size
205                             (+ len (the fixnum                             (+ len (the memory-size
206                                         (1- (the fixnum (ash 1 (- shift)))))))                                         (1- (the memory-size (ash 1 (- shift)))))))
207                        shift)                        shift)
208                   (ash len shift)))))))                   (ash len shift)))))))
209    
210    ;;; Access to the GENCGC page table for better precision in
211    ;;; MAP-ALLOCATED-OBJECTS.
212    #+gencgc
213    (progn
214      (declaim (inline find-page-index get-page-table-info))
215      (def-alien-routine "find_page_index" c-call:int
216        (addr c-call:long))
217      (def-alien-routine get-page-table-info c-call:void
218        (page c-call:int)
219        (flags c-call:int :out)
220        (bytes c-call:int :out))
221      )
222    
223  ;;; MAP-ALLOCATED-OBJECTS  --  Interface  ;;; MAP-ALLOCATED-OBJECTS  --  Interface
224  ;;;  ;;;
# Line 179  Line 227 
227  ;;; including any header and padding.  ;;; including any header and padding.
228  ;;;  ;;;
229  (declaim (maybe-inline map-allocated-objects))  (declaim (maybe-inline map-allocated-objects))
230    #+nil
231  (defun map-allocated-objects (fun space)  (defun map-allocated-objects (fun space)
232    (declare (type function fun) (type spaces space))    (declare (type function fun) (type spaces space))
233    (without-gcing    (without-gcing
# Line 186  Line 235 
235                           (space-bounds space)                           (space-bounds space)
236        (declare (type system-area-pointer start end))        (declare (type system-area-pointer start end))
237        (declare (optimize (speed 3) (safety 0)))        (declare (optimize (speed 3) (safety 0)))
238        (let ((current start)        (iterate step ((current start))
239              #+nil          (flet ((next (size)
240              (prev nil))                   (let ((c (etypecase size
241          (loop                              (fixnum (sap+ current size))
242                                (memory-size (sap+ current size)))))
243                       (cond ((sap< c end)
244                              (step c))
245                             (t
246                              (assert (sap= c end)))))))
247            (let* ((header (sap-ref-32 current 0))            (let* ((header (sap-ref-32 current 0))
248                   (header-type (logand header #xFF))                   (header-type (logand header #xFF))
249                   (info (svref *room-info* header-type)))                   (info (svref *room-info* header-type)))
# Line 202  Line 256 
256                                                  list-pointer-type))                                                  list-pointer-type))
257                           list-pointer-type                           list-pointer-type
258                           size)                           size)
259                  (setq current (sap+ current size))))                  (next size)))
260               ((eql header-type closure-header-type)               ((eql header-type closure-header-type)
261                (let* ((obj (make-lisp-obj (logior (sap-int current)                (let* ((obj (make-lisp-obj (logior (sap-int current)
262                                                   function-pointer-type)))                                                   function-pointer-type)))
# Line 210  Line 264 
264                              (* (the fixnum (1+ (get-closure-length obj)))                              (* (the fixnum (1+ (get-closure-length obj)))
265                                 word-bytes))))                                 word-bytes))))
266                  (funcall fun obj header-type size)                  (funcall fun obj header-type size)
267                  (setq current (sap+ current size))))                  (next size)))
268               ((eq (room-info-kind info) :instance)               ((eq (room-info-kind info) :instance)
269                (let* ((obj (make-lisp-obj                (let* ((obj (make-lisp-obj
270                             (logior (sap-int current) instance-pointer-type)))                             (logior (sap-int current) instance-pointer-type)))
271                       (size (round-to-dualword                       (size (round-to-dualword
272                              (* (+ (%instance-length obj) 1) word-bytes))))                              (* (+ (%instance-length obj) 1) word-bytes))))
273                  (declare (fixnum size))                  (declare (type memory-size size))
274                  (funcall fun obj header-type size)                  (funcall fun obj header-type size)
275                  (assert (zerop (logand size lowtag-mask)))                  (assert (zerop (logand size lowtag-mask)))
276                  #+nil                  #+nil
277                  (when (> size 200000) (break "Implausible size, prev ~S" prev))                  (when (> size 200000) (break "Implausible size, prev ~S" prev))
278                  #+nil                  #+nil
279                  (setq prev current)                  (setq prev current)
280                  (setq current (sap+ current size))))                  (next size)))
281               (t               (t
282                (let* ((obj (make-lisp-obj                (let* ((obj (make-lisp-obj
283                             (logior (sap-int current) other-pointer-type)))                             (logior (sap-int current) other-pointer-type)))
# Line 245  Line 299 
299                                   (round-to-dualword                                   (round-to-dualword
300                                    (* (the fixnum (%code-code-size obj))                                    (* (the fixnum (%code-code-size obj))
301                                       word-bytes)))))))                                       word-bytes)))))))
302                  (declare (fixnum size))                  (declare (type memory-size size))
303                  (funcall fun obj header-type size)                  (funcall fun obj header-type size)
304                  (assert (zerop (logand size lowtag-mask)))                  (assert (zerop (logand size lowtag-mask)))
305                  #+nil                  #+nil
# Line 253  Line 307 
307                    (break "Implausible size, prev ~S" prev))                    (break "Implausible size, prev ~S" prev))
308                  #+nil                  #+nil
309                  (setq prev current)                  (setq prev current)
310                  (setq current (sap+ current size))))))                  (next size))))))
           (unless (sap< current end)  
             (assert (sap= current end))  
             (return)))  
311    
312          #+nil          #+nil
313          prev))))          prev))))
314    
315    (defun map-allocated-objects (fun space)
316      (declare (type function fun) (type spaces space))
317      (without-gcing
318       (multiple-value-bind (start end)
319           (space-bounds space)
320         (declare (type system-area-pointer start end))
321         (declare (optimize (speed 3) (safety 0)))
322         (let ((skip-tests-until-addr 0)
323               (current start))
324           (declare (type (unsigned-byte 31) skip-tests-until-addr))
325           (labels
326               ((maybe-finish-mapping ()
327                  (unless (sap< current end)
328                    (return-from map-allocated-objects)))
329                ;; GENCGC doesn't allocate linearly, which means that the
330                ;; dynamic space can contain large blocks of zeros that
331                ;; get accounted as conses in ROOM (and slow down other
332                ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
333                ;; check the GC page structure for the current address.
334                ;; If the page is free or the address is beyond the page-
335                ;; internal allocation offset (bytes-used) skip to the
336                ;; next page immediately.
337                (maybe-skip-page ()
338                  #+gencgc
339                  (when (eq space :dynamic)
340                    (let ((tested (>= (sap-int current) skip-tests-until-addr)))
341                      (loop with page-mask = (1- gencgc-page-size)
342                         for addr of-type (unsigned-byte 32) = (sap-int current)
343                         while (>= addr skip-tests-until-addr)
344                         do
345                         (multiple-value-bind (ret flags bytes-used)
346                             (get-page-table-info (find-page-index addr))
347                           (declare (ignore ret))
348                           (let ((alloc-flag (logand flags #x40)))
349                             ;; If the page is not free and the current
350                             ;; pointer is still below the allocation
351                             ;; offset of the page
352                             (when (and (not (zerop alloc-flag))
353                                        (<= (logand page-mask addr)
354                                            bytes-used))
355                               ;; Don't bother testing again until we get
356                               ;; past that allocation offset
357                               (setf skip-tests-until-addr
358                                     (+ (logandc2 addr page-mask)
359                                        (the fixnum bytes-used)))
360                               ;; And then continue with the scheduled mapping
361                               (return-from maybe-skip-page))
362                             ;; Move CURRENT to start of next page
363                             (setf current (int-sap (+ (logandc2 addr page-mask)
364                                                       gencgc-page-size)))
365                             (maybe-finish-mapping)))))))
366                (next (size)
367                  (let ((c (etypecase size
368                             (fixnum (sap+ current size))
369                             (memory-size (sap+ current size)))))
370                    (setf current c))))
371             (declare (inline next maybe-finish-mapping))
372             (loop
373                (maybe-finish-mapping)
374                (maybe-skip-page)
375                (let* ((header (sap-ref-32 current 0))
376                       (header-type (logand header #xFF))
377                       (info (svref *room-info* header-type)))
378                  (cond
379                    ((or (not info)
380                         (eq (room-info-kind info) :lowtag))
381                     (let ((size (* cons-size word-bytes)))
382                       (funcall fun
383                                (make-lisp-obj (logior (sap-int current)
384                                                       list-pointer-type))
385                                list-pointer-type
386                                size)
387                       (next size)))
388                    ((eql header-type closure-header-type)
389                     (let* ((obj (make-lisp-obj (logior (sap-int current)
390                                                        function-pointer-type)))
391                            (size (round-to-dualword
392                                   (* (the fixnum (1+ (get-closure-length obj)))
393                                      word-bytes))))
394                       (funcall fun obj header-type size)
395                       (next size)))
396                    ((eq (room-info-kind info) :instance)
397                     (let* ((obj (make-lisp-obj
398                                  (logior (sap-int current) instance-pointer-type)))
399                            (size (round-to-dualword
400                                   (* (+ (%instance-length obj) 1) word-bytes))))
401                       (declare (type memory-size size))
402                       (funcall fun obj header-type size)
403                       (assert (zerop (logand size lowtag-mask)))
404                       (next size)))
405                    (t
406                     (let* ((obj (make-lisp-obj
407                                  (logior (sap-int current) other-pointer-type)))
408                            (size (ecase (room-info-kind info)
409                                    (:fixed
410                                     (assert (or (eql (room-info-length info)
411                                                      (1+ (get-header-data obj)))
412                                                 (floatp obj)))
413                                     (round-to-dualword
414                                      (* (room-info-length info) word-bytes)))
415                                    ((:vector :string)
416                                     (vector-total-size obj info))
417                                    (:header
418                                     (round-to-dualword
419                                      (* (1+ (get-header-data obj)) word-bytes)))
420                                    (:code
421                                     (+ (the fixnum
422                                          (* (get-header-data obj) word-bytes))
423                                        (round-to-dualword
424                                         (* (the fixnum (%code-code-size obj))
425                                            word-bytes)))))))
426                       (declare (type memory-size size))
427                       (funcall fun obj header-type size)
428                       (assert (zerop (logand size lowtag-mask)))
429                       (next size)))))))))))
430    
431    
432  ;;;; MEMORY-USAGE:  ;;;; MEMORY-USAGE:
433    
# Line 270  Line 437 
437  ;;; allocated in Space.  ;;; allocated in Space.
438  ;;;  ;;;
439  (defun type-breakdown (space)  (defun type-breakdown (space)
440    (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))    (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte 32)))
441          (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))          (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte 32))))
442      (map-allocated-objects      (map-allocated-objects
443       #'(lambda (obj type size)       #'(lambda (obj type size)
444           (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))           (declare (type memory-size size) (optimize (speed 3) (safety 0)) (ignore obj))
445           (incf (aref sizes type) size)           (incf (aref sizes type) size)
446           (incf (aref counts type)))           (incf (aref counts type)))
447       space)       space)
# Line 318  Line 485 
485        (maphash #'(lambda (k v)        (maphash #'(lambda (k v)
486                     (declare (ignore k))                     (declare (ignore k))
487                     (let ((sum 0))                     (let ((sum 0))
488                       (declare (fixnum sum))                       (declare (type memory-size sum))
489                       (dolist (space-total v)                       (dolist (space-total v)
490                         (incf sum (first (cdr space-total))))                         (incf sum (first (cdr space-total))))
491                       (summary-totals (cons sum v))))                       (summary-totals (cons sum v))))
492                 summary)                 summary)
493    
494        (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)        (format t (intl:gettext "~2&Summary of spaces: ~(~{~A ~}~)~%") spaces)
495        (let ((summary-total-bytes 0)        (let ((summary-total-bytes 0)
496              (summary-total-objects 0))              (summary-total-objects 0))
497          (declare (fixnum summary-total-bytes summary-total-objects))          (declare (type memory-size summary-total-bytes summary-total-objects))
498          (dolist (space-totals          (dolist (space-totals
499                   (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))                   (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
500            (let ((total-objects 0)            (let ((total-objects 0)
501                  (total-bytes 0)                  (total-bytes 0)
502                  name)                  name)
503              (declare (fixnum total-objects total-bytes))              (declare (fixnum total-objects)
504                         (type memory-size total-bytes))
505              (collect ((spaces))              (collect ((spaces))
506                (dolist (space-total space-totals)                (dolist (space-total space-totals)
507                  (let ((total (cdr space-total)))                  (let ((total (cdr space-total)))
# Line 341  Line 509 
509                    (incf total-bytes (first total))                    (incf total-bytes (first total))
510                    (incf total-objects (second total))                    (incf total-objects (second total))
511                    (spaces (cons (car space-total) (first total)))))                    (spaces (cons (car space-total) (first total)))))
512                (format t "~%~A:~%    ~:D bytes, ~:D object~:P"                (format t (intl:ngettext "~%~A:~%    ~:D bytes, ~:D object"
513                                           "~%~A:~%    ~:D bytes, ~:D objects"
514                                           total-objects)
515                        name total-bytes total-objects)                        name total-bytes total-objects)
516                (dolist (space (spaces))                (dolist (space (spaces))
517                  (format t ", ~D% ~(~A~)"                  (format t ", ~D% ~(~A~)"
# Line 350  Line 520 
520                (format t ".~%")                (format t ".~%")
521                (incf summary-total-bytes total-bytes)                (incf summary-total-bytes total-bytes)
522                (incf summary-total-objects total-objects))))                (incf summary-total-objects total-objects))))
523          (format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"          (format t (intl:gettext "~%Summary total:~%    ~:D bytes, ~:D objects.~%")
524                  summary-total-bytes summary-total-objects)))))                  summary-total-bytes summary-total-objects)))))
525    
526    
# Line 360  Line 530 
530  ;;;  ;;;
531  (defun report-space-total (space-total cutoff)  (defun report-space-total (space-total cutoff)
532    (declare (list space-total) (type (or single-float null) cutoff))    (declare (list space-total) (type (or single-float null) cutoff))
533    (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))    (format t (intl:gettext "~2&Breakdown for ~(~A~) space:~%") (car space-total))
534    (let* ((types (cdr space-total))    (let* ((types (cdr space-total))
535           (total-bytes (reduce #'+ (mapcar #'first types)))           (total-bytes (reduce #'+ (mapcar #'first types)))
536           (total-objects (reduce #'+ (mapcar #'second types)))           (total-objects (reduce #'+ (mapcar #'second types)))
# Line 369  Line 539 
539                             0))                             0))
540           (reported-bytes 0)           (reported-bytes 0)
541           (reported-objects 0))           (reported-objects 0))
542      (declare (fixnum total-objects total-bytes cutoff-point reported-objects      (declare (fixnum total-objects cutoff-point reported-objects)
543                       reported-bytes))               (type memory-size total-bytes reported-bytes))
544      (loop for (bytes objects name) in types do      (loop for (bytes objects name) in types do
545        (when (<= bytes cutoff-point)        (when (<= bytes cutoff-point)
546          (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"          (format t (intl:ngettext "  ~13:D bytes for ~9:D other object.~%"
547                                     "  ~13:D bytes for ~9:D other objects.~%"
548                                     (- total-objects reported-objects))
549                  (- total-bytes reported-bytes)                  (- total-bytes reported-bytes)
550                  (- total-objects reported-objects))                  (- total-objects reported-objects))
551          (return))          (return))
552        (incf reported-bytes bytes)        (incf reported-bytes bytes)
553        (incf reported-objects objects)        (incf reported-objects objects)
554        (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"        (format t (intl:ngettext "  ~13:D bytes for ~9:D ~(~A~) object.~%"
555                                   "  ~13:D bytes for ~9:D ~(~A~) objects.~%"
556                                   objects)
557                bytes objects name))                bytes objects name))
558      (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"      (format t (intl:ngettext "  ~13:D bytes for ~9:D ~(~A~) object (space total.)~%"
559                                 "  ~13:D bytes for ~9:D ~(~A~) objects (space total.)~%"
560                                 total-objects)
561              total-bytes total-objects (car space-total))))              total-bytes total-objects (car space-total))))
562    
563    
# Line 439  Line 615 
615       space)       space)
616    
617      (format t      (format t
618              "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"              (intl:gettext "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%")
619              total-bytes code-words no-ops              total-bytes code-words no-ops
620              (round (* no-ops 100) code-words)))              (round (* no-ops 100) code-words)))
621    
# Line 469  Line 645 
645               ((#.bignum-type               ((#.bignum-type
646                 #.single-float-type                 #.single-float-type
647                 #.double-float-type                 #.double-float-type
648                   #+double-double
649                   #.double-double-float-type
650                   #.complex-single-float-type
651                   #.complex-double-float-type
652                   #+double-double
653                   #.complex-double-double-float-type
654                 #.simple-string-type                 #.simple-string-type
655                 #.simple-bit-vector-type                 #.simple-bit-vector-type
656                 #.simple-array-unsigned-byte-2-type                 #.simple-array-unsigned-byte-2-type
# Line 482  Line 664 
664                 #.simple-array-signed-byte-32-type                 #.simple-array-signed-byte-32-type
665                 #.simple-array-single-float-type                 #.simple-array-single-float-type
666                 #.simple-array-double-float-type                 #.simple-array-double-float-type
667                   #+double-double
668                   #.simple-array-double-double-float-type
669                 #.simple-array-complex-single-float-type                 #.simple-array-complex-single-float-type
670                 #.simple-array-complex-double-float-type)                 #.simple-array-complex-double-float-type
671                   #+double-double
672                   #.simple-array-complex-double-double-float-type)
673                (incf non-descriptor-headers)                (incf non-descriptor-headers)
674                (incf non-descriptor-bytes (- size word-bytes)))                (incf non-descriptor-bytes (- size word-bytes)))
675               ((#.list-pointer-type               ((#.list-pointer-type
# Line 502  Line 688 
688                 #.symbol-header-type                 #.symbol-header-type
689                 #.sap-type                 #.sap-type
690                 #.weak-pointer-type                 #.weak-pointer-type
691                 #.instance-header-type)                 #.instance-header-type
692                   #.fdefn-type
693                   #+gencgc
694                   #.scavenger-hook-type)
695                (incf descriptor-words (truncate size word-bytes)))                (incf descriptor-words (truncate size word-bytes)))
696               (t               (t
697                (error "Bogus type: ~D" type))))                (error (intl:gettext "Bogus type: ~D") type))))
698         space))         space))
699      (format t "~:D words allocated for descriptor objects.~%"      (format t (intl:gettext "~:D words allocated for descriptor objects.~%")
700              descriptor-words)              descriptor-words)
701      (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"      (format t (intl:gettext "~:D bytes data/~:D words header for non-descriptor objects.~%")
702              non-descriptor-bytes non-descriptor-headers)              non-descriptor-bytes non-descriptor-headers)
703      (values)))      (values)))
704    
# Line 521  Line 710 
710    "Print a breakdown by instance type of all the instances allocated in    "Print a breakdown by instance type of all the instances allocated in
711    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
712    largest usage."    largest usage."
713    (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)    (format t (intl:gettext "~2&~@[Top ~D ~]~(~A~) instance types:~%") top-n space)
714    (let ((totals (make-hash-table :test #'eq))    (let ((totals (make-hash-table :test #'eq))
715          (total-objects 0)          (total-objects 0)
716          (total-bytes 0))          (total-bytes 0))
717      (declare (fixnum total-objects total-bytes))      (declare (fixnum total-objects)
718                 (type memory-size total-bytes))
719      (map-allocated-objects      (map-allocated-objects
720       #'(lambda (obj type size)       #'(lambda (obj type size)
721           (declare (fixnum size) (optimize (speed 3) (safety 0)))           (declare (type memory-size size) (optimize (speed 3) (safety 0)))
722           (when (eql type instance-header-type)           (when (eql type instance-header-type)
723             (incf total-objects)             (incf total-objects)
724             (incf total-bytes size)             (incf total-bytes size)
# Line 550  Line 740 
740        (let ((sorted (sort (totals-list) #'> :key #'cddr))        (let ((sorted (sort (totals-list) #'> :key #'cddr))
741              (printed-bytes 0)              (printed-bytes 0)
742              (printed-objects 0))              (printed-objects 0))
743          (declare (fixnum printed-bytes printed-objects))          (declare (type memory-size printed-bytes printed-objects))
744          (dolist (what (if top-n          (dolist (what (if top-n
745                            (subseq sorted 0 (min (length sorted) top-n))                            (subseq sorted 0 (min (length sorted) top-n))
746                            sorted))                            sorted))
# Line 558  Line 748 
748                  (objects (cadr what)))                  (objects (cadr what)))
749              (incf printed-bytes bytes)              (incf printed-bytes bytes)
750              (incf printed-objects objects)              (incf printed-objects objects)
751              (format t "  ~A: ~:D bytes, ~D object~:P.~%" (car what)              (format t (intl:ngettext "  ~32A: ~7:D bytes, ~5D object.~%"
752                                         "  ~32A: ~7:D bytes, ~5D objects.~%"
753                                         objects)
754                        (car what)
755                      bytes objects)))                      bytes objects)))
756    
757          (let ((residual-objects (- total-objects printed-objects))          (let ((residual-objects (- total-objects printed-objects))
758                (residual-bytes (- total-bytes printed-bytes)))                (residual-bytes (- total-bytes printed-bytes)))
759            (unless (zerop residual-objects)            (unless (zerop residual-objects)
760              (format t "  Other types: ~:D bytes, ~D: object~:P.~%"              (format t (intl:ngettext "  Other types: ~:D bytes, ~D: object~:P.~%"
761                                         "  Other types: ~:D bytes, ~D: object~:P.~%"
762                                         residual-objects)
763                      residual-bytes residual-objects))))                      residual-bytes residual-objects))))
764    
765        (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"        (format t (intl:ngettext "  ~:(~A~) instance total: ~:D bytes, ~:D object.~%"
766                                   "  ~:(~A~) instance total: ~:D bytes, ~:D objects.~%"
767                                   total-objects)
768                space total-bytes total-objects)))                space total-bytes total-objects)))
769    
770    (values))    (values))
# Line 577  Line 774 
774  ;;;  ;;;
775  (defun find-holes (&rest spaces)  (defun find-holes (&rest spaces)
776    (dolist (space (or spaces '(:read-only :static :dynamic)))    (dolist (space (or spaces '(:read-only :static :dynamic)))
777      (format t "In ~A space:~%" space)      (format t (intl:gettext "In ~A space:~%") space)
778      (let ((start-addr nil)      (let ((start-addr nil)
779            (total-bytes 0))            (total-bytes 0))
780        (declare (type (or null (unsigned-byte 32)) start-addr)        (declare (type (or null (unsigned-byte 32)) start-addr)
# Line 594  Line 791 
791                     (setf start-addr (di::get-lisp-obj-address object)                     (setf start-addr (di::get-lisp-obj-address object)
792                           total-bytes bytes))                           total-bytes bytes))
793                 (when start-addr                 (when start-addr
794                   (format t "~D bytes at #x~X~%" total-bytes start-addr)                   (format t (intl:gettext "~D bytes at #x~X~%") total-bytes start-addr)
795                   (setf start-addr nil))))                   (setf start-addr nil))))
796         space)         space)
797        (when start-addr        (when start-addr
798          (format t "~D bytes at #x~X~%" total-bytes start-addr))))          (format t (intl:gettext "~D bytes at #x~X~%") total-bytes start-addr))))
799    (values))    (values))
800    
801    
# Line 791  Line 988 
988                                        (c::debug-source-name source)                                        (c::debug-source-name source)
989                                        "FROM LISP")))                                        "FROM LISP")))
990                                 (t                                 (t
991                                  (warn "No source for ~S" obj)                                  (warn (intl:gettext "No source for ~S") obj)
992                                  "NO SOURCE")))                                  "NO SOURCE")))
993                         "UNKNOWN"))                         "UNKNOWN"))
994                    (file-info (or (gethash file pkg-info)                    (file-info (or (gethash file pkg-info)
# Line 816  Line 1013 
1013    
1014        (loop for (pkg (pkg-count . pkg-size) . files) in        (loop for (pkg (pkg-count . pkg-size) . files) in
1015              (sort res #'> :key #'(lambda (x) (cdr (second x)))) do              (sort res #'> :key #'(lambda (x) (cdr (second x)))) do
1016          (format t "~%Package ~A: ~32T~9:D bytes, ~9:D object~:P.~%"          (format t (intl:ngettext "~%Package ~A: ~32T~9:D bytes, ~9:D object.~%"
1017                                     "~%Package ~A: ~32T~9:D bytes, ~9:D objects.~%"
1018                                     pkg-count)
1019                  pkg pkg-size pkg-count)                  pkg pkg-size pkg-count)
1020          (when (eq how :file)          (when (eq how :file)
1021            (loop for (file (file-count . file-size)) in            (loop for (file (file-count . file-size)) in
1022                  (sort files #'> :key #'(lambda (x) (cdr (second x)))) do                  (sort files #'> :key #'(lambda (x) (cdr (second x)))) do
1023              (format t "~30@A: ~9:D bytes, ~9:D object~:P.~%"              (format t (intl:ngettext "~30@A: ~9:D bytes, ~9:D object.~%"
1024                                         "~30@A: ~9:D bytes, ~9:D objects.~%"
1025                                         file-count)
1026                      (file-namestring file) file-size file-count))))))                      (file-namestring file) file-size file-count))))))
1027    
1028    (values))    (values))
# Line 864  Line 1065 
1065  #+nil  #+nil
1066  (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)  (defun report-histogram (table &key (low 1) (high 20) (bucket-size 1)
1067                                 (function #'identity))                                 (function #'identity))
1068    "Given a hashtable, print a histogram of the contents.  Function should give    _N"Given a hashtable, print a histogram of the contents.  Function should give
1069    the value to plot when applied to the hashtable values."    the value to plot when applied to the hashtable values."
1070    (let ((function (if (eval:interpreted-function-p function)    (let ((function (if (eval:interpreted-function-p function)
1071                        (compile nil function)                        (compile nil function)
# Line 898  Line 1099 
1099    
1100          (let ((residual (- (total-val) printed)))          (let ((residual (- (total-val) printed)))
1101            (unless (zerop residual)            (unless (zerop residual)
1102              (format t "~8:D: Other~%" residual))))              (format t (intl:gettext "~8:D: Other~%") residual))))
1103    
1104        (format t "~8:D: Total~%" (total-val))))        (format t (intl:gettext "~8:D: Total~%") (total-val))))
1105    (values))    (values))
1106    
1107    

Legend:
Removed from v.1.25.2.4  
changed lines
  Added in v.1.41

  ViewVC Help
Powered by ViewVC 1.1.5