redo memory-usage mechanism, add way of dynamically initializing Lisp objects -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-03-18 Ben Wing <ben@xemacs.org> * diagnose.el (show-memory-usage): Rewrite to take into account API changes in memory-usage functions. src/ChangeLog addition: 2010-03-18 Ben Wing <ben@xemacs.org> * alloc.c: * alloc.c (disksave_object_finalization_1): * alloc.c (lisp_object_storage_size): * alloc.c (listu): * alloc.c (listn): * alloc.c (Fobject_memory_usage_stats): * alloc.c (compute_memusage_stats_length): * alloc.c (Fobject_memory_usage): * alloc.c (Ftotal_object_memory_usage): * alloc.c (malloced_storage_size): * alloc.c (common_init_alloc_early): * alloc.c (reinit_alloc_objects_early): * alloc.c (reinit_alloc_early): * alloc.c (init_alloc_once_early): * alloc.c (syms_of_alloc): * alloc.c (reinit_vars_of_alloc): * buffer.c: * buffer.c (struct buffer_stats): * buffer.c (compute_buffer_text_usage): * buffer.c (compute_buffer_usage): * buffer.c (buffer_memory_usage): * buffer.c (buffer_objects_create): * buffer.c (syms_of_buffer): * buffer.c (vars_of_buffer): * console-impl.h (struct console_methods): * dynarr.c (Dynarr_memory_usage): * emacs.c (main_1): * events.c (clear_event_resource): * extents.c: * extents.c (compute_buffer_extent_usage): * extents.c (extent_objects_create): * extents.h: * faces.c: * faces.c (compute_face_cachel_usage): * faces.c (face_objects_create): * faces.h: * general-slots.h: * glyphs.c: * glyphs.c (compute_glyph_cachel_usage): * glyphs.c (glyph_objects_create): * glyphs.h: * lisp.h: * lisp.h (struct usage_stats): * lrecord.h: * lrecord.h (enum lrecord_type): * lrecord.h (struct lrecord_implementation): * lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE): * lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT): * lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT): * lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT): * lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT): * lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT): * lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT): * lrecord.h (MAKE_LISP_OBJECT): * lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT): * lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT): * lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT): * lrecord.h (MAKE_MODULE_LISP_OBJECT): * lrecord.h (INIT_LISP_OBJECT): * lrecord.h (INIT_MODULE_LISP_OBJECT): * lrecord.h (UNDEF_LISP_OBJECT): * lrecord.h (UNDEF_MODULE_LISP_OBJECT): * lrecord.h (DECLARE_LISP_OBJECT): * lrecord.h (DECLARE_MODULE_API_LISP_OBJECT): * lrecord.h (DECLARE_MODULE_LISP_OBJECT): * lstream.c: * lstream.c (syms_of_lstream): * lstream.c (vars_of_lstream): * marker.c: * marker.c (compute_buffer_marker_usage): * mc-alloc.c (mc_alloced_storage_size): * mc-alloc.h: * mule-charset.c: * mule-charset.c (struct charset_stats): * mule-charset.c (compute_charset_usage): * mule-charset.c (charset_memory_usage): * mule-charset.c (mule_charset_objects_create): * mule-charset.c (syms_of_mule_charset): * mule-charset.c (vars_of_mule_charset): * redisplay.c: * redisplay.c (compute_rune_dynarr_usage): * redisplay.c (compute_display_block_dynarr_usage): * redisplay.c (compute_glyph_block_dynarr_usage): * redisplay.c (compute_display_line_dynarr_usage): * redisplay.c (compute_line_start_cache_dynarr_usage): * redisplay.h: * scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): * scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage): * scrollbar-x.c (x_compute_scrollbar_instance_usage): * scrollbar.c (compute_scrollbar_instance_usage): * scrollbar.h: * symbols.c: * symbols.c (reinit_symbol_objects_early): * symbols.c (init_symbols_once_early): * symbols.c (reinit_symbols_early): * symbols.c (defsymbol_massage_name_1): * symsinit.h: * ui-gtk.c: * ui-gtk.c (emacs_gtk_object_getprop): * ui-gtk.c (emacs_gtk_object_putprop): * ui-gtk.c (ui_gtk_objects_create): * unicode.c (compute_from_unicode_table_size_1): * unicode.c (compute_to_unicode_table_size_1): * unicode.c (compute_from_unicode_table_size): * unicode.c (compute_to_unicode_table_size): * window.c: * window.c (struct window_stats): * window.c (compute_window_mirror_usage): * window.c (compute_window_usage): * window.c (window_memory_usage): * window.c (window_objects_create): * window.c (syms_of_window): * window.c (vars_of_window): * window.h: Redo memory-usage mechanism, make it general; add way of dynamically initializing Lisp object types -- OBJECT_HAS_METHOD(), similar to CONSOLE_HAS_METHOD(). (1) Create OBJECT_HAS_METHOD(), OBJECT_HAS_PROPERTY() etc. for specifying that a Lisp object type has a particular method or property. Call such methods with OBJECT_METH, MAYBE_OBJECT_METH, OBJECT_METH_OR_GIVEN; retrieve properties with OBJECT_PROPERTY. Methods that formerly required a DEFINE_*GENERAL_LISP_OBJECT() to specify them (getprop, putprop, remprop, plist, disksave) now instead use the dynamic-method mechanism. The main benefit of this is that new methods or properties can be added without requiring that the declaration statements of all existing methods be modified. We have to make the `struct lrecord_implementation' non-const, but I don't think this should have any effect on speed -- the only possible method that's really speed-critical is the mark method, and we already extract those out into a separate (non-const) array for increased cache locality. Object methods need to be reinitialized after pdump, so we put them in separate functions such as face_objects_create(), extent_objects_create() and call them appropriately from emacs.c The only current object property (`memusage_stats_list') that objects can specify is a Lisp object and gets staticpro()ed so it only needs to be set during dump time, but because it references symbols that might not exist in a syms_of_() function, we initialize it in vars_of_(). There is also an object property (`num_extra_memusage_stats') that is automatically initialized based on `memusage_stats_list'; we do that in reinit_vars_of_alloc(), which is called after all vars_of_() functions are called. `disksaver' method was renamed `disksave' to correspond with the name normally given to the function (e.g. disksave_lstream()). (2) Generalize the memory-usage mechanism in `buffer-memory-usage', `window-memory-usage', `charset-memory-usage' into an object-type- specific mechanism called by a single function `object-memory-usage'. (Former function `object-memory-usage' renamed to `total-object-memory-usage'). Generalize the mechanism of different "slices" so that we can have different "classes" of memory described and different "slices" onto each class; `t' separates classes, `nil' separates slices. Currently we have three classes defined: the memory of an object itself, non-Lisp-object memory associated with the object (e.g. arrays or dynarrs stored as fields in the object), and Lisp-object memory associated with the object (other internal Lisp objects stored in the object). This isn't completely finished yet and we might need to further separate the "other internal Lisp objects" class into two classes. The memory-usage mechanism uses a `struct usage_stats' (renamed from `struct overhead_stats') to describe a malloc-view onto a set of allocated memory (listing how much was requested and various types of overhead) and a more general `struct generic_usage_stats' (with a `struct usage_stats' in it) to hold all statistics about object memory. `struct generic_usage_stats' contains an array of 32 Bytecounts, which are statistics of unspecified semantics. The intention is that individual types declare a corresponding struct (e.g. `struct window_stats') with the same structure but with specific fields in place of the array, corresponding to specific statistics. The number of such statistics is an object property computed from the list of tags (Lisp symbols describing the statistics) stored in `memusage_stats_list'. The idea here is to allow particular object types to customize the number and semantics of the statistics where completely avoiding consing. This doesn't matter so much yet, but the intention is to have the memory usage of all objects computed at the end of GC, at the same time as other statistics are currently computed. The values for all statistics for a single type would be added up to compute aggregate values for all objects of a specific type. To make this efficient, we can't allow any memory allocation at all. (3) Create some additional functions for creating lists that specify the elements directly as args rather than indirectly through an array: listn() (number of args given), listu() (list terminated by Qunbound). (4) Delete a bit of remaining unused C window_config stuff, also unused lrecord_type_popup_data.

;;; disp-table.el --- functions for dealing with char tables.

;; Copyright (C) 1987, 1994, 1997, 2007 Free Software Foundation, Inc.
;; Copyright (C) 1995 Sun Microsystems.
;; Copyright (C) 2005 Ben Wing.

;; Maintainer: XEmacs Development Team
;; Keywords: i18n, internal

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the 
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not synched with FSF.

;;; Commentary:

;; Rewritten for XEmacs July 1995, Ben Wing.
;; November 1998?, display tables generalized to char/range tables, Hrvoje
;; Niksic.
;; July 2007, rewrite this file to handle generalized display tables,
;; Aidan Kehoe.

;;; Code:

;;;###autoload
(defun make-display-table ()
  "Return a new, empty display table.

This returns a generic character table; previously it returned a vector, but
that was not helpful when dealing with internationalized characters above
?\xFF.  See `make-char-table' for details of character tables in general.  To
write code that works with both vectors and character tables, add something
like the following to the beginning of your file, and use
`put-display-table' to set what a given character is displayed as, and
`get-display-table' to examine what that character is currently displayed
as:

