/[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.6 by ram, Sun Apr 14 16:49:54 1991 UTC revision 1.7 by ram, Sun Apr 14 23:57:14 1991 UTC
# Line 18  Line 18 
18  (in-package "VM")  (in-package "VM")
19  (use-package "SYSTEM")  (use-package "SYSTEM")
20  (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage  (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
21                         structure-usage find-holes print-allocated-objects))                         structure-usage find-holes print-allocated-objects
22                           code-package-breakdown uninterned-symbol-count))
23  (in-package "LISP")  (in-package "LISP")
24  (import '(  (import '(
25            dynamic-0-space-start dynamic-1-space-start read-only-space-start            dynamic-0-space-start dynamic-1-space-start read-only-space-start
# Line 602  Line 603 
603                              (subseq str 0 (min (length str) 60)))))))))                              (subseq str 0 (min (length str) 60)))))))))
604         space)))         space)))
605    (values))    (values))
606    
607    ;;;; Misc:
608    
609    (defun uninterned-symbol-count (space)
610      (declare (type spaces space))
611      (let ((total 0)
612            (uninterned 0))
613        (map-allocated-objects
614         #'(lambda (obj type size)
615             (declare (ignore type size))
616             (when (symbolp obj)
617               (incf total)
618               (unless (symbol-package obj)
619                 (incf uninterned))))
620         space)
621        (values uninterned (float (/ uninterned total)))))
622    
623    (defun code-package-breakdown (space)
624      (let ((info (make-hash-table :test #'equal)))
625        (map-allocated-objects
626         #'(lambda (obj type size)
627             (when (eql type code-header-type)
628               (let* ((dinfo (code-debug-info obj))
629                      (name (if dinfo
630                                (c::compiled-debug-info-package dinfo)
631                                "UNKNOWN"))
632                      (found (or (gethash name info)
633                                 (setf (gethash name info) (cons 0 0)))))
634                 (incf (car found))
635                 (incf (cdr found) size))))
636         space)
637    
638        (collect ((res))
639          (maphash #'(lambda (k v)
640                       (res (list v k)))
641                   info)
642          (loop for ((count . size) name) in (sort (res) #'> :key #'cdar) do
643            (format t "~20@A: ~:D bytes, ~:D objects.~%" name size count))))

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

  ViewVC Help
Powered by ViewVC 1.1.5