From 55718b85c3e6472b3e73da296970765f5fe3a8e0 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sun, 14 Apr 1991 23:57:14 +0000
Subject: [PATCH] Added CODE-PACKAGE-BREAKDOWN and UNINTERNED-SYMBOL-COUNT.

---
 code/room.lisp | 45 ++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 42 insertions(+), 3 deletions(-)

diff --git a/code/room.lisp b/code/room.lisp
index 4ca3e5427..544278562 100644
--- a/code/room.lisp
+++ b/code/room.lisp
@@ -7,18 +7,19 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.6 1991/04/14 16:49:54 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.7 1991/04/14 23:57:14 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.6 1991/04/14 16:49:54 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.7 1991/04/14 23:57:14 ram Exp $
 ;;; 
 ;;; Heap grovelling memory usage stuff.
 ;;; 
 (in-package "VM")
 (use-package "SYSTEM")
 (export '(memory-usage count-no-ops descriptor-vs-non-descriptor-storage
-		       structure-usage find-holes print-allocated-objects))
+		       structure-usage find-holes print-allocated-objects
+		       code-package-breakdown uninterned-symbol-count))
 (in-package "LISP")
 (import '(
 	  dynamic-0-space-start dynamic-1-space-start read-only-space-start
@@ -602,3 +603,41 @@
 			    (subseq str 0 (min (length str) 60)))))))))
        space)))
   (values))
+
+;;;; Misc:
+
+(defun uninterned-symbol-count (space)
+  (declare (type spaces space))
+  (let ((total 0)
+	(uninterned 0))
+    (map-allocated-objects
+     #'(lambda (obj type size)
+	 (declare (ignore type size))
+	 (when (symbolp obj)
+	   (incf total)
+	   (unless (symbol-package obj)
+	     (incf uninterned))))
+     space)
+    (values uninterned (float (/ uninterned total)))))
+
+(defun code-package-breakdown (space)
+  (let ((info (make-hash-table :test #'equal)))
+    (map-allocated-objects
+     #'(lambda (obj type size)
+	 (when (eql type code-header-type)
+	   (let* ((dinfo (code-debug-info obj))
+		  (name (if dinfo
+			    (c::compiled-debug-info-package dinfo)
+			    "UNKNOWN"))
+		  (found (or (gethash name info)
+			     (setf (gethash name info) (cons 0 0)))))
+	     (incf (car found))
+	     (incf (cdr found) size))))
+     space)
+
+    (collect ((res))
+      (maphash #'(lambda (k v)
+		   (res (list v k)))
+	       info)
+      (loop for ((count . size) name) in (sort (res) #'> :key #'cdar) do
+	(format t "~20@A: ~:D bytes, ~:D objects.~%" name size count))))
-- 
GitLab