\(defun-when-void put-display-table (range value display-table)
  \"Set the value for char RANGE to VALUE in DISPLAY-TABLE.  \"
  (if (sequencep display-table)
      (aset display-table range value)
    (put-char-table range value display-table)))

\(defun-when-void get-display-table (character display-table)
  \"Find value for CHARACTER in DISPLAY-TABLE.  \"
  (if (sequencep display-table)
      (aref display-table character)
    (get-char-table character display-table)))

In this implementation, `put-display-table' and `get-display-table' are
aliases of `put-char-table' and `get-char-table' respectively, and are
always available."
  (make-char-table 'generic))

;;;###autoload
(defalias 'put-display-table #'put-char-table)

;;;###autoload
(defalias 'get-display-table #'get-char-table)

(defun describe-display-table (dt)
  "Describe the display table DT in a help buffer."
  (with-displaying-help-buffer
   (lambda ()
     (map-char-table
      (lambda (range value)
        (cond
         ((eq range t)
          (princ "\nAll characters: \n")
          (princ (format "  %S" value)))
         ((eq 'charset (and (symbolp range) (type-of (find-charset range))))
          (princ (format "\n\nCharset %S: \n" (charset-name range)))
          (princ (format "  %S" value)))
         ((vectorp range)
          (princ (format "\n\nCharset %S, row %d \n"
                         (charset-name (aref value 0))
                         (aref value 1)))
          (princ (format "  %S\n\n" value)))
         ((characterp range)
          (princ (format "\nCharacter U+%04X, %S: "
                         range (if (fboundp 'split-char)
                                   (split-char range)
                                 (list 'ascii (char-to-int range)))))
          (princ (format "  %S" value))))
        nil) dt)
     (princ 
      "\n\nFor some of the various other glyphs that GNU Emacs uses the display
table for, see the XEmacs specifiers `truncation-glyph' ,
`continuation-glyph', `control-arrow-glyph', `octal-escape-glyph' and the
others described in the docstring of `make-glyph'. \n\n"))))


;;;###autoload
(defun describe-current-display-table (&optional domain)
  "Describe the display table in use in the selected window and buffer."
  (interactive)
  (or domain (setq domain (selected-window)))
  (let ((disptab (specifier-instance current-display-table domain)))
    (if disptab
	(describe-display-table disptab)
      (message "No display table"))))

;; #### we need a generic frob-specifier function.
;; #### this also needs to be redone like frob-face-property.

;; Let me say one more time how much dynamic scoping sucks.

;; #### Need more thinking about basic primitives for modifying a specifier.
;; cf `modify-specifier-instances'.

;;;###autoload
(defun frob-display-table (fdt-function fdt-locale &optional tag-set)
  (or fdt-locale (setq fdt-locale 'global))
  (or (specifier-spec-list current-display-table fdt-locale tag-set)
      (add-spec-to-specifier current-display-table (make-display-table)
			     fdt-locale tag-set))
  (add-spec-list-to-specifier
   current-display-table
   (list (cons fdt-locale
	       (mapcar
		(lambda (fdt-x)
                  (funcall fdt-function (cdr fdt-x))
                  fdt-x)
		(cdar (specifier-spec-list current-display-table
					   fdt-locale tag-set)))))))

(defun standard-display-8bit-1 (dt l h)
  (while (<= l h)
    (remove-char-table (int-to-char l) dt)
    (setq l (1+ l))))

;;;###autoload
(defun standard-display-8bit (l h &optional locale)
  "Display characters in the range L to H literally [sic].

GNU Emacs includes this function.  There, `literally' has no good meaning.
Under XEmacs, this function makes characters with numeric values in the
range L to H display as themselves; that is, as ASCII, latin-iso8859-1,
latin-iso8859-2 or whatever.  See `standard-display-default' for the inverse
function.  "
  (frob-display-table
   (lambda (x)
     (standard-display-8bit-1 x l h))
   locale))

(defun standard-display-default-1 (dt l h)
  "Misnamed function under XEmacs. See `standard-display-default'."
  (while (<= l h)
    (put-char-table (int-to-char l) (format "\\%o" l) dt)
    (setq l (1+ l))))

;;;###autoload
(defun standard-display-default (l h &optional locale)
  "Display characters in the range L to H using octal escape notation.

In the XEmacs context this function is misnamed.  Under GNU Emacs,
characters in the range #xA0 to #xFF display as octal escapes unless
`standard-display-european' has been called; this function neutralizes the
effects of `standard-display-european'.  Under XEmacs, those characters
normally do not display as octal escapes (this ignores hackery like
specifying the X11 font character set on non-Mule builds) and this function
sets them to display as octal escapes.  "
  (frob-display-table
   (lambda (x)
     (standard-display-default-1 x l h))
   locale))

;;;###autoload
(defun standard-display-ascii (c s &optional locale)
  "Display character C using printable string S."
  (frob-display-table
   (lambda (x)
     (put-char-table c s x))
   locale))

;;;###autoload
(defun standard-display-g1 (c sc &optional locale)
  "Display character C as character SC in the g1 character set.
This only has an effect on TTY devices and assumes that your terminal uses
the SO/SI characters."
  (frob-display-table
   (lambda (x)
     (put-char-table c (concat "\016" (char-to-string sc) "\017") x))
   locale '(tty)))

;;;###autoload
(defun standard-display-graphic (c gc &optional locale)
  "Display character C as character GC in graphics character set.
This only has an effect on TTY devices and assumes VT100-compatible escapes."
  (frob-display-table
   (lambda (x)
     (put-char-table c (concat "\e(0" (char-to-string gc) "\e(B") x))
   locale '(tty)))

;;;###autoload
(defun standard-display-underline (c uc &optional locale)
  "Display character C as character UC plus underlining."
  (frob-display-table
   (lambda (x)
     (let (glyph)
       (setq glyph (make-glyph (vector 'string :data (char-to-string uc))))
       (set-glyph-face glyph 'underline)
       (put-char-table c glyph x)))
   locale))

;;;###autoload
(defun standard-display-european (arg &optional locale)
  "Toggle display of European characters encoded with ISO 8859-1.
When enabled (the default), characters in the range of 160 to 255 display
as accented characters. With negative prefix argument, display characters in
that range as octal escapes.  

If you want to work in a Western European language under XEmacs, it
shouldn't be necessary to call this function--things should just work.  But
it's in a sufficient number of init files that we're not in a hurry to
remove it.  "
  (interactive "P")
  (if (<= (prefix-numeric-value arg) 0)
      (frob-display-table
       (lambda (x)
         (standard-display-default-1 x 160 255))
       locale)
    (frob-display-table
     (lambda (x)
       (standard-display-8bit-1 x 160 255))
       locale)))

(provide 'disp-table)

;;; disp-table.el ends here