Mercurial > hg > xemacs-beta
annotate lisp/userlock.el @ 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 | 576fb035e263 |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 ;;; userlock.el --- handle file access contention between multiple users |
| 2 | |
| 3 ;; Copyright (C) 1985, 1986, 1993 Free Software Foundation, inc. | |
| 4 | |
| 5 ;; Maintainer: FSF | |
| 6 ;; Keywords: internal | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: FSF 19.34. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;; This file is autoloaded to handle certain conditions | |
| 30 ;; detected by the file-locking code within XEmacs. | |
| 31 ;; The two entry points are `ask-user-about-lock' and | |
| 32 ;; `ask-user-about-supersession-threat'. | |
| 33 | |
| 34 ;;; Code: | |
| 35 | |
| 36 (define-error 'file-locked "File is locked" 'file-error) ; XEmacs | |
| 37 | |
| 444 | 38 (defun ask-user-about-lock-minibuf (filename other-user) |
| 428 | 39 (save-window-excursion |
| 40 (let (answer) | |
| 41 (while (null answer) | |
| 444 | 42 (message "%s is locking %s: action (s, q, p, ?)? " other-user filename) |
| 428 | 43 (let ((tem (let ((inhibit-quit t) |
| 44 (cursor-in-echo-area t)) | |
| 45 (prog1 (downcase (read-char)) | |
| 46 (setq quit-flag nil))))) | |
| 47 (if (= tem help-char) | |
| 48 (ask-user-about-lock-help) | |
| 49 (setq answer (assoc tem '((?s . t) | |
| 50 (?q . yield) | |
| 51 (?\C-g . yield) | |
| 52 (?p . nil) | |
| 53 (?? . help)))) | |
| 54 (cond ((null answer) | |
| 55 (beep) | |
| 56 (message "Please type q, s, or p; or ? for help") | |
| 57 (sit-for 3)) | |
| 58 ((eq (cdr answer) 'help) | |
| 59 (ask-user-about-lock-help) | |
| 60 (setq answer nil)) | |
| 61 ((eq (cdr answer) 'yield) | |
| 444 | 62 (signal 'file-locked (list "File is locked" filename other-user))))))) |
| 428 | 63 (cdr answer)))) |
| 64 | |
| 65 (defun ask-user-about-lock-help () | |
| 66 (with-output-to-temp-buffer "*Help*" | |
| 67 (princ "It has been detected that you want to modify a file that someone else has | |
| 68 already started modifying in EMACS. | |
| 69 | |
| 70 You can <s>teal the file; The other user becomes the | |
| 71 intruder if (s)he ever unmodifies the file and then changes it again. | |
| 72 You can <p>roceed; you edit at your own (and the other user's) risk. | |
| 73 You can <q>uit; don't modify this file.") | |
| 74 (save-excursion | |
| 75 (set-buffer standard-output) | |
| 76 (help-mode)))) | |
| 77 | |
| 78 (define-error 'file-supersession "File changed on disk" 'file-error) ; XEmacs | |
| 79 | |
| 444 | 80 (defun ask-user-about-supersession-threat-minibuf (filename) |
| 428 | 81 (save-window-excursion |
| 82 (let (answer) | |
| 83 (while (null answer) | |
| 84 (message "%s changed on disk; really edit the buffer? (y, n, r or C-h) " | |
| 444 | 85 (file-name-nondirectory filename)) |
| 428 | 86 (let ((tem (downcase (let ((cursor-in-echo-area t)) |
| 87 (read-char))))) | |
| 88 (setq answer | |
| 89 (if (= tem help-char) | |
| 90 'help | |
| 91 (cdr (assoc tem '((?n . yield) | |
| 92 (?\C-g . yield) | |
| 93 (?y . proceed) | |
| 94 (?r . revert) | |
| 95 (?? . help)))))) | |
| 96 (cond ((null answer) | |
| 97 (beep) | |
| 98 (message "Please type y, n or r; or ? for help") | |
| 99 (sit-for 3)) | |
| 100 ((eq answer 'help) | |
| 101 (ask-user-about-supersession-help) | |
| 102 (setq answer nil)) | |
| 103 ((eq answer 'revert) | |
| 104 (revert-buffer nil (not (buffer-modified-p))) | |
| 105 ; ask confirmation iff buffer modified | |
| 106 (signal 'file-supersession | |
| 444 | 107 (list "File reverted" filename))) |
| 428 | 108 ((eq answer 'yield) |
| 109 (signal 'file-supersession | |
| 444 | 110 (list "File changed on disk" filename)))))) |
| 428 | 111 (message |
| 112 "File on disk now will become a backup file if you save these changes.") | |
| 113 (setq buffer-backed-up nil)))) | |
| 114 | |
| 115 (defun ask-user-about-supersession-help () | |
| 116 (with-output-to-temp-buffer "*Help*" | |
| 117 (princ "You want to modify a buffer whose disk file has changed | |
| 118 since you last read it in or saved it with this buffer. | |
| 119 | |
| 120 If you say `y' to go ahead and modify this buffer, | |
| 121 you risk ruining the work of whoever rewrote the file. | |
| 122 If you say `r' to revert, the contents of the buffer are refreshed | |
| 123 from the file on disk. | |
| 124 If you say `n', the change you started to make will be aborted. | |
| 125 | |
| 126 Usually, you should type `n' and then `M-x revert-buffer', | |
| 127 to get the latest version of the file, then make the change again.") | |
| 128 (save-excursion | |
| 129 (set-buffer standard-output) | |
| 130 (help-mode)))) | |
| 131 | |
| 132 ;;; dialog-box versions [XEmacs] | |
| 133 | |
| 444 | 134 (defun ask-user-about-lock-dbox (filename other-user) |
| 442 | 135 (let ((echo-keystrokes 0)) |
| 136 (make-dialog-box | |
| 137 'question | |
| 138 :question (format "%s is locking %s\n | |
| 428 | 139 It has been detected that you want to modify a file that |
| 140 someone else has already started modifying in XEmacs." | |
| 444 | 141 other-user filename) |
| 442 | 142 :buttons |
| 143 '(["Steal Lock\n\nThe other user will\nbecome the intruder" steal t] | |
| 144 ["Proceed\n\nEdit file at your own\n\(and the other user's) risk" | |
| 145 proceed t] | |
| 146 nil | |
| 147 ["Abort\n\nDon't modify the buffer\n" yield t])) | |
| 428 | 148 (catch 'aual-done |
| 149 (while t | |
| 150 (let ((event (next-command-event))) | |
| 442 | 151 (cond ((and (misc-user-event-p event) |
| 152 (eq (event-object event) 'proceed)) | |
| 428 | 153 (throw 'aual-done nil)) |
| 442 | 154 ((and (misc-user-event-p event) |
| 155 (eq (event-object event) 'steal)) | |
| 428 | 156 (throw 'aual-done t)) |
| 442 | 157 ((and (misc-user-event-p event) |
| 158 (eq (event-object event) 'yield)) | |
| 444 | 159 (signal 'file-locked (list "File is locked" filename other-user))) |
| 428 | 160 ((and (misc-user-event-p event) |
| 161 (eq (event-object event) 'menu-no-selection-hook)) | |
| 162 (signal 'quit nil)) | |
| 442 | 163 ;; safety check, so we're not endlessly stuck when no |
| 164 ;; dialog box up | |
| 165 ((not (popup-up-p)) | |
| 166 (signal 'quit nil)) | |
| 428 | 167 ((button-release-event-p event) ;; don't beep twice |
| 168 nil) | |
| 169 (t | |
| 170 (beep) | |
| 171 (message "please answer the dialog box")))))))) | |
| 172 | |
| 444 | 173 (defun ask-user-about-supersession-threat-dbox (filename) |
| 442 | 174 (let ((echo-keystrokes 0)) |
| 175 (make-dialog-box | |
| 176 'question | |
| 177 :question | |
| 178 (format "File %s has changed on disk | |
| 428 | 179 since its buffer was last read in or saved. |
| 180 | |
| 444 | 181 Do you really want to edit the buffer? " filename) |
| 442 | 182 :buttons |
| 183 '(["Yes\n\nEdit the buffer anyway,\nignoring the disk file" | |
| 184 proceed t] | |
| 185 ["No\n\nDon't modify the buffer\n" yield t] | |
| 186 nil | |
| 187 ["No\n\nDon't modify the buffer\nbut revert it" revert t] | |
| 188 )) | |
| 428 | 189 (catch 'auast-done |
| 190 (while t | |
| 191 (let ((event (next-command-event))) | |
| 192 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed)) | |
| 193 (throw 'auast-done nil)) | |
| 194 ((and (misc-user-event-p event) (eq (event-object event) 'yield)) | |
| 444 | 195 (signal 'file-supersession (list filename))) |
| 428 | 196 ((and (misc-user-event-p event) (eq (event-object event) 'revert)) |
| 444 | 197 (or (equal filename (buffer-file-name)) |
| 428 | 198 (error |
| 199 "ask-user-about-supersession-threat called bogusly")) | |
| 200 (revert-buffer nil t) | |
| 201 (signal 'file-supersession | |
| 444 | 202 (list filename "(reverted)"))) |
| 428 | 203 ((and (misc-user-event-p event) |
| 204 (eq (event-object event) 'menu-no-selection-hook)) | |
| 205 (signal 'quit nil)) | |
| 442 | 206 ;; safety check, so we're not endlessly stuck when no |
| 207 ;; dialog box up | |
| 208 ((not (popup-up-p)) | |
| 209 (signal 'quit nil)) | |
| 428 | 210 ((button-release-event-p event) ;; don't beep twice |
| 211 nil) | |
| 212 (t | |
| 213 (beep) | |
| 214 (message "please answer the dialog box")))))))) | |
| 215 | |
| 216 | |
| 217 ;;; top-level | |
| 218 | |
| 219 ;;;###autoload | |
| 444 | 220 (defun ask-user-about-lock (filename other-user) |
| 221 "Ask user wanting to edit FILENAME, locked by OTHER-USER, what to do. | |
| 428 | 222 This function has a choice of three things to do: |
| 444 | 223 do (signal 'file-locked (list FILENAME OTHER-USER)) |
| 428 | 224 to refrain from editing the file |
| 225 return t (grab the lock on the file) | |
| 226 return nil (edit the file even though it is locked). | |
| 444 | 227 You can rewrite it to use any criteria you like to choose which one to do." |
| 428 | 228 (discard-input) |
| 442 | 229 (if (should-use-dialog-box-p) |
| 444 | 230 (ask-user-about-lock-dbox filename other-user) |
| 231 (ask-user-about-lock-minibuf filename other-user))) | |
| 428 | 232 |
| 233 ;;;###autoload | |
| 444 | 234 (defun ask-user-about-supersession-threat (filename) |
| 235 "Ask user who is about to modify an obsolete buffer what to do. | |
| 428 | 236 This function has two choices: it can return, in which case the modification |
| 444 | 237 of the buffer will proceed, or it can (signal 'file-supersession (FILENAME)), |
| 428 | 238 in which case the proposed buffer modification will not be made. |
| 239 | |
| 444 | 240 You can rewrite this to use any criteria you like to choose which one to do. |
| 428 | 241 The buffer in question is current when this function is called." |
| 242 (discard-input) | |
| 442 | 243 (if (should-use-dialog-box-p) |
| 444 | 244 (ask-user-about-supersession-threat-dbox filename) |
| 245 (ask-user-about-supersession-threat-minibuf filename))) | |
| 428 | 246 |
| 247 ;;; userlock.el ends here |