Mercurial > hg > xemacs-beta
view src/EmacsShell-sub.c @ 5157:1fae11d56ad2
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.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Thu, 18 Mar 2010 10:50:06 -0500 |
| parents | 726060ee587c |
| children | 308d34e9f07d |
line wrap: on
line source
/* Emacs shell widget -- define the two widgets. Copyright (C) 1994, 1995 Sun Microsystems, Inc. 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, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ /* Written by Ben Wing, May, 1994. */ /* It is rather unfortunate that we have to do this. Blame those short-sighted people who designed the monstrosities known as Xt and ICCCM. */ /* This widget is not actually Emacs-specific; perhaps there could be a better name than "EmacsShell". What it does is work around a limitation in Xt in correctly dealing with the window-manager size hints with applications that (a) dynamically change their window size (b) have a cell size (width-inc and height-inc) other than 1 and (c) cannot predict in advance exactly what size their shell will be (This is the more common situation, when you have a number of widgets, each with their own size ideas) This widget assumes that your program contains a fixed "base size" plus some number of cells (e.g. character cells). The WMShell resources "widthInc" and "heightInc" specify the size of a character cell, and the window manager will report the app's size in cells rather than in pixels. If you use this widget, do not use the WMShell resources "baseWidth", "baseHeight", "minWidth", or "minHeight". Instead, use "widthCells" and "heightCells" to specify the current size in cells (you must keep this up-to-date), and "minWidthCells" and "minHeightCells" to specify the minimum size in cells. Every time that the program issues a size command, the "baseWidth", "baseHeight", "minWidth", and "minHeight" fields of the WM_NORMAL_HINTS property will be updated to stay in line with the resource values specified above. The calculations are done once the desired shell size is known but before the window-manager size-change request is issued. (We must do it at this time because before then we don't know what size we will request, and after the request the deed has already been done.) After you change the "baseWidth", "baseHeight", "minWidth", or "minHeight" resources, you need to call EmacsShellUpdateSizeHints() to manually update the size hints, except in the following two circumstances: (a) you are about to make a geometry request. (b) you are changing only "baseWidth" and "baseHeight" from within a resize procedure. (In this case, the size hints are already correct.) */ #include <config.h> #include <stdio.h> #include <stdlib.h> #include <X11/StringDefs.h> #include "xintrinsicp.h" #include <X11/Shell.h> #include <X11/ShellP.h> #include <X11/Vendor.h> #include <X11/VendorP.h> #include "EmacsShellP.h" #include "../lwlib/xt-wrappers.h" #define ABORT abort #if defined (DEFINE_TOP_LEVEL_EMACS_SHELL) #define EMACS_SHELL_WIDGET TopLevelEmacsShellWidget #define SUPERCLASS_WIDGET_CLASS topLevelShellWidgetClass #define SUPERCLASS_CLASS_REC topLevelShellClassRec #define EMACS_SHELL_REC TopLevelEmacsShellRec #define EMACS_SHELL_CLASS_REC topLevelEmacsShellClassRec #define EMACS_SHELL_CLASS_REC_TYPE TopLevelEmacsShellClassRec #define EMACS_SHELL_CLASS_NAME "TopLevelEmacsShell" #define EMACS_SHELL_WIDGET_CLASS topLevelEmacsShellWidgetClass #define EMACS_SHELL_UPDATE_SIZE_HINTS TopLevelEmacsShellUpdateSizeHints #elif defined (DEFINE_TRANSIENT_EMACS_SHELL) #define EMACS_SHELL_WIDGET TransientEmacsShellWidget #define SUPERCLASS_WIDGET_CLASS transientShellWidgetClass #define SUPERCLASS_CLASS_REC transientShellClassRec #define EMACS_SHELL_REC TransientEmacsShellRec #define EMACS_SHELL_CLASS_REC transientEmacsShellClassRec #define EMACS_SHELL_CLASS_REC_TYPE TransientEmacsShellClassRec #define EMACS_SHELL_CLASS_NAME "TransientEmacsShell" #define EMACS_SHELL_WIDGET_CLASS transientEmacsShellWidgetClass #define EMACS_SHELL_UPDATE_SIZE_HINTS TransientEmacsShellUpdateSizeHints #else Error. Must define either DEFINE_TOP_LEVEL_EMACS_SHELL or DEFINE_TRANSIENT_EMACS_SHELL. #endif typedef struct { XtPointer next_extension; XrmQuark record_type; long version; Cardinal record_size; } GenericClassExtRec; static XtGeometryResult RootGeometryManager (Widget gw, XtWidgetGeometry *request, XtWidgetGeometry *reply); static void ChangeManaged (Widget w); /* snarfed from Shell.c */ #define BIGSIZE ((Dimension)32767) static XtResource resources[] = { #define offset(field) XtOffset(EMACS_SHELL_WIDGET, emacs_shell.field) #define coreoffset(field) XtOffset(EMACS_SHELL_WIDGET, core.field) #define res(name,_class,member,size) \ { (String) name, (String) _class, XtRInt, sizeof (int), \ offset (member), XtRImmediate, (XtPointer)0 } #define motifres(name,member) \ { (String) name, XtCPosition, XtRPosition, sizeof (Position), \ coreoffset (member), XtRImmediate, (XtPointer)BIGSIZE } #ifdef LWLIB_USES_MOTIF /* *** BOGOSITY^10! *** The Motif VendorShell fucks around with the default values for X and Y, for no obvious reason. This causes Shell to indicate that the defaults of (0,0) were program-specified, instead of letting the WM do what it wants. */ motifres (XtNx, x), motifres (XtNy, y), #endif res (XtNwidthCells, XtCWidthCells, width_cells, 0), res (XtNheightCells, XtCHeightCells, height_cells, 0), res (XtNminWidthCells, XtCMinWidthCells, min_width_cells, 0), res (XtNminHeightCells, XtCMinHeightCells, min_height_cells, 0), #undef offset #undef coreoffset #undef res #undef motifres }; static CompositeClassExtensionRec compositeClassExtRec = { NULL, NULLQUARK, XtCompositeExtensionVersion, sizeof (CompositeClassExtensionRec), TRUE, }; static ShellClassExtensionRec shellClassExtRec = { NULL, NULLQUARK, XtShellExtensionVersion, sizeof (ShellClassExtensionRec), RootGeometryManager }; EMACS_SHELL_CLASS_REC_TYPE EMACS_SHELL_CLASS_REC = { { /* * core_class fields */ /* superclass */ (WidgetClass) &SUPERCLASS_CLASS_REC, /* class_name */ (String) EMACS_SHELL_CLASS_NAME, /* size */ sizeof (EMACS_SHELL_REC), /* Class Initializer */ NULL, /* class_part_initialize*/ NULL, /* XtInheritClassPartInitialize, */ /* Class init'ed ? */ FALSE, /* initialize */ NULL, /* initialize_notify */ NULL, /* realize */ XtInheritRealize, /* actions */ NULL, /* num_actions */ 0, /* resources */ resources, /* resource_count */ XtNumber (resources), /* xrm_class */ NULLQUARK, /* compress_motion */ TRUE, /* compress_exposure */ XtExposeCompressMaximal | XtExposeNoRegion, /* compress_enterleave*/ TRUE, /* visible_interest */ TRUE, /* destroy */ NULL, /* resize */ XtInheritResize, /* expose */ NULL, /* set_values */ NULL, /* XtInheritSetValues, */ /* set_values_hook */ NULL, /* set_values_almost */ XtInheritSetValuesAlmost, /* get_values_hook */ NULL, /* accept_focus */ NULL, /* intrinsics version */ XtVersion, /* callback offsets */ NULL, /* tm_table */ NULL, /* query_geometry */ NULL, /* display_accelerator*/ NULL, /* extension */ NULL },{ /* Composite */ /* geometry_manager */ XtInheritGeometryManager, /* change_managed */ ChangeManaged, /* insert_child */ XtInheritInsertChild, /* delete_child */ XtInheritDeleteChild, /* extension */ (XtPointer)&compositeClassExtRec },{ /* Shell */ /* extension */ (XtPointer)&shellClassExtRec },{ /* WMShell */ /* extension */ NULL },{ /* VendorShell */ /* extension */ NULL },{ /* TopLevelShell or TransientShell */ /* both have exactly one XtPointer here. */ /* extension */ NULL },{ /* EmacsShell */ 0 } }; WidgetClass EMACS_SHELL_WIDGET_CLASS = (WidgetClass) &EMACS_SHELL_CLASS_REC; static void update_size_hints_internal (EMACS_SHELL_WIDGET w, int width, int height) { int base_width, base_height; int cell_width, cell_height; Arg al [10]; /* time to update them thar size hints */ cell_width = w->wm.size_hints.width_inc; cell_height = w->wm.size_hints.height_inc; base_width = width - cell_width * w->emacs_shell.width_cells; base_height = height - cell_height * w->emacs_shell.height_cells; #ifdef DEBUG_GEOMETRY_MANAGEMENT /* Very useful info when debugging geometry management problems. When it's guaranteed that no more such problems exist, take this stuff out. */ printf ("update_size_hints_internal:\n"); printf (" actual pixel size: %d %d\n", width, height); printf (" cell size in pixels: %d %d\n", cell_width, cell_height); printf (" text area size in cells: %d %d\n", w->emacs_shell.width_cells, w->emacs_shell.height_cells); printf (" base size set to: %d %d\n", base_width, base_height); fflush (stdout); #endif Xt_SET_ARG(al [0], XtNbaseWidth, base_width); Xt_SET_ARG(al [1], XtNbaseHeight, base_height); Xt_SET_ARG(al [2], XtNminWidth, base_width + cell_width * w->emacs_shell.min_width_cells); Xt_SET_ARG(al [3], XtNminHeight, base_height + cell_height * w->emacs_shell.min_height_cells); XtSetValues ((Widget) w, al, 4); } static XtGeometryResult SuperClassRootGeometryManager (Widget gw, XtWidgetGeometry *request, XtWidgetGeometry *reply) { ShellWidgetClass swc = (ShellWidgetClass) SUPERCLASS_WIDGET_CLASS; ShellClassExtensionRec *scer; GenericClassExtRec *gcer; /* find the shell extension record that specifies the root geometry manager method #### We could use XtGetClassExtension here. */ for (gcer = (GenericClassExtRec *) swc->shell_class.extension; gcer; gcer = (GenericClassExtRec *) gcer->next_extension) { if (gcer->record_type == NULLQUARK) break; } /* #### The R11.6.4 Xt specification says if we don't find NULLQUARK here, we should assume root_geometry_manager = XtInheritRootGeometryManager. Is that actually callable? */ if (!gcer) ABORT (); /* call it to actually make the geometry request */ scer = (ShellClassExtensionRec *) gcer; return (scer->root_geometry_manager)(gw, request, reply); } static XtGeometryResult RootGeometryManager (Widget gw, XtWidgetGeometry *request, XtWidgetGeometry *reply) { EMACS_SHELL_WIDGET w = (EMACS_SHELL_WIDGET) gw; /* OK since this file is not dumped */ static int reentrant = 0; XtGeometryResult result; if (reentrant) ABORT (); reentrant++; #ifdef DEBUG_GEOMETRY_MANAGEMENT printf ("root_geometry_manager:\n"); printf (" current shell size: %d %d\n", w->core.width, w->core.height); if (request->request_mode & CWWidth) printf ("width requested;"); if (request->request_mode & CWHeight) printf ("height requested;"); printf ("\n"); printf (" requested shell size: %d %d\n", request->width, request->height); #endif /* update the size hints */ update_size_hints_internal (w, request->request_mode & CWWidth ? request->width : w->core.width, request->request_mode & CWHeight ? request->height : w->core.height); result = SuperClassRootGeometryManager (gw, request, reply); #ifdef DEBUG_GEOMETRY_MANAGEMENT printf (" result: %s\n", result == XtGeometryYes ? "XtGeometryYes" : result == XtGeometryNo ? "XtGeometryNo" : result == XtGeometryAlmost ? "XtGeometryAlmost" : "XtGeometryDone"); if (reply->request_mode & CWWidth) printf ("width returned was %d%s", reply->width, reply->request_mode & CWHeight ? "; " : ".\n"); if (reply->request_mode & CWHeight) printf ("height returned was %d.\n", reply->height); /* #### does this also need to depend on the result? With XtGeometryYes there doesn't seem to be a useful reply object. */ printf (" resulting shell size: %d %d\n", reply->request_mode & CWWidth ? reply->width : w->core.width, reply->request_mode & CWHeight ? reply->height : w->core.height); printf ("----------\n"); fflush (stdout); #endif reentrant--; return result; } static void ChangeManaged (Widget wid) { EMACS_SHELL_WIDGET w = (EMACS_SHELL_WIDGET) wid; /* If not realized, then we're being called from XtRealizeWidget(). RootGeometryManager() has not yet been called, and thus our base size is incorrect. We need to set it now or the Shell will mess up geometry specifications with negative positional offsets. */ if (!XtIsRealized (wid)) { Widget child = NULL; Cardinal i; /* the managed child indicates what our size is */ for (i = 0; i < w->composite.num_children; i++) { if (XtIsManaged(w->composite.children[i])) { child = w->composite.children[i]; break; } } update_size_hints_internal (w, child->core.width, child->core.height); } /* call the real ChangeManaged */ (((ShellWidgetClass) SUPERCLASS_WIDGET_CLASS)-> composite_class.change_managed)(wid); } /******************* external entry points *********************/ void EMACS_SHELL_UPDATE_SIZE_HINTS (Widget gw) { EMACS_SHELL_WIDGET w = (EMACS_SHELL_WIDGET) gw; update_size_hints_internal (w, w->core.width, w->core.height); }
