Mercurial > hg > xemacs-beta

diff lisp/diagnose.el @ 5170:5ddbab03b0e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
various fixes to memory-usage stats -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-03-25 Ben Wing <ben@xemacs.org> * diagnose.el (show-memory-usage): * diagnose.el (show-object-memory-usage-stats): Further changes to correspond with changes in the C code; add an additional column in show-object-memory-usage-stats showing the ancillary Lisp overhead used with each type; shrink columns for windows in show-memory-usage to get it to fit in 79 chars. src/ChangeLog addition: 2010-03-25 Ben Wing <ben@xemacs.org> * alloc.c: * alloc.c (struct): * alloc.c (finish_object_memory_usage_stats): * alloc.c (object_memory_usage_stats): * alloc.c (Fobject_memory_usage): * alloc.c (lisp_object_memory_usage_full): * alloc.c (compute_memusage_stats_length): * lrecord.h: * lrecord.h (struct lrecord_implementation): Add fields to the `lrecord_implementation' structure to list an offset into the array of extra statistics in a `struct generic_usage_stats' and a length, listing the first slice of ancillary Lisp-object memory. Compute automatically in compute_memusage_stats_length(). Use to add an entry `FOO-lisp-ancillary-storage' for object type FOO. Don't crash when an int or char is given to object-memory-usage, signal an error instead. Add functions lisp_object_memory_usage_full() and lisp_object_memory_usage() to compute the total memory usage of an object (sum of object, non-Lisp attached, and Lisp ancillary memory). * array.c: * array.c (gap_array_memory_usage): * array.h: Add function to return memory usage of a gap array. * buffer.c (struct buffer_stats): * buffer.c (compute_buffer_usage): * buffer.c (vars_of_buffer): * extents.c (compute_buffer_extent_usage): * marker.c: * marker.c (compute_buffer_marker_usage): * extents.h: * lisp.h: Remove `struct usage_stats' arg from compute_buffer_marker_usage() and compute_buffer_extent_usage() -- these are ancillary Lisp objects and don't get accumulated into `struct usage_stats'; change the value of `memusage_stats_list' so that `markers' and `extents' memory is in Lisp-ancillary, where it belongs. In compute_buffer_marker_usage(), use lisp_object_memory_usage() rather than lisp_object_storage_size(). * casetab.c: * casetab.c (case_table_memory_usage): * casetab.c (vars_of_casetab): * emacs.c (main_1): Add memory usage stats for case tables. * lisp.h: Add comment explaining the `struct generic_usage_stats' more, as well as the new fields in lrecord_implementation. * console-impl.h: * console-impl.h (struct console_methods): * scrollbar-gtk.c: * scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): * scrollbar-msw.c: * scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage): * scrollbar-x.c: * scrollbar-x.c (x_compute_scrollbar_instance_usage): * scrollbar.c: * scrollbar.c (struct scrollbar_instance_stats): * scrollbar.c (compute_all_scrollbar_instance_usage): * scrollbar.c (scrollbar_instance_memory_usage): * scrollbar.c (scrollbar_objects_create): * scrollbar.c (vars_of_scrollbar): * scrollbar.h: * symsinit.h: * window.c: * window.c (find_window_mirror_maybe): * window.c (struct window_mirror_stats): * window.c (compute_window_mirror_usage): * window.c (window_mirror_memory_usage): * window.c (compute_window_usage): * window.c (window_objects_create): * window.c (syms_of_window): * window.c (vars_of_window): Redo memory-usage associated with windows, window mirrors, and scrollbar instances. Should fix crash in find_window_mirror, among other things. Properly assign memo ry to object memory, non-Lisp extra memory, and Lisp ancillary memory. For example, redisplay structures are non-Lisp memory hanging off a window mirror, not a window; make it an ancillary Lisp-object field. Window mirrors and scrollbar instances have their own statistics, among other things.
author Ben Wing <ben@xemacs.org>
date Thu, 25 Mar 2010 06:07:25 -0500
parents ab9ee10a53e4
children 4c56e7c6a704
line wrap: on
line diff
--- a/lisp/diagnose.el	Wed Mar 24 01:22:51 2010 -0500
+++ b/lisp/diagnose.el	Thu Mar 25 06:07:25 2010 -0500
@@ -35,11 +35,12 @@
   "Show statistics about memory usage of various sorts in XEmacs."
   (interactive)
   (garbage-collect)
-  (flet ((show-foo-stats (objtypename cleanfun objlist)
+  (flet ((show-foo-stats (objtypename statname-plist cleanfun objlist
+			  &optional objnamelen)
 	   (let* ((hash (make-hash-table))
 		  (first t)
-		  types fmt
-		  (objnamelen 25)
+		  types origtypes fmt
+		  (objnamelen (or objnamelen 25))
 		  (linelen objnamelen)
 		  (totaltotal 0))
 	     (loop for obj in objlist do
@@ -54,19 +55,22 @@
 		 ;; the  memory grouped by type
 		 (while (and stats (pop stats)))
 
-		 (loop for (type . num) in stats while type do
+		 (loop for (type . num) in (remq t stats) while type do
+		   (if first (push type origtypes))
+		   (setq type (getf statname-plist type type))
 		   (puthash type (+ num (or (gethash type hash) 0)) hash)
 		   (incf total num)
 		   (if first (push type types)))
 		 (incf totaltotal total)
 		 (when first
 		   (setq types (nreverse types))
+		   (setq origtypes (nreverse origtypes))
 		   (setq fmt (concat
 			      (format "%%-%ds" objnamelen)
 			      (mapconcat
 			       #'(lambda (type)
 				   (let ((fieldlen
-					  (max 8 (+ 2 (length
+					  (max 7 (+ 2 (length
 						       (symbol-name type))))))
 				     (incf linelen fieldlen)
 				     (format "%%%ds" fieldlen)))
@@ -83,7 +87,7 @@
 							     (1- objnamelen)))
 				 (nconc (mapcar #'(lambda (type)
 						    (cdr (assq type stats)))
-						types)
+						origtypes)
 					(list total)))))
 		 (setq first nil)))
 	     (princ "\n")
@@ -103,7 +107,7 @@
 	  (when-fboundp 'charset-list
 	    (setq begin (point))
 	    (incf grandtotal
-		  (show-foo-stats 'charset 'charset-name
+		  (show-foo-stats 'charset nil 'charset-name
 				  (mapcar 'get-charset (charset-list))))
 	    (when-fboundp 'sort-numeric-fields
 	      (sort-numeric-fields -1
@@ -117,7 +121,7 @@
 	    (princ "\n"))
 	  (setq begin (point))
 	  (incf grandtotal
-		(show-foo-stats 'buffer 'buffer-name (buffer-list)))
+		(show-foo-stats 'buffer nil 'buffer-name (buffer-list)))
 	  (when-fboundp 'sort-numeric-fields
 	    (sort-numeric-fields -1
 				 (save-excursion
@@ -130,11 +134,19 @@
 	  (princ "\n")
 	  (setq begin (point))
 	  (incf grandtotal
-		(show-foo-stats 'window #'(lambda (x)
-					    (buffer-name (window-buffer x)))
+		(show-foo-stats 'window
+				'(line-start-cache line-st.
+				  face-cache face
+				  glyph-cache glyph
+				  redisplay-structs redisplay
+				  scrollbar-instances scrollbar
+				  window-mirror mirror)
+				#'(lambda (x)
+				    (buffer-name (window-buffer x)))
 				(mapcan #'(lambda (fr)
 					    (window-list fr t))
-					(frame-list))))
+					(frame-list))
+				16))
           (when-fboundp #'sort-numeric-fields
             (sort-numeric-fields -1
                                  (save-excursion
@@ -152,9 +164,14 @@
 	    (princ (make-string 40 ?-))
 	    (princ "\n")
 	    (map-plist #'(lambda (stat num)
-			   (when (string-match 
-				  "\\(.*\\)-storage$"
-				  (symbol-name stat))
+			   (when (and
+				  (not
+				   (string-match 
+				    "\\(.*\\)-ancillary-storage$"
+				    (symbol-name stat)))
+				  (string-match 
+				   "\\(.*\\)-storage$"
+				   (symbol-name stat)))
 			     (incf total num)
 			     (princ (format fmt
 					    (match-string 1 (symbol-name stat))
@@ -184,12 +201,14 @@
   (garbage-collect)
   (let ((buffer "*object memory usage statistics*")
 	(plist (object-memory-usage-stats))
-	(fmt "%-30s%10s%10s%10s%18s\n")
+	(fmt "%-28s%10s%10s%10s%10s%10s\n")
 	(grandtotal 0)
 	begin)
   (flet ((show-stats (match-string)
-	(princ (format fmt "object" "count" "storage" "overhead"
-		       "non-Lisp storage"))
+	(princ (format "%28s%10s%40s\n" "" ""
+		       "--------------storage---------------"))
+	(princ (format fmt "object" "count" "object" "overhead"
+		       "non-Lisp" "ancillary"))
 	(princ (make-string 78 ?-))
 	(princ "\n")
 	(let ((total-use 0)
@@ -202,9 +221,13 @@
 	       (let ((symmatch
 		      (and (string-match match-string (symbol-name stat))
 			   (match-string 1 (symbol-name stat)))))
-		 (when (and symmatch (or (< (length symmatch) 9)
-					 (not (equal (substring symmatch -9)
-						     "-non-lisp"))))
+		 (when (and symmatch
+			    (or (< (length symmatch) 9)
+				(not (equal (substring symmatch -9)
+					    "-non-lisp")))
+			    (or (< (length symmatch) 15)
+				(not (equal (substring symmatch -15)
+					    "-lisp-ancillary"))))
 		   (let* ((storage-use num)
 			  (storage-use-overhead
 			   (or (plist-get 
@@ -227,6 +250,12 @@
 				(intern (concat symmatch
 						"-non-lisp-storage")))
 			       0))
+			  (lisp-ancillary-storage
+			   (or (plist-get
+				plist
+				(intern (concat symmatch
+						"-lisp-ancillary-storage")))
+			       0))
 			  (storage-count 
 			   (or (loop for str in '("s-used" "es-used" "-used")
 				 for val = (plist-get
@@ -251,19 +280,20 @@
 					 (or storage-count "unknown")
 					 storage-use
 					 storage-use-overhead
-					 non-lisp-storage)))))))
+					 non-lisp-storage
+					 lisp-ancillary-storage)))))))
 	   plist)
 	  (princ "\n")
 	  (princ (format fmt "total" 
 			 total-count total-use total-use-overhead
-			 total-non-lisp-use))
+			 total-non-lisp-use ""))
 	  (incf grandtotal total-use-with-overhead)
 	  (incf grandtotal total-non-lisp-use)
           (when-fboundp #'sort-numeric-fields
-            (sort-numeric-fields -3
+            (sort-numeric-fields -4
                                  (save-excursion
                                    (goto-char begin)
-                                   (forward-line 3)
+                                   (forward-line 4)
                                    (point))
                                  (save-excursion
                                    (forward-line -2)