Mercurial > hg > xemacs-beta
annotate src/alloc.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 | 88bd4f3ef8e4 |
| children | 9e0b43d3095c |
| rev | line source |
|---|---|
| 428 | 1 /* Storage allocation and gc for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1998 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
|
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
4 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2010 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from | |
| 24 FSF. */ | |
| 25 | |
| 26 /* Authorship: | |
| 27 | |
| 28 FSF: Original version; a long time ago. | |
| 29 Mly: Significantly rewritten to use new 3-bit tags and | |
| 30 nicely abstracted object definitions, for 19.8. | |
| 31 JWZ: Improved code to keep track of purespace usage and | |
| 32 issue nice purespace and GC stats. | |
| 33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking | |
| 34 and various changes for Mule, for 19.12. | |
| 35 Added bit vectors for 19.13. | |
| 36 Added lcrecord lists for 19.14. | |
| 37 slb: Lots of work on the purification and dump time code. | |
| 38 Synched Doug Lea malloc support from Emacs 20.2. | |
| 442 | 39 og: Killed the purespace. Portable dumper (moved to dumper.c) |
| 428 | 40 */ |
| 41 | |
| 42 #include <config.h> | |
| 43 #include "lisp.h" | |
| 44 | |
| 45 #include "backtrace.h" | |
| 46 #include "buffer.h" | |
| 47 #include "bytecode.h" | |
| 48 #include "chartab.h" | |
| 49 #include "device.h" | |
| 50 #include "elhash.h" | |
| 51 #include "events.h" | |
| 872 | 52 #include "extents-impl.h" |
| 1204 | 53 #include "file-coding.h" |
| 872 | 54 #include "frame-impl.h" |
| 3092 | 55 #include "gc.h" |
| 428 | 56 #include "glyphs.h" |
| 57 #include "opaque.h" | |
| 1204 | 58 #include "lstream.h" |
| 872 | 59 #include "process.h" |
| 1292 | 60 #include "profile.h" |
| 428 | 61 #include "redisplay.h" |
| 62 #include "specifier.h" | |
| 63 #include "sysfile.h" | |
| 442 | 64 #include "sysdep.h" |
| 428 | 65 #include "window.h" |
| 3092 | 66 #ifdef NEW_GC |
| 67 #include "vdb.h" | |
| 68 #endif /* NEW_GC */ | |
| 428 | 69 #include "console-stream.h" |
| 70 | |
| 71 #ifdef DOUG_LEA_MALLOC | |
| 72 #include <malloc.h> | |
| 73 #endif | |
|
4803
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
74 #ifdef USE_VALGRIND |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
75 #include <valgrind/memcheck.h> |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
76 #endif |
| 428 | 77 |
| 78 EXFUN (Fgarbage_collect, 0); | |
| 79 | |
| 80 #if 0 /* this is _way_ too slow to be part of the standard debug options */ | |
| 81 #if defined(DEBUG_XEMACS) && defined(MULE) | |
| 82 #define VERIFY_STRING_CHARS_INTEGRITY | |
| 83 #endif | |
| 84 #endif | |
| 85 | |
| 86 /* Define this to use malloc/free with no freelist for all datatypes, | |
| 87 the hope being that some debugging tools may help detect | |
| 88 freed memory references */ | |
| 89 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */ | |
| 90 #include <dmalloc.h> | |
| 91 #define ALLOC_NO_POOLS | |
| 92 #endif | |
| 93 | |
| 94 #ifdef DEBUG_XEMACS | |
| 458 | 95 static Fixnum debug_allocation; |
| 96 static Fixnum debug_allocation_backtrace_length; | |
| 428 | 97 #endif |
| 98 | |
| 851 | 99 int need_to_check_c_alloca; |
| 887 | 100 int need_to_signal_post_gc; |
| 851 | 101 int funcall_allocation_flag; |
| 102 Bytecount __temp_alloca_size__; | |
| 103 Bytecount funcall_alloca_count; | |
| 814 | 104 |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
105 /* All the built-in lisp object types are enumerated in `enum lrecord_type'. |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
106 Additional ones may be defined by a module (none yet). We leave some |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
107 room in `lrecord_implementations_table' for such new lisp object types. */ |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
108 struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
109 int lrecord_type_count = lrecord_type_last_built_in_type; |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
110 |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
111 /* This is just for use by the printer, to allow things to print uniquely. |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
112 We have a separate UID space for each object. (Important because the |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
113 UID is only 20 bits in old-GC, and 22 in NEW_GC.) */ |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
114 int lrecord_uid_counter[countof (lrecord_implementations_table)]; |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
115 |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
116 /* Non-zero means we're in the process of doing the dump */ |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
117 int purify_flag; |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
118 |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
119 /* Non-zero means we're pdumping out or in */ |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
120 #ifdef PDUMP |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
121 int in_pdump; |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
122 #endif |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
123 |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
124 #ifdef ERROR_CHECK_TYPES |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
125 |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
126 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN, ERROR_ME_DEBUG_WARN; |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
127 |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
128 #endif |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
129 |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
130 #ifdef MEMORY_USAGE_STATS |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
131 Lisp_Object Qobject_actually_requested, Qobject_malloc_overhead; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
132 Lisp_Object Qother_memory_actually_requested, Qother_memory_malloc_overhead; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
133 Lisp_Object Qother_memory_dynarr_overhead, Qother_memory_gap_overhead; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
134 #endif /* MEMORY_USAGE_STATS */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
135 |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
136 /* Very cheesy ways of figuring out how much memory is being used for |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
137 data. #### Need better (system-dependent) ways. */ |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
138 void *minimum_address_seen; |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
139 void *maximum_address_seen; |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
140 |
| 814 | 141 /* Determine now whether we need to garbage collect or not, to make |
| 142 Ffuncall() faster */ | |
| 143 #define INCREMENT_CONS_COUNTER_1(size) \ | |
| 144 do \ | |
| 145 { \ | |
| 146 consing_since_gc += (size); \ | |
| 1292 | 147 total_consing += (size); \ |
| 148 if (profiling_active) \ | |
| 149 profile_record_consing (size); \ | |
| 814 | 150 recompute_need_to_garbage_collect (); \ |
| 151 } while (0) | |
| 428 | 152 |
| 153 #define debug_allocation_backtrace() \ | |
| 154 do { \ | |
| 155 if (debug_allocation_backtrace_length > 0) \ | |
| 156 debug_short_backtrace (debug_allocation_backtrace_length); \ | |
| 157 } while (0) | |
| 158 | |
| 159 #ifdef DEBUG_XEMACS | |
| 801 | 160 #define INCREMENT_CONS_COUNTER(foosize, type) \ |
| 161 do { \ | |
| 162 if (debug_allocation) \ | |
| 163 { \ | |
| 164 stderr_out ("allocating %s (size %ld)\n", type, \ | |
| 165 (long) foosize); \ | |
| 166 debug_allocation_backtrace (); \ | |
| 167 } \ | |
| 168 INCREMENT_CONS_COUNTER_1 (foosize); \ | |
| 428 | 169 } while (0) |
| 170 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \ | |
| 171 do { \ | |
| 172 if (debug_allocation > 1) \ | |
| 173 { \ | |
| 801 | 174 stderr_out ("allocating noseeum %s (size %ld)\n", type, \ |
| 175 (long) foosize); \ | |
| 428 | 176 debug_allocation_backtrace (); \ |
| 177 } \ | |
| 178 INCREMENT_CONS_COUNTER_1 (foosize); \ | |
| 179 } while (0) | |
| 180 #else | |
| 181 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size) | |
| 182 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \ | |
| 183 INCREMENT_CONS_COUNTER_1 (size) | |
| 184 #endif | |
| 185 | |
| 3092 | 186 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
187 /* [[ The call to recompute_need_to_garbage_collect is moved to |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
188 free_normal_lisp_object, since DECREMENT_CONS_COUNTER is extensively called |
| 3092 | 189 during sweep and recomputing need_to_garbage_collect all the time |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
190 is not needed. ]] -- not accurate! */ |
| 3092 | 191 #define DECREMENT_CONS_COUNTER(size) do { \ |
| 192 consing_since_gc -= (size); \ | |
| 193 total_consing -= (size); \ | |
| 194 if (profiling_active) \ | |
| 195 profile_record_unconsing (size); \ | |
| 196 if (consing_since_gc < 0) \ | |
| 197 consing_since_gc = 0; \ | |
| 198 } while (0) | |
| 199 #else /* not NEW_GC */ | |
| 428 | 200 #define DECREMENT_CONS_COUNTER(size) do { \ |
| 201 consing_since_gc -= (size); \ | |
| 1292 | 202 total_consing -= (size); \ |
| 203 if (profiling_active) \ | |
| 204 profile_record_unconsing (size); \ | |
| 428 | 205 if (consing_since_gc < 0) \ |
| 206 consing_since_gc = 0; \ | |
| 814 | 207 recompute_need_to_garbage_collect (); \ |
| 428 | 208 } while (0) |
| 3092 | 209 #endif /*not NEW_GC */ |
| 428 | 210 |
| 3263 | 211 #ifndef NEW_GC |
| 428 | 212 int |
| 213 c_readonly (Lisp_Object obj) | |
| 214 { | |
| 215 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj); | |
| 216 } | |
| 3263 | 217 #endif /* not NEW_GC */ |
| 428 | 218 |
| 219 int | |
| 220 lisp_readonly (Lisp_Object obj) | |
| 221 { | |
| 222 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj); | |
| 223 } | |
| 224 | |
| 225 | |
| 226 /* Maximum amount of C stack to save when a GC happens. */ | |
| 227 | |
| 228 #ifndef MAX_SAVE_STACK | |
| 229 #define MAX_SAVE_STACK 0 /* 16000 */ | |
| 230 #endif | |
| 231 | |
| 232 /* Non-zero means ignore malloc warnings. Set during initialization. */ | |
| 233 int ignore_malloc_warnings; | |
| 234 | |
| 235 | |
| 3263 | 236 #ifndef NEW_GC |
| 3092 | 237 void *breathing_space; |
| 428 | 238 |
| 239 void | |
| 240 release_breathing_space (void) | |
| 241 { | |
| 242 if (breathing_space) | |
| 243 { | |
| 244 void *tmp = breathing_space; | |
| 245 breathing_space = 0; | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
246 xfree (tmp); |
| 428 | 247 } |
| 248 } | |
| 3263 | 249 #endif /* not NEW_GC */ |
| 428 | 250 |
| 801 | 251 static void |
| 252 set_alloc_mins_and_maxes (void *val, Bytecount size) | |
| 253 { | |
| 254 if (!val) | |
| 255 return; | |
| 256 if ((char *) val + size > (char *) maximum_address_seen) | |
| 257 maximum_address_seen = (char *) val + size; | |
| 258 if (!minimum_address_seen) | |
| 259 minimum_address_seen = | |
| 260 #if SIZEOF_VOID_P == 8 | |
| 261 (void *) 0xFFFFFFFFFFFFFFFF; | |
| 262 #else | |
| 263 (void *) 0xFFFFFFFF; | |
| 264 #endif | |
| 265 if ((char *) val < (char *) minimum_address_seen) | |
| 266 minimum_address_seen = (char *) val; | |
| 267 } | |
| 268 | |
| 1315 | 269 #ifdef ERROR_CHECK_MALLOC |
| 3176 | 270 static int in_malloc; |
| 1333 | 271 extern int regex_malloc_disallowed; |
| 2367 | 272 |
| 273 #define MALLOC_BEGIN() \ | |
| 274 do \ | |
| 275 { \ | |
| 3176 | 276 assert (!in_malloc); \ |
| 2367 | 277 assert (!regex_malloc_disallowed); \ |
| 278 in_malloc = 1; \ | |
| 279 } \ | |
| 280 while (0) | |
| 281 | |
| 3263 | 282 #ifdef NEW_GC |
| 2720 | 283 #define FREE_OR_REALLOC_BEGIN(block) \ |
| 284 do \ | |
| 285 { \ | |
| 286 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \ | |
| 287 error until much later on for many system mallocs, such as \ | |
| 288 the one that comes with Solaris 2.3. FMH!! */ \ | |
|
4938
299dce99bdad
(for main branch) when freeing check against DEADBEEF_CONSTANT since that's what we use elsewhere
Ben Wing <ben@xemacs.org>
parents:
4934
diff
changeset
|
289 assert (block != (void *) DEADBEEF_CONSTANT); \ |
| 2720 | 290 MALLOC_BEGIN (); \ |
| 291 } \ | |
| 292 while (0) | |
| 3263 | 293 #else /* not NEW_GC */ |
| 2367 | 294 #define FREE_OR_REALLOC_BEGIN(block) \ |
| 295 do \ | |
| 296 { \ | |
| 297 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \ | |
| 298 error until much later on for many system mallocs, such as \ | |
| 299 the one that comes with Solaris 2.3. FMH!! */ \ | |
|
4938
299dce99bdad
(for main branch) when freeing check against DEADBEEF_CONSTANT since that's what we use elsewhere
Ben Wing <ben@xemacs.org>
parents:
4934
diff
changeset
|
300 assert (block != (void *) DEADBEEF_CONSTANT); \ |
| 2367 | 301 /* You cannot free something within dumped space, because there is \ |
| 302 no longer any sort of malloc structure associated with the block. \ | |
| 303 If you are tripping this, you may need to conditionalize on \ | |
| 304 DUMPEDP. */ \ | |
| 305 assert (!DUMPEDP (block)); \ | |
| 306 MALLOC_BEGIN (); \ | |
| 307 } \ | |
| 308 while (0) | |
| 3263 | 309 #endif /* not NEW_GC */ |
| 2367 | 310 |
| 311 #define MALLOC_END() \ | |
| 312 do \ | |
| 313 { \ | |
| 314 in_malloc = 0; \ | |
| 315 } \ | |
| 316 while (0) | |
| 317 | |
| 318 #else /* ERROR_CHECK_MALLOC */ | |
| 319 | |
| 2658 | 320 #define MALLOC_BEGIN() |
| 2367 | 321 #define FREE_OR_REALLOC_BEGIN(block) |
| 322 #define MALLOC_END() | |
| 323 | |
| 324 #endif /* ERROR_CHECK_MALLOC */ | |
| 325 | |
| 326 static void | |
| 327 malloc_after (void *val, Bytecount size) | |
| 328 { | |
| 329 if (!val && size != 0) | |
| 330 memory_full (); | |
| 331 set_alloc_mins_and_maxes (val, size); | |
| 332 } | |
| 333 | |
| 3305 | 334 /* malloc calls this if it finds we are near exhausting storage */ |
| 335 void | |
| 336 malloc_warning (const char *str) | |
| 337 { | |
| 338 if (ignore_malloc_warnings) | |
| 339 return; | |
| 340 | |
| 341 /* Remove the malloc lock here, because warn_when_safe may allocate | |
| 342 again. It is safe to remove the malloc lock here, because malloc | |
| 343 is already finished (malloc_warning is called via | |
| 344 after_morecore_hook -> check_memory_limits -> save_warn_fun -> | |
| 345 malloc_warning). */ | |
| 346 MALLOC_END (); | |
| 347 | |
| 348 warn_when_safe | |
| 349 (Qmemory, Qemergency, | |
| 350 "%s\n" | |
| 351 "Killing some buffers may delay running out of memory.\n" | |
| 352 "However, certainly by the time you receive the 95%% warning,\n" | |
| 353 "you should clean up, kill this Emacs, and start a new one.", | |
| 354 str); | |
| 355 } | |
| 356 | |
| 357 /* Called if malloc returns zero */ | |
| 358 DOESNT_RETURN | |
| 359 memory_full (void) | |
| 360 { | |
| 361 /* Force a GC next time eval is called. | |
| 362 It's better to loop garbage-collecting (we might reclaim enough | |
| 363 to win) than to loop beeping and barfing "Memory exhausted" | |
| 364 */ | |
| 365 consing_since_gc = gc_cons_threshold + 1; | |
| 366 recompute_need_to_garbage_collect (); | |
| 367 #ifdef NEW_GC | |
| 368 /* Put mc-alloc into memory shortage mode. This may keep XEmacs | |
| 369 alive until the garbage collector can free enough memory to get | |
| 370 us out of the memory exhaustion. If already in memory shortage | |
| 371 mode, we are in a loop and hopelessly lost. */ | |
| 372 if (memory_shortage) | |
| 373 { | |
| 374 fprintf (stderr, "Memory full, cannot recover.\n"); | |
| 375 ABORT (); | |
| 376 } | |
| 377 fprintf (stderr, | |
| 378 "Memory full, try to recover.\n" | |
| 379 "You should clean up, kill this Emacs, and start a new one.\n"); | |
| 380 memory_shortage++; | |
| 381 #else /* not NEW_GC */ | |
| 382 release_breathing_space (); | |
| 383 #endif /* not NEW_GC */ | |
| 384 | |
| 385 /* Flush some histories which might conceivably contain garbalogical | |
| 386 inhibitors. */ | |
| 387 if (!NILP (Fboundp (Qvalues))) | |
| 388 Fset (Qvalues, Qnil); | |
| 389 Vcommand_history = Qnil; | |
| 390 | |
| 391 out_of_memory ("Memory exhausted", Qunbound); | |
| 392 } | |
| 393 | |
| 2367 | 394 /* like malloc, calloc, realloc, free but: |
| 395 | |
| 396 -- check for no memory left | |
| 397 -- set internal mins and maxes | |
| 398 -- with error-checking on, check for reentrancy, invalid freeing, etc. | |
| 399 */ | |
| 1292 | 400 |
| 428 | 401 #undef xmalloc |
| 402 void * | |
| 665 | 403 xmalloc (Bytecount size) |
| 428 | 404 { |
| 1292 | 405 void *val; |
| 2367 | 406 MALLOC_BEGIN (); |
| 1292 | 407 val = malloc (size); |
| 2367 | 408 MALLOC_END (); |
| 409 malloc_after (val, size); | |
| 428 | 410 return val; |
| 411 } | |
| 412 | |
| 413 #undef xcalloc | |
| 414 static void * | |
| 665 | 415 xcalloc (Elemcount nelem, Bytecount elsize) |
| 428 | 416 { |
| 1292 | 417 void *val; |
| 2367 | 418 MALLOC_BEGIN (); |
| 1292 | 419 val= calloc (nelem, elsize); |
| 2367 | 420 MALLOC_END (); |
| 421 malloc_after (val, nelem * elsize); | |
| 428 | 422 return val; |
| 423 } | |
| 424 | |
| 425 void * | |
| 665 | 426 xmalloc_and_zero (Bytecount size) |
| 428 | 427 { |
| 428 return xcalloc (size, sizeof (char)); | |
| 429 } | |
| 430 | |
| 431 #undef xrealloc | |
| 432 void * | |
| 665 | 433 xrealloc (void *block, Bytecount size) |
| 428 | 434 { |
| 2367 | 435 FREE_OR_REALLOC_BEGIN (block); |
| 551 | 436 block = realloc (block, size); |
| 2367 | 437 MALLOC_END (); |
| 438 malloc_after (block, size); | |
| 551 | 439 return block; |
| 428 | 440 } |
| 441 | |
| 442 void | |
| 443 xfree_1 (void *block) | |
| 444 { | |
| 445 #ifdef ERROR_CHECK_MALLOC | |
| 446 assert (block); | |
| 447 #endif /* ERROR_CHECK_MALLOC */ | |
| 2367 | 448 FREE_OR_REALLOC_BEGIN (block); |
| 428 | 449 free (block); |
| 2367 | 450 MALLOC_END (); |
| 428 | 451 } |
| 452 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
453 void |
| 665 | 454 deadbeef_memory (void *ptr, Bytecount size) |
| 428 | 455 { |
| 826 | 456 UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr; |
| 665 | 457 Bytecount beefs = size >> 2; |
| 428 | 458 |
| 459 /* In practice, size will always be a multiple of four. */ | |
| 460 while (beefs--) | |
| 1204 | 461 (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */ |
| 428 | 462 } |
| 463 | |
| 464 #undef xstrdup | |
| 465 char * | |
| 442 | 466 xstrdup (const char *str) |
| 428 | 467 { |
| 468 int len = strlen (str) + 1; /* for stupid terminating 0 */ | |
| 469 void *val = xmalloc (len); | |
| 771 | 470 |
| 428 | 471 if (val == 0) return 0; |
| 472 return (char *) memcpy (val, str, len); | |
| 473 } | |
| 474 | |
| 475 #ifdef NEED_STRDUP | |
| 476 char * | |
| 442 | 477 strdup (const char *s) |
| 428 | 478 { |
| 479 return xstrdup (s); | |
| 480 } | |
| 481 #endif /* NEED_STRDUP */ | |
| 482 | |
| 483 | |
| 3263 | 484 #ifndef NEW_GC |
| 428 | 485 static void * |
| 665 | 486 allocate_lisp_storage (Bytecount size) |
| 428 | 487 { |
| 793 | 488 void *val = xmalloc (size); |
| 489 /* We don't increment the cons counter anymore. Calling functions do | |
| 490 that now because we have two different kinds of cons counters -- one | |
| 491 for normal objects, and one for no-see-um conses (and possibly others | |
| 492 similar) where the conses are used totally internally, never escape, | |
| 493 and are created and then freed and shouldn't logically increment the | |
| 494 cons counting. #### (Or perhaps, we should decrement it when an object | |
| 495 get freed?) */ | |
| 496 | |
| 497 /* But we do now (as of 3-27-02) go and zero out the memory. This is a | |
| 498 good thing, as it will guarantee we won't get any intermittent bugs | |
| 1204 | 499 coming from an uninitiated field. The speed loss is unnoticeable, |
| 500 esp. as the objects are not large -- large stuff like buffer text and | |
| 501 redisplay structures are allocated separately. */ | |
| 793 | 502 memset (val, 0, size); |
| 851 | 503 |
| 504 if (need_to_check_c_alloca) | |
| 505 xemacs_c_alloca (0); | |
| 506 | |
| 793 | 507 return val; |
| 428 | 508 } |
| 3263 | 509 #endif /* not NEW_GC */ |
| 510 | |
| 511 #if defined (NEW_GC) && defined (ALLOC_TYPE_STATS) | |
| 2720 | 512 static struct |
| 513 { | |
| 514 int instances_in_use; | |
| 515 int bytes_in_use; | |
| 516 int bytes_in_use_including_overhead; | |
| 3461 | 517 } lrecord_stats [countof (lrecord_implementations_table)]; |
| 2720 | 518 |
| 519 void | |
| 520 init_lrecord_stats () | |
| 521 { | |
| 522 xzero (lrecord_stats); | |
| 523 } | |
| 524 | |
| 525 void | |
| 526 inc_lrecord_stats (Bytecount size, const struct lrecord_header *h) | |
| 527 { | |
| 528 int type_index = h->type; | |
| 529 if (!size) | |
| 530 size = detagged_lisp_object_size (h); | |
| 531 | |
| 532 lrecord_stats[type_index].instances_in_use++; | |
| 533 lrecord_stats[type_index].bytes_in_use += size; | |
| 534 lrecord_stats[type_index].bytes_in_use_including_overhead | |
| 535 #ifdef MEMORY_USAGE_STATS | |
| 536 += mc_alloced_storage_size (size, 0); | |
| 537 #else /* not MEMORY_USAGE_STATS */ | |
| 538 += size; | |
| 539 #endif /* not MEMORY_USAGE_STATS */ | |
| 540 } | |
| 541 | |
| 542 void | |
| 543 dec_lrecord_stats (Bytecount size_including_overhead, | |
| 544 const struct lrecord_header *h) | |
| 545 { | |
| 546 int type_index = h->type; | |
| 2775 | 547 int size = detagged_lisp_object_size (h); |
| 2720 | 548 |
| 549 lrecord_stats[type_index].instances_in_use--; | |
| 2775 | 550 lrecord_stats[type_index].bytes_in_use -= size; |
| 2720 | 551 lrecord_stats[type_index].bytes_in_use_including_overhead |
| 552 -= size_including_overhead; | |
| 553 | |
| 2775 | 554 DECREMENT_CONS_COUNTER (size); |
| 2720 | 555 } |
| 3092 | 556 |
| 557 int | |
| 558 lrecord_stats_heap_size (void) | |
| 559 { | |
| 560 int i; | |
| 561 int size = 0; | |
| 3461 | 562 for (i = 0; i < countof (lrecord_implementations_table); i++) |
| 3092 | 563 size += lrecord_stats[i].bytes_in_use; |
| 564 return size; | |
| 565 } | |
| 3263 | 566 #endif /* NEW_GC && ALLOC_TYPE_STATS */ |
| 567 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
568 #define assert_proper_sizing(size) \ |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
569 type_checking_assert \ |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
570 (implementation->static_size == 0 ? \ |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
571 implementation->size_in_bytes_method != NULL : \ |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
572 implementation->size_in_bytes_method == NULL && \ |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
573 implementation->static_size == size) |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
574 |
| 3263 | 575 #ifndef NEW_GC |
| 442 | 576 /* lcrecords are chained together through their "next" field. |
| 577 After doing the mark phase, GC will walk this linked list | |
| 578 and free any lcrecord which hasn't been marked. */ | |
| 3024 | 579 static struct old_lcrecord_header *all_lcrecords; |
| 3263 | 580 #endif /* not NEW_GC */ |
| 581 | |
| 582 #ifdef NEW_GC | |
| 2720 | 583 /* The basic lrecord allocation functions. See lrecord.h for details. */ |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
584 static Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
585 alloc_sized_lrecord_1 (Bytecount size, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
586 const struct lrecord_implementation *implementation, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
587 int noseeum) |
| 2720 | 588 { |
| 589 struct lrecord_header *lheader; | |
| 590 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
591 assert_proper_sizing (size); |
| 2720 | 592 |
| 593 lheader = (struct lrecord_header *) mc_alloc (size); | |
| 594 gc_checking_assert (LRECORD_FREE_P (lheader)); | |
| 595 set_lheader_implementation (lheader, implementation); | |
| 2994 | 596 #ifdef ALLOC_TYPE_STATS |
| 2720 | 597 inc_lrecord_stats (size, lheader); |
| 2994 | 598 #endif /* ALLOC_TYPE_STATS */ |
| 3263 | 599 if (implementation->finalizer) |
| 600 add_finalizable_obj (wrap_pointer_1 (lheader)); | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
601 if (noseeum) |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
602 NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
603 else |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
604 INCREMENT_CONS_COUNTER (size, implementation->name); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
605 return wrap_pointer_1 (lheader); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
606 } |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
607 |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
608 Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
609 alloc_sized_lrecord (Bytecount size, |
| 3092 | 610 const struct lrecord_implementation *implementation) |
| 611 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
612 return alloc_sized_lrecord_1 (size, implementation, 0); |
| 2720 | 613 } |
| 614 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
615 Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
616 noseeum_alloc_sized_lrecord (Bytecount size, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
617 const struct lrecord_implementation * |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
618 implementation) |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
619 { |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
620 return alloc_sized_lrecord_1 (size, implementation, 1); |
| 2720 | 621 } |
| 622 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
623 Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
624 alloc_lrecord (const struct lrecord_implementation *implementation) |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
625 { |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
626 type_checking_assert (implementation->static_size > 0); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
627 return alloc_sized_lrecord (implementation->static_size, implementation); |
| 2720 | 628 } |
| 629 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
630 Lisp_Object |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
631 noseeum_alloc_lrecord (const struct lrecord_implementation *implementation) |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
632 { |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
633 type_checking_assert (implementation->static_size > 0); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
634 return noseeum_alloc_sized_lrecord (implementation->static_size, implementation); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
635 } |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
636 |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
637 Lisp_Object |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
638 alloc_sized_lrecord_array (Bytecount size, int elemcount, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
639 const struct lrecord_implementation *implementation) |
| 3092 | 640 { |
| 641 struct lrecord_header *lheader; | |
| 642 Rawbyte *start, *stop; | |
| 643 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
644 assert_proper_sizing (size); |
| 3092 | 645 |
| 646 lheader = (struct lrecord_header *) mc_alloc_array (size, elemcount); | |
| 647 gc_checking_assert (LRECORD_FREE_P (lheader)); | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
648 |
| 3092 | 649 for (start = (Rawbyte *) lheader, |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
650 /* #### FIXME: why is this -1 present? */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
651 stop = ((Rawbyte *) lheader) + (size * elemcount -1); |
| 3092 | 652 start < stop; start += size) |
| 653 { | |
| 654 struct lrecord_header *lh = (struct lrecord_header *) start; | |
| 655 set_lheader_implementation (lh, implementation); | |
| 656 #ifdef ALLOC_TYPE_STATS | |
| 657 inc_lrecord_stats (size, lh); | |
| 658 #endif /* not ALLOC_TYPE_STATS */ | |
| 3263 | 659 if (implementation->finalizer) |
| 660 add_finalizable_obj (wrap_pointer_1 (lh)); | |
| 3092 | 661 } |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
662 |
| 3092 | 663 INCREMENT_CONS_COUNTER (size * elemcount, implementation->name); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
664 return wrap_pointer_1 (lheader); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
665 } |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
666 |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
667 Lisp_Object |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
668 alloc_lrecord_array (int elemcount, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
669 const struct lrecord_implementation *implementation) |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
670 { |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
671 type_checking_assert (implementation->static_size > 0); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
672 return alloc_sized_lrecord_array (implementation->static_size, elemcount, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
673 implementation); |
| 3092 | 674 } |
| 675 | |
| 3263 | 676 #else /* not NEW_GC */ |
| 428 | 677 |
| 1204 | 678 /* The most basic of the lcrecord allocation functions. Not usually called |
| 679 directly. Allocates an lrecord not managed by any lcrecord-list, of a | |
| 680 specified size. See lrecord.h. */ | |
| 681 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
682 Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
683 old_alloc_sized_lcrecord (Bytecount size, |
| 3024 | 684 const struct lrecord_implementation *implementation) |
| 685 { | |
| 686 struct old_lcrecord_header *lcheader; | |
| 428 | 687 |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
688 assert_proper_sizing (size); |
| 442 | 689 type_checking_assert |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
690 (!implementation->frob_block_p |
| 442 | 691 && |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
692 !(implementation->hash == NULL && implementation->equal != NULL)); |
| 428 | 693 |
| 3024 | 694 lcheader = (struct old_lcrecord_header *) allocate_lisp_storage (size); |
| 442 | 695 set_lheader_implementation (&lcheader->lheader, implementation); |
| 428 | 696 lcheader->next = all_lcrecords; |
| 697 all_lcrecords = lcheader; | |
| 698 INCREMENT_CONS_COUNTER (size, implementation->name); | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
699 return wrap_pointer_1 (lcheader); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
700 } |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
701 |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
702 Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
703 old_alloc_lcrecord (const struct lrecord_implementation *implementation) |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
704 { |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
705 type_checking_assert (implementation->static_size > 0); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
706 return old_alloc_sized_lcrecord (implementation->static_size, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
707 implementation); |
| 428 | 708 } |
| 709 | |
| 710 #if 0 /* Presently unused */ | |
| 711 /* Very, very poor man's EGC? | |
| 712 * This may be slow and thrash pages all over the place. | |
| 713 * Only call it if you really feel you must (and if the | |
| 714 * lrecord was fairly recently allocated). | |
| 715 * Otherwise, just let the GC do its job -- that's what it's there for | |
| 716 */ | |
| 717 void | |
| 3024 | 718 very_old_free_lcrecord (struct old_lcrecord_header *lcrecord) |
| 428 | 719 { |
| 720 if (all_lcrecords == lcrecord) | |
| 721 { | |
| 722 all_lcrecords = lcrecord->next; | |
| 723 } | |
| 724 else | |
| 725 { | |
| 3024 | 726 struct old_lcrecord_header *header = all_lcrecords; |
| 428 | 727 for (;;) |
| 728 { | |
| 3024 | 729 struct old_lcrecord_header *next = header->next; |
| 428 | 730 if (next == lcrecord) |
| 731 { | |
| 732 header->next = lrecord->next; | |
| 733 break; | |
| 734 } | |
| 735 else if (next == 0) | |
| 2500 | 736 ABORT (); |
| 428 | 737 else |
| 738 header = next; | |
| 739 } | |
| 740 } | |
| 741 if (lrecord->implementation->finalizer) | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
742 lrecord->implementation->finalizer (wrap_pointer_1 (lrecord)); |
| 428 | 743 xfree (lrecord); |
| 744 return; | |
| 745 } | |
| 746 #endif /* Unused */ | |
| 3263 | 747 #endif /* not NEW_GC */ |
| 428 | 748 |
| 749 | |
| 750 static void | |
| 751 disksave_object_finalization_1 (void) | |
| 752 { | |
| 3263 | 753 #ifdef NEW_GC |
| 2720 | 754 mc_finalize_for_disksave (); |
| 3263 | 755 #else /* not NEW_GC */ |
| 3024 | 756 struct old_lcrecord_header *header; |
| 428 | 757 |
| 758 for (header = all_lcrecords; header; header = header->next) | |
| 759 { | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
760 struct lrecord_header *objh = &header->lheader; |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
761 const struct lrecord_implementation *imp = LHEADER_IMPLEMENTATION (objh); |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
762 #if 0 /* possibly useful for debugging */ |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
763 if (!RECORD_DUMPABLE (objh) && !objh->free) |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
764 { |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
765 stderr_out ("Disksaving a non-dumpable object: "); |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
766 debug_print (wrap_pointer_1 (header)); |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
767 } |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
768 #endif |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
769 if (imp->disksave && !objh->free) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
770 (imp->disksave) (wrap_pointer_1 (header)); |
| 428 | 771 } |
| 3263 | 772 #endif /* not NEW_GC */ |
| 428 | 773 } |
| 774 | |
| 1204 | 775 /* Bitwise copy all parts of a Lisp object other than the header */ |
| 776 | |
| 777 void | |
| 778 copy_lisp_object (Lisp_Object dst, Lisp_Object src) | |
| 779 { | |
| 780 const struct lrecord_implementation *imp = | |
| 781 XRECORD_LHEADER_IMPLEMENTATION (src); | |
| 782 Bytecount size = lisp_object_size (src); | |
| 783 | |
| 784 assert (imp == XRECORD_LHEADER_IMPLEMENTATION (dst)); | |
| 785 assert (size == lisp_object_size (dst)); | |
| 786 | |
| 3263 | 787 #ifdef NEW_GC |
| 2720 | 788 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), |
| 789 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), | |
| 790 size - sizeof (struct lrecord_header)); | |
| 3263 | 791 #else /* not NEW_GC */ |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
792 if (imp->frob_block_p) |
| 1204 | 793 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), |
| 794 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), | |
| 795 size - sizeof (struct lrecord_header)); | |
| 796 else | |
| 3024 | 797 memcpy ((char *) XRECORD_LHEADER (dst) + |
| 798 sizeof (struct old_lcrecord_header), | |
| 799 (char *) XRECORD_LHEADER (src) + | |
| 800 sizeof (struct old_lcrecord_header), | |
| 801 size - sizeof (struct old_lcrecord_header)); | |
| 3263 | 802 #endif /* not NEW_GC */ |
| 1204 | 803 } |
| 804 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
805 /* Zero out all parts of a Lisp object other than the header, for a |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
806 variable-sized object. The size needs to be given explicitly because |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
807 at the time this is called, the contents of the object may not be |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
808 defined, or may not be set up in such a way that we can reliably |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
809 retrieve the size, since it may depend on settings inside of the object. */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
810 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
811 void |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
812 zero_sized_lisp_object (Lisp_Object obj, Bytecount size) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
813 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
814 #ifndef NEW_GC |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
815 const struct lrecord_implementation *imp = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
816 XRECORD_LHEADER_IMPLEMENTATION (obj); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
817 #endif /* not NEW_GC */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
818 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
819 #ifdef NEW_GC |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
820 memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0, |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
821 size - sizeof (struct lrecord_header)); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
822 #else /* not NEW_GC */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
823 if (imp->frob_block_p) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
824 memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0, |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
825 size - sizeof (struct lrecord_header)); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
826 else |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
827 memset ((char *) XRECORD_LHEADER (obj) + |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
828 sizeof (struct old_lcrecord_header), 0, |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
829 size - sizeof (struct old_lcrecord_header)); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
830 #endif /* not NEW_GC */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
831 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
832 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
833 /* Zero out all parts of a Lisp object other than the header, for an object |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
834 that isn't variable-size. Objects that are variable-size need to use |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
835 zero_sized_lisp_object(). |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
836 */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
837 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
838 void |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
839 zero_nonsized_lisp_object (Lisp_Object obj) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
840 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
841 const struct lrecord_implementation *imp = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
842 XRECORD_LHEADER_IMPLEMENTATION (obj); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
843 assert (!imp->size_in_bytes_method); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
844 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
845 zero_sized_lisp_object (obj, lisp_object_size (obj)); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
846 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
847 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
848 #ifdef MEMORY_USAGE_STATS |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
849 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
850 Bytecount |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
851 lisp_object_storage_size (Lisp_Object obj, struct usage_stats *ustats) |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
852 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
853 #ifndef NEW_GC |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
854 const struct lrecord_implementation *imp = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
855 XRECORD_LHEADER_IMPLEMENTATION (obj); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
856 #endif /* not NEW_GC */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
857 Bytecount size = lisp_object_size (obj); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
858 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
859 #ifdef NEW_GC |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
860 return mc_alloced_storage_size (size, ustats); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
861 #else |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
862 if (imp->frob_block_p) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
863 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
864 Bytecount overhead = fixed_type_block_overhead (size); |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
865 if (ustats) |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
866 { |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
867 ustats->was_requested += size; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
868 ustats->malloc_overhead += overhead; |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
869 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
870 return size + overhead; |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
871 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
872 else |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
873 return malloced_storage_size (XPNTR (obj), size, ustats); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
874 #endif |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
875 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
876 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
877 #endif /* MEMORY_USAGE_STATS */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
878 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
879 void |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
880 free_normal_lisp_object (Lisp_Object obj) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
881 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
882 #ifndef NEW_GC |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
883 const struct lrecord_implementation *imp = |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
884 XRECORD_LHEADER_IMPLEMENTATION (obj); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
885 #endif /* not NEW_GC */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
886 |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
887 #ifdef NEW_GC |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
888 /* Manual frees are not allowed with asynchronous finalization */ |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
889 return; |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
890 #else |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
891 assert (!imp->frob_block_p); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
892 assert (!imp->size_in_bytes_method); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
893 old_free_lcrecord (obj); |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
894 #endif |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
895 } |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
896 |
| 428 | 897 |
| 898 /************************************************************************/ | |
| 899 /* Debugger support */ | |
| 900 /************************************************************************/ | |
| 901 /* Give gdb/dbx enough information to decode Lisp Objects. We make | |
| 902 sure certain symbols are always defined, so gdb doesn't complain | |
| 438 | 903 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc |
| 904 to see how this is used. */ | |
| 428 | 905 |
| 458 | 906 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS; |
| 907 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1; | |
| 428 | 908 |
| 909 #ifdef USE_UNION_TYPE | |
| 458 | 910 unsigned char dbg_USE_UNION_TYPE = 1; |
| 428 | 911 #else |
| 458 | 912 unsigned char dbg_USE_UNION_TYPE = 0; |
| 428 | 913 #endif |
| 914 | |
| 458 | 915 unsigned char dbg_valbits = VALBITS; |
| 916 unsigned char dbg_gctypebits = GCTYPEBITS; | |
| 917 | |
| 918 /* On some systems, the above definitions will be optimized away by | |
| 919 the compiler or linker unless they are referenced in some function. */ | |
| 920 long dbg_inhibit_dbg_symbol_deletion (void); | |
| 921 long | |
| 922 dbg_inhibit_dbg_symbol_deletion (void) | |
| 923 { | |
| 924 return | |
| 925 (dbg_valmask + | |
| 926 dbg_typemask + | |
| 927 dbg_USE_UNION_TYPE + | |
| 928 dbg_valbits + | |
| 929 dbg_gctypebits); | |
| 930 } | |
| 428 | 931 |
| 932 /* Macros turned into functions for ease of debugging. | |
| 933 Debuggers don't know about macros! */ | |
| 934 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2); | |
| 935 int | |
| 936 dbg_eq (Lisp_Object obj1, Lisp_Object obj2) | |
| 937 { | |
| 938 return EQ (obj1, obj2); | |
| 939 } | |
| 940 | |
| 941 | |
| 3263 | 942 #ifdef NEW_GC |
| 3017 | 943 #define DECLARE_FIXED_TYPE_ALLOC(type, structture) struct __foo__ |
| 944 #else | |
| 428 | 945 /************************************************************************/ |
| 946 /* Fixed-size type macros */ | |
| 947 /************************************************************************/ | |
| 948 | |
| 949 /* For fixed-size types that are commonly used, we malloc() large blocks | |
| 950 of memory at a time and subdivide them into chunks of the correct | |
| 951 size for an object of that type. This is more efficient than | |
| 952 malloc()ing each object separately because we save on malloc() time | |
| 953 and overhead due to the fewer number of malloc()ed blocks, and | |
| 954 also because we don't need any extra pointers within each object | |
| 955 to keep them threaded together for GC purposes. For less common | |
| 956 (and frequently large-size) types, we use lcrecords, which are | |
| 957 malloc()ed individually and chained together through a pointer | |
| 958 in the lcrecord header. lcrecords do not need to be fixed-size | |
| 959 (i.e. two objects of the same type need not have the same size; | |
| 960 however, the size of a particular object cannot vary dynamically). | |
| 961 It is also much easier to create a new lcrecord type because no | |
| 962 additional code needs to be added to alloc.c. Finally, lcrecords | |
| 963 may be more efficient when there are only a small number of them. | |
| 964 | |
| 965 The types that are stored in these large blocks (or "frob blocks") | |
| 1983 | 966 are cons, all number types except fixnum, compiled-function, symbol, |
| 967 marker, extent, event, and string. | |
| 428 | 968 |
| 969 Note that strings are special in that they are actually stored in | |
| 970 two parts: a structure containing information about the string, and | |
| 971 the actual data associated with the string. The former structure | |
| 972 (a struct Lisp_String) is a fixed-size structure and is managed the | |
| 973 same way as all the other such types. This structure contains a | |
| 974 pointer to the actual string data, which is stored in structures of | |
| 975 type struct string_chars_block. Each string_chars_block consists | |
| 976 of a pointer to a struct Lisp_String, followed by the data for that | |
| 440 | 977 string, followed by another pointer to a Lisp_String, followed by |
| 978 the data for that string, etc. At GC time, the data in these | |
| 979 blocks is compacted by searching sequentially through all the | |
| 428 | 980 blocks and compressing out any holes created by unmarked strings. |
| 981 Strings that are more than a certain size (bigger than the size of | |
| 982 a string_chars_block, although something like half as big might | |
| 983 make more sense) are malloc()ed separately and not stored in | |
| 984 string_chars_blocks. Furthermore, no one string stretches across | |
| 985 two string_chars_blocks. | |
| 986 | |
| 1204 | 987 Vectors are each malloc()ed separately as lcrecords. |
| 428 | 988 |
| 989 In the following discussion, we use conses, but it applies equally | |
| 990 well to the other fixed-size types. | |
| 991 | |
| 992 We store cons cells inside of cons_blocks, allocating a new | |
| 993 cons_block with malloc() whenever necessary. Cons cells reclaimed | |
| 994 by GC are put on a free list to be reallocated before allocating | |
| 995 any new cons cells from the latest cons_block. Each cons_block is | |
| 996 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least | |
| 997 the versions in malloc.c and gmalloc.c) really allocates in units | |
| 998 of powers of two and uses 4 bytes for its own overhead. | |
| 999 | |
| 1000 What GC actually does is to search through all the cons_blocks, | |
| 1001 from the most recently allocated to the oldest, and put all | |
| 1002 cons cells that are not marked (whether or not they're already | |
| 1003 free) on a cons_free_list. The cons_free_list is a stack, and | |
| 1004 so the cons cells in the oldest-allocated cons_block end up | |
| 1005 at the head of the stack and are the first to be reallocated. | |
| 1006 If any cons_block is entirely free, it is freed with free() | |
| 1007 and its cons cells removed from the cons_free_list. Because | |
| 1008 the cons_free_list ends up basically in memory order, we have | |
| 1009 a high locality of reference (assuming a reasonable turnover | |
| 1010 of allocating and freeing) and have a reasonable probability | |
| 1011 of entirely freeing up cons_blocks that have been more recently | |
| 1012 allocated. This stage is called the "sweep stage" of GC, and | |
| 1013 is executed after the "mark stage", which involves starting | |
| 1014 from all places that are known to point to in-use Lisp objects | |
| 1015 (e.g. the obarray, where are all symbols are stored; the | |
| 1016 current catches and condition-cases; the backtrace list of | |
| 1017 currently executing functions; the gcpro list; etc.) and | |
| 1018 recursively marking all objects that are accessible. | |
| 1019 | |
| 454 | 1020 At the beginning of the sweep stage, the conses in the cons blocks |
| 1021 are in one of three states: in use and marked, in use but not | |
| 1022 marked, and not in use (already freed). Any conses that are marked | |
| 1023 have been marked in the mark stage just executed, because as part | |
| 1024 of the sweep stage we unmark any marked objects. The way we tell | |
| 1025 whether or not a cons cell is in use is through the LRECORD_FREE_P | |
| 1026 macro. This uses a special lrecord type `lrecord_type_free', | |
| 1027 which is never associated with any valid object. | |
| 1028 | |
| 1029 Conses on the free_cons_list are threaded through a pointer stored | |
| 1030 in the conses themselves. Because the cons is still in a | |
| 1031 cons_block and needs to remain marked as not in use for the next | |
| 1032 time that GC happens, we need room to store both the "free" | |
| 1033 indicator and the chaining pointer. So this pointer is stored | |
| 1034 after the lrecord header (actually where C places a pointer after | |
| 1035 the lrecord header; they are not necessarily contiguous). This | |
| 1036 implies that all fixed-size types must be big enough to contain at | |
| 1037 least one pointer. This is true for all current fixed-size types, | |
| 1038 with the possible exception of Lisp_Floats, for which we define the | |
| 1039 meat of the struct using a union of a pointer and a double to | |
| 1040 ensure adequate space for the free list chain pointer. | |
| 428 | 1041 |
| 1042 Some types of objects need additional "finalization" done | |
| 1043 when an object is converted from in use to not in use; | |
| 1044 this is the purpose of the ADDITIONAL_FREE_type macro. | |
| 1045 For example, markers need to be removed from the chain | |
| 1046 of markers that is kept in each buffer. This is because | |
| 1047 markers in a buffer automatically disappear if the marker | |
| 1048 is no longer referenced anywhere (the same does not | |
| 1049 apply to extents, however). | |
| 1050 | |
| 1051 WARNING: Things are in an extremely bizarre state when | |
| 1052 the ADDITIONAL_FREE_type macros are called, so beware! | |
| 1053 | |
| 454 | 1054 When ERROR_CHECK_GC is defined, we do things differently so as to |
| 1055 maximize our chances of catching places where there is insufficient | |
| 1056 GCPROing. The thing we want to avoid is having an object that | |
| 1057 we're using but didn't GCPRO get freed by GC and then reallocated | |
| 1058 while we're in the process of using it -- this will result in | |
| 1059 something seemingly unrelated getting trashed, and is extremely | |
| 1060 difficult to track down. If the object gets freed but not | |
| 1061 reallocated, we can usually catch this because we set most of the | |
| 1062 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set | |
| 1063 to the invalid type `lrecord_type_free', however, and a pointer | |
| 1064 used to chain freed objects together is stored after the lrecord | |
| 1065 header; we play some tricks with this pointer to make it more | |
| 428 | 1066 bogus, so crashes are more likely to occur right away.) |
| 1067 | |
| 1068 We want freed objects to stay free as long as possible, | |
| 1069 so instead of doing what we do above, we maintain the | |
| 1070 free objects in a first-in first-out queue. We also | |
| 1071 don't recompute the free list each GC, unlike above; | |
| 1072 this ensures that the queue ordering is preserved. | |
| 1073 [This means that we are likely to have worse locality | |
| 1074 of reference, and that we can never free a frob block | |
| 1075 once it's allocated. (Even if we know that all cells | |
| 1076 in it are free, there's no easy way to remove all those | |
| 1077 cells from the free list because the objects on the | |
| 1078 free list are unlikely to be in memory order.)] | |
| 1079 Furthermore, we never take objects off the free list | |
| 1080 unless there's a large number (usually 1000, but | |
| 1081 varies depending on type) of them already on the list. | |
| 1082 This way, we ensure that an object that gets freed will | |
| 1083 remain free for the next 1000 (or whatever) times that | |
| 440 | 1084 an object of that type is allocated. */ |
| 428 | 1085 |
| 1086 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) | |
| 1087 /* If we released our reserve (due to running out of memory), | |
| 1088 and we have a fair amount free once again, | |
| 1089 try to set aside another reserve in case we run out once more. | |
| 1090 | |
| 1091 This is called when a relocatable block is freed in ralloc.c. */ | |
| 1092 void refill_memory_reserve (void); | |
| 1093 void | |
| 442 | 1094 refill_memory_reserve (void) |
| 428 | 1095 { |
| 1096 if (breathing_space == 0) | |
| 1097 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD); | |
| 1098 } | |
| 1099 #endif | |
| 1100 | |
| 1101 #ifdef ALLOC_NO_POOLS | |
| 1102 # define TYPE_ALLOC_SIZE(type, structtype) 1 | |
| 1103 #else | |
| 1104 # define TYPE_ALLOC_SIZE(type, structtype) \ | |
| 1105 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \ | |
| 1106 / sizeof (structtype)) | |
| 1107 #endif /* ALLOC_NO_POOLS */ | |
| 1108 | |
| 1109 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ | |
| 1110 \ | |
| 1111 struct type##_block \ | |
| 1112 { \ | |
| 1113 struct type##_block *prev; \ | |
| 1114 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ | |
| 1115 }; \ | |
| 1116 \ | |
| 1117 static struct type##_block *current_##type##_block; \ | |
| 1118 static int current_##type##_block_index; \ | |
| 1119 \ | |
| 454 | 1120 static Lisp_Free *type##_free_list; \ |
| 1121 static Lisp_Free *type##_free_list_tail; \ | |
| 428 | 1122 \ |
| 1123 static void \ | |
| 1124 init_##type##_alloc (void) \ | |
| 1125 { \ | |
| 1126 current_##type##_block = 0; \ | |
| 1127 current_##type##_block_index = \ | |
| 1128 countof (current_##type##_block->block); \ | |
| 1129 type##_free_list = 0; \ | |
| 1130 type##_free_list_tail = 0; \ | |
| 1131 } \ | |
| 1132 \ | |
| 1133 static int gc_count_num_##type##_in_use; \ | |
| 1134 static int gc_count_num_##type##_freelist | |
| 1135 | |
| 1136 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \ | |
| 1137 if (current_##type##_block_index \ | |
| 1138 == countof (current_##type##_block->block)) \ | |
| 1139 { \ | |
| 1140 struct type##_block *AFTFB_new = (struct type##_block *) \ | |
| 1141 allocate_lisp_storage (sizeof (struct type##_block)); \ | |
| 1142 AFTFB_new->prev = current_##type##_block; \ | |
| 1143 current_##type##_block = AFTFB_new; \ | |
| 1144 current_##type##_block_index = 0; \ | |
| 1145 } \ | |
| 1146 (result) = \ | |
| 1147 &(current_##type##_block->block[current_##type##_block_index++]); \ | |
| 1148 } while (0) | |
| 1149 | |
| 1150 /* Allocate an instance of a type that is stored in blocks. | |
| 1151 TYPE is the "name" of the type, STRUCTTYPE is the corresponding | |
| 1152 structure type. */ | |
| 1153 | |
| 1154 #ifdef ERROR_CHECK_GC | |
| 1155 | |
| 1156 /* Note: if you get crashes in this function, suspect incorrect calls | |
| 1157 to free_cons() and friends. This happened once because the cons | |
| 1158 cell was not GC-protected and was getting collected before | |
| 1159 free_cons() was called. */ | |
| 1160 | |
| 454 | 1161 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
| 1162 if (gc_count_num_##type##_freelist > \ | |
| 1163 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \ | |
| 1164 { \ | |
| 1165 result = (structtype *) type##_free_list; \ | |
| 1204 | 1166 assert (LRECORD_FREE_P (result)); \ |
| 1167 /* Before actually using the chain pointer, we complement \ | |
| 1168 all its bits; see PUT_FIXED_TYPE_ON_FREE_LIST(). */ \ | |
| 454 | 1169 type##_free_list = (Lisp_Free *) \ |
| 1170 (~ (EMACS_UINT) (type##_free_list->chain)); \ | |
| 1171 gc_count_num_##type##_freelist--; \ | |
| 1172 } \ | |
| 1173 else \ | |
| 1174 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
| 1175 MARK_LRECORD_AS_NOT_FREE (result); \ | |
| 428 | 1176 } while (0) |
| 1177 | |
| 1178 #else /* !ERROR_CHECK_GC */ | |
| 1179 | |
| 454 | 1180 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
| 428 | 1181 if (type##_free_list) \ |
| 1182 { \ | |
| 454 | 1183 result = (structtype *) type##_free_list; \ |
| 1184 type##_free_list = type##_free_list->chain; \ | |
| 428 | 1185 } \ |
| 1186 else \ | |
| 1187 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
| 454 | 1188 MARK_LRECORD_AS_NOT_FREE (result); \ |
| 428 | 1189 } while (0) |
| 1190 | |
| 1191 #endif /* !ERROR_CHECK_GC */ | |
| 1192 | |
| 454 | 1193 |
| 428 | 1194 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \ |
| 1195 do \ | |
| 1196 { \ | |
| 1197 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
| 1198 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
| 1199 } while (0) | |
| 1200 | |
| 1201 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \ | |
| 1202 do \ | |
| 1203 { \ | |
| 1204 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
| 1205 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
| 1206 } while (0) | |
| 1207 | |
| 454 | 1208 /* Lisp_Free is the type to represent a free list member inside a frob |
| 1209 block of any lisp object type. */ | |
| 1210 typedef struct Lisp_Free | |
| 1211 { | |
| 1212 struct lrecord_header lheader; | |
| 1213 struct Lisp_Free *chain; | |
| 1214 } Lisp_Free; | |
| 1215 | |
| 1216 #define LRECORD_FREE_P(ptr) \ | |
| 771 | 1217 (((struct lrecord_header *) ptr)->type == lrecord_type_free) |
| 454 | 1218 |
| 1219 #define MARK_LRECORD_AS_FREE(ptr) \ | |
| 771 | 1220 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free)) |
| 454 | 1221 |
| 1222 #ifdef ERROR_CHECK_GC | |
| 1223 #define MARK_LRECORD_AS_NOT_FREE(ptr) \ | |
| 771 | 1224 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined)) |
| 428 | 1225 #else |
| 454 | 1226 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING |
| 428 | 1227 #endif |
| 1228 | |
| 1229 #ifdef ERROR_CHECK_GC | |
| 1230 | |
| 454 | 1231 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
| 1232 if (type##_free_list_tail) \ | |
| 1233 { \ | |
| 1234 /* When we store the chain pointer, we complement all \ | |
| 1235 its bits; this should significantly increase its \ | |
| 1236 bogosity in case someone tries to use the value, and \ | |
| 1237 should make us crash faster if someone overwrites the \ | |
| 1238 pointer because when it gets un-complemented in \ | |
| 1239 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \ | |
| 1240 extremely bogus. */ \ | |
| 1241 type##_free_list_tail->chain = \ | |
| 1242 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \ | |
| 1243 } \ | |
| 1244 else \ | |
| 1245 type##_free_list = (Lisp_Free *) (ptr); \ | |
| 1246 type##_free_list_tail = (Lisp_Free *) (ptr); \ | |
| 1247 } while (0) | |
| 428 | 1248 |
| 1249 #else /* !ERROR_CHECK_GC */ | |
| 1250 | |
| 454 | 1251 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
| 1252 ((Lisp_Free *) (ptr))->chain = type##_free_list; \ | |
| 1253 type##_free_list = (Lisp_Free *) (ptr); \ | |
| 1254 } while (0) \ | |
| 428 | 1255 |
| 1256 #endif /* !ERROR_CHECK_GC */ | |
| 1257 | |
| 1258 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */ | |
| 1259 | |
| 1260 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \ | |
| 1261 structtype *FFT_ptr = (ptr); \ | |
| 1204 | 1262 gc_checking_assert (!LRECORD_FREE_P (FFT_ptr)); \ |
| 2367 | 1263 gc_checking_assert (!DUMPEDP (FFT_ptr)); \ |
| 428 | 1264 ADDITIONAL_FREE_##type (FFT_ptr); \ |
| 1265 deadbeef_memory (FFT_ptr, sizeof (structtype)); \ | |
| 1266 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \ | |
| 454 | 1267 MARK_LRECORD_AS_FREE (FFT_ptr); \ |
| 428 | 1268 } while (0) |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1269 #endif /* NEW_GC */ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1270 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1271 #ifdef NEW_GC |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1272 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) \ |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1273 free_normal_lisp_object (lo) |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1274 #else /* not NEW_GC */ |
| 428 | 1275 /* Like FREE_FIXED_TYPE() but used when we are explicitly |
| 1276 freeing a structure through free_cons(), free_marker(), etc. | |
| 1277 rather than through the normal process of sweeping. | |
| 1278 We attempt to undo the changes made to the allocation counters | |
| 1279 as a result of this structure being allocated. This is not | |
| 1280 completely necessary but helps keep things saner: e.g. this way, | |
| 1281 repeatedly allocating and freeing a cons will not result in | |
| 1282 the consing-since-gc counter advancing, which would cause a GC | |
| 1204 | 1283 and somewhat defeat the purpose of explicitly freeing. |
| 1284 | |
| 1285 We also disable this mechanism entirely when ALLOC_NO_POOLS is | |
| 1286 set, which is used for Purify and the like. */ | |
| 1287 | |
| 1288 #ifndef ALLOC_NO_POOLS | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1289 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1290 do { FREE_FIXED_TYPE (type, structtype, ptr); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1291 DECREMENT_CONS_COUNTER (sizeof (structtype)); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1292 gc_count_num_##type##_freelist++; \ |
| 428 | 1293 } while (0) |
| 1204 | 1294 #else |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1295 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) |
| 1204 | 1296 #endif |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1297 #endif /* (not) NEW_GC */ |
| 3263 | 1298 |
| 1299 #ifdef NEW_GC | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1300 #define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr)\ |
| 3017 | 1301 do { \ |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1302 (var) = (lisp_type *) XPNTR (ALLOC_NORMAL_LISP_OBJECT (type)); \ |
| 3017 | 1303 } while (0) |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1304 #define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ |
| 3017 | 1305 lrec_ptr) \ |
| 1306 do { \ | |
|
5120
d1247f3cc363
latest work on lisp-object workspace;
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1307 (var) = (lisp_type *) XPNTR (noseeum_alloc_lrecord (lrec_ptr)); \ |
| 3017 | 1308 } while (0) |
| 3263 | 1309 #else /* not NEW_GC */ |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1310 #define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \ |
| 3017 | 1311 do \ |
| 1312 { \ | |
| 1313 ALLOCATE_FIXED_TYPE (type, lisp_type, var); \ | |
| 1314 set_lheader_implementation (&(var)->lheader, lrec_ptr); \ | |
| 1315 } while (0) | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1316 #define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ |
| 3017 | 1317 lrec_ptr) \ |
| 1318 do \ | |
| 1319 { \ | |
| 1320 NOSEEUM_ALLOCATE_FIXED_TYPE (type, lisp_type, var); \ | |
| 1321 set_lheader_implementation (&(var)->lheader, lrec_ptr); \ | |
| 1322 } while (0) | |
| 3263 | 1323 #endif /* not NEW_GC */ |
| 3017 | 1324 |
| 428 | 1325 |
| 1326 | |
| 1327 /************************************************************************/ | |
| 1328 /* Cons allocation */ | |
| 1329 /************************************************************************/ | |
| 1330 | |
| 440 | 1331 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons); |
| 428 | 1332 /* conses are used and freed so often that we set this really high */ |
| 1333 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ | |
| 1334 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 | |
| 1335 | |
| 1336 static Lisp_Object | |
| 1337 mark_cons (Lisp_Object obj) | |
| 1338 { | |
| 1339 if (NILP (XCDR (obj))) | |
| 1340 return XCAR (obj); | |
| 1341 | |
| 1342 mark_object (XCAR (obj)); | |
| 1343 return XCDR (obj); | |
| 1344 } | |
| 1345 | |
| 1346 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1347 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth, int foldcase) |
| 428 | 1348 { |
| 442 | 1349 depth++; |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1350 while (internal_equal_0 (XCAR (ob1), XCAR (ob2), depth, foldcase)) |
| 428 | 1351 { |
| 1352 ob1 = XCDR (ob1); | |
| 1353 ob2 = XCDR (ob2); | |
| 1354 if (! CONSP (ob1) || ! CONSP (ob2)) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1355 return internal_equal_0 (ob1, ob2, depth, foldcase); |
| 428 | 1356 } |
| 1357 return 0; | |
| 1358 } | |
| 1359 | |
| 1204 | 1360 static const struct memory_description cons_description[] = { |
| 853 | 1361 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) }, |
| 1362 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) }, | |
| 428 | 1363 { XD_END } |
| 1364 }; | |
| 1365 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1366 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("cons", cons, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1367 mark_cons, print_cons, 0, cons_equal, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1368 /* |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1369 * No `hash' method needed. |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1370 * internal_hash knows how to |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1371 * handle conses. |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1372 */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1373 0, cons_description, Lisp_Cons); |
| 428 | 1374 |
| 1375 DEFUN ("cons", Fcons, 2, 2, 0, /* | |
| 3355 | 1376 Create a new cons cell, give it CAR and CDR as components, and return it. |
| 1377 | |
| 1378 A cons cell is a Lisp object (an area in memory) made up of two pointers | |
| 1379 called the CAR and the CDR. Each of these pointers can point to any other | |
| 1380 Lisp object. The common Lisp data type, the list, is a specially-structured | |
| 1381 series of cons cells. | |
| 1382 | |
| 1383 The pointers are accessed from Lisp with `car' and `cdr', and mutated with | |
| 1384 `setcar' and `setcdr' respectively. For historical reasons, the aliases | |
| 1385 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported. | |
| 428 | 1386 */ |
| 1387 (car, cdr)) | |
| 1388 { | |
| 1389 /* This cannot GC. */ | |
| 1390 Lisp_Object val; | |
| 440 | 1391 Lisp_Cons *c; |
| 1392 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1393 ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons); |
| 793 | 1394 val = wrap_cons (c); |
| 853 | 1395 XSETCAR (val, car); |
| 1396 XSETCDR (val, cdr); | |
| 428 | 1397 return val; |
| 1398 } | |
| 1399 | |
| 1400 /* This is identical to Fcons() but it used for conses that we're | |
| 1401 going to free later, and is useful when trying to track down | |
| 1402 "real" consing. */ | |
| 1403 Lisp_Object | |
| 1404 noseeum_cons (Lisp_Object car, Lisp_Object cdr) | |
| 1405 { | |
| 1406 Lisp_Object val; | |
| 440 | 1407 Lisp_Cons *c; |
| 1408 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1409 NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons); |
| 793 | 1410 val = wrap_cons (c); |
| 428 | 1411 XCAR (val) = car; |
| 1412 XCDR (val) = cdr; | |
| 1413 return val; | |
| 1414 } | |
| 1415 | |
| 1416 DEFUN ("list", Flist, 0, MANY, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1417 Return a newly created list with specified ARGS as elements. |
| 428 | 1418 Any number of arguments, even zero arguments, are allowed. |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1419 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1420 arguments: (&rest ARGS) |
| 428 | 1421 */ |
| 1422 (int nargs, Lisp_Object *args)) | |
| 1423 { | |
| 1424 Lisp_Object val = Qnil; | |
| 1425 Lisp_Object *argp = args + nargs; | |
| 1426 | |
| 1427 while (argp > args) | |
| 1428 val = Fcons (*--argp, val); | |
| 1429 return val; | |
| 1430 } | |
| 1431 | |
| 1432 Lisp_Object | |
| 1433 list1 (Lisp_Object obj0) | |
| 1434 { | |
| 1435 /* This cannot GC. */ | |
| 1436 return Fcons (obj0, Qnil); | |
| 1437 } | |
| 1438 | |
| 1439 Lisp_Object | |
| 1440 list2 (Lisp_Object obj0, Lisp_Object obj1) | |
| 1441 { | |
| 1442 /* This cannot GC. */ | |
| 1443 return Fcons (obj0, Fcons (obj1, Qnil)); | |
| 1444 } | |
| 1445 | |
| 1446 Lisp_Object | |
| 1447 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1448 { | |
| 1449 /* This cannot GC. */ | |
| 1450 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil))); | |
| 1451 } | |
| 1452 | |
| 1453 Lisp_Object | |
| 1454 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1455 { | |
| 1456 /* This cannot GC. */ | |
| 1457 return Fcons (obj0, Fcons (obj1, obj2)); | |
| 1458 } | |
| 1459 | |
| 1460 Lisp_Object | |
| 1461 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist) | |
| 1462 { | |
| 1463 return Fcons (Fcons (key, value), alist); | |
| 1464 } | |
| 1465 | |
| 1466 Lisp_Object | |
| 1467 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3) | |
| 1468 { | |
| 1469 /* This cannot GC. */ | |
| 1470 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil)))); | |
| 1471 } | |
| 1472 | |
| 1473 Lisp_Object | |
| 1474 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
| 1475 Lisp_Object obj4) | |
| 1476 { | |
| 1477 /* This cannot GC. */ | |
| 1478 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil))))); | |
| 1479 } | |
| 1480 | |
| 1481 Lisp_Object | |
| 1482 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
| 1483 Lisp_Object obj4, Lisp_Object obj5) | |
| 1484 { | |
| 1485 /* This cannot GC. */ | |
| 1486 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil)))))); | |
| 1487 } | |
| 1488 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1489 /* Return a list of arbitrary length, terminated by Qunbound. */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1490 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1491 Lisp_Object |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1492 listu (Lisp_Object first, ...) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1493 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1494 Lisp_Object obj = Qnil; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1495 Lisp_Object val; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1496 va_list va; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1497 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1498 va_start (va, first); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1499 val = first; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1500 while (!UNBOUNDP (val)) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1501 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1502 obj = Fcons (val, obj); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1503 val = va_arg (va, Lisp_Object); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1504 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1505 va_end (va); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1506 return Fnreverse (obj); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1507 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1508 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1509 /* Return a list of arbitrary length, with length specified and remaining |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1510 args making up the list. */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1511 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1512 Lisp_Object |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1513 listn (int num_args, ...) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1514 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1515 int i; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1516 Lisp_Object obj = Qnil; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1517 va_list va; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1518 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1519 va_start (va, num_args); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1520 for (i = 0; i < num_args; i++) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1521 obj = Fcons (va_arg (va, Lisp_Object), obj); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1522 va_end (va); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1523 return Fnreverse (obj); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1524 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1525 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1526 /* Return a list of arbitrary length, with length specified and an array |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1527 of elements. */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1528 |
| 428 | 1529 DEFUN ("make-list", Fmake_list, 2, 2, 0, /* |
| 444 | 1530 Return a new list of length LENGTH, with each element being OBJECT. |
| 428 | 1531 */ |
| 444 | 1532 (length, object)) |
| 428 | 1533 { |
| 1534 CHECK_NATNUM (length); | |
| 1535 | |
| 1536 { | |
| 1537 Lisp_Object val = Qnil; | |
| 647 | 1538 EMACS_INT size = XINT (length); |
| 428 | 1539 |
| 1540 while (size--) | |
| 444 | 1541 val = Fcons (object, val); |
| 428 | 1542 return val; |
| 1543 } | |
| 1544 } | |
| 1545 | |
| 1546 | |
| 1547 /************************************************************************/ | |
| 1548 /* Float allocation */ | |
| 1549 /************************************************************************/ | |
| 1550 | |
| 1983 | 1551 /*** With enhanced number support, these are short floats */ |
| 1552 | |
| 440 | 1553 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float); |
| 428 | 1554 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 |
| 1555 | |
| 1556 Lisp_Object | |
| 1557 make_float (double float_value) | |
| 1558 { | |
| 440 | 1559 Lisp_Float *f; |
| 1560 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1561 ALLOC_FROB_BLOCK_LISP_OBJECT (float, Lisp_Float, f, &lrecord_float); |
| 440 | 1562 |
| 1563 /* Avoid dump-time `uninitialized memory read' purify warnings. */ | |
| 1564 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1565 zero_nonsized_lisp_object (wrap_float (f)); |
| 3017 | 1566 |
| 428 | 1567 float_data (f) = float_value; |
| 793 | 1568 return wrap_float (f); |
| 428 | 1569 } |
| 1570 | |
| 1571 | |
| 1572 /************************************************************************/ | |
| 1983 | 1573 /* Enhanced number allocation */ |
| 1574 /************************************************************************/ | |
| 1575 | |
| 1576 /*** Bignum ***/ | |
| 1577 #ifdef HAVE_BIGNUM | |
| 1578 DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum); | |
| 1579 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250 | |
| 1580 | |
| 1581 /* WARNING: This function returns a bignum even if its argument fits into a | |
| 1582 fixnum. See Fcanonicalize_number(). */ | |
| 1583 Lisp_Object | |
| 1584 make_bignum (long bignum_value) | |
| 1585 { | |
| 1586 Lisp_Bignum *b; | |
| 1587 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1588 ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum); |
| 1983 | 1589 bignum_init (bignum_data (b)); |
| 1590 bignum_set_long (bignum_data (b), bignum_value); | |
| 1591 return wrap_bignum (b); | |
| 1592 } | |
| 1593 | |
| 1594 /* WARNING: This function returns a bignum even if its argument fits into a | |
| 1595 fixnum. See Fcanonicalize_number(). */ | |
| 1596 Lisp_Object | |
| 1597 make_bignum_bg (bignum bg) | |
| 1598 { | |
| 1599 Lisp_Bignum *b; | |
| 1600 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1601 ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum); |
| 1983 | 1602 bignum_init (bignum_data (b)); |
| 1603 bignum_set (bignum_data (b), bg); | |
| 1604 return wrap_bignum (b); | |
| 1605 } | |
| 1606 #endif /* HAVE_BIGNUM */ | |
| 1607 | |
| 1608 /*** Ratio ***/ | |
| 1609 #ifdef HAVE_RATIO | |
| 1610 DECLARE_FIXED_TYPE_ALLOC (ratio, Lisp_Ratio); | |
| 1611 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_ratio 250 | |
| 1612 | |
| 1613 Lisp_Object | |
| 1614 make_ratio (long numerator, unsigned long denominator) | |
| 1615 { | |
| 1616 Lisp_Ratio *r; | |
| 1617 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1618 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); |
| 1983 | 1619 ratio_init (ratio_data (r)); |
| 1620 ratio_set_long_ulong (ratio_data (r), numerator, denominator); | |
| 1621 ratio_canonicalize (ratio_data (r)); | |
| 1622 return wrap_ratio (r); | |
| 1623 } | |
| 1624 | |
| 1625 Lisp_Object | |
| 1626 make_ratio_bg (bignum numerator, bignum denominator) | |
| 1627 { | |
| 1628 Lisp_Ratio *r; | |
| 1629 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1630 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); |
| 1983 | 1631 ratio_init (ratio_data (r)); |
| 1632 ratio_set_bignum_bignum (ratio_data (r), numerator, denominator); | |
| 1633 ratio_canonicalize (ratio_data (r)); | |
| 1634 return wrap_ratio (r); | |
| 1635 } | |
| 1636 | |
| 1637 Lisp_Object | |
| 1638 make_ratio_rt (ratio rat) | |
| 1639 { | |
| 1640 Lisp_Ratio *r; | |
| 1641 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1642 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); |
| 1983 | 1643 ratio_init (ratio_data (r)); |
| 1644 ratio_set (ratio_data (r), rat); | |
| 1645 return wrap_ratio (r); | |
| 1646 } | |
| 1647 #endif /* HAVE_RATIO */ | |
| 1648 | |
| 1649 /*** Bigfloat ***/ | |
| 1650 #ifdef HAVE_BIGFLOAT | |
| 1651 DECLARE_FIXED_TYPE_ALLOC (bigfloat, Lisp_Bigfloat); | |
| 1652 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfloat 250 | |
| 1653 | |
| 1654 /* This function creates a bigfloat with the default precision if the | |
| 1655 PRECISION argument is zero. */ | |
| 1656 Lisp_Object | |
| 1657 make_bigfloat (double float_value, unsigned long precision) | |
| 1658 { | |
| 1659 Lisp_Bigfloat *f; | |
| 1660 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1661 ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); |
| 1983 | 1662 if (precision == 0UL) |
| 1663 bigfloat_init (bigfloat_data (f)); | |
| 1664 else | |
| 1665 bigfloat_init_prec (bigfloat_data (f), precision); | |
| 1666 bigfloat_set_double (bigfloat_data (f), float_value); | |
| 1667 return wrap_bigfloat (f); | |
| 1668 } | |
| 1669 | |
| 1670 /* This function creates a bigfloat with the precision of its argument */ | |
| 1671 Lisp_Object | |
| 1672 make_bigfloat_bf (bigfloat float_value) | |
| 1673 { | |
| 1674 Lisp_Bigfloat *f; | |
| 1675 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1676 ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); |
| 1983 | 1677 bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value)); |
| 1678 bigfloat_set (bigfloat_data (f), float_value); | |
| 1679 return wrap_bigfloat (f); | |
| 1680 } | |
| 1681 #endif /* HAVE_BIGFLOAT */ | |
| 1682 | |
| 1683 /************************************************************************/ | |
| 428 | 1684 /* Vector allocation */ |
| 1685 /************************************************************************/ | |
| 1686 | |
| 1687 static Lisp_Object | |
| 1688 mark_vector (Lisp_Object obj) | |
| 1689 { | |
| 1690 Lisp_Vector *ptr = XVECTOR (obj); | |
| 1691 int len = vector_length (ptr); | |
| 1692 int i; | |
| 1693 | |
| 1694 for (i = 0; i < len - 1; i++) | |
| 1695 mark_object (ptr->contents[i]); | |
| 1696 return (len > 0) ? ptr->contents[len - 1] : Qnil; | |
| 1697 } | |
| 1698 | |
| 665 | 1699 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1700 size_vector (Lisp_Object obj) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1701 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1702 |
| 456 | 1703 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents, |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1704 XVECTOR (obj)->size); |
| 428 | 1705 } |
| 1706 | |
| 1707 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1708 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 428 | 1709 { |
| 1710 int len = XVECTOR_LENGTH (obj1); | |
| 1711 if (len != XVECTOR_LENGTH (obj2)) | |
| 1712 return 0; | |
| 1713 | |
| 1714 { | |
| 1715 Lisp_Object *ptr1 = XVECTOR_DATA (obj1); | |
| 1716 Lisp_Object *ptr2 = XVECTOR_DATA (obj2); | |
| 1717 while (len--) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1718 if (!internal_equal_0 (*ptr1++, *ptr2++, depth + 1, foldcase)) |
| 428 | 1719 return 0; |
| 1720 } | |
| 1721 return 1; | |
| 1722 } | |
| 1723 | |
| 665 | 1724 static Hashcode |
| 442 | 1725 vector_hash (Lisp_Object obj, int depth) |
| 1726 { | |
| 1727 return HASH2 (XVECTOR_LENGTH (obj), | |
| 1728 internal_array_hash (XVECTOR_DATA (obj), | |
| 1729 XVECTOR_LENGTH (obj), | |
| 1730 depth + 1)); | |
| 1731 } | |
| 1732 | |
| 1204 | 1733 static const struct memory_description vector_description[] = { |
| 440 | 1734 { XD_LONG, offsetof (Lisp_Vector, size) }, |
| 1735 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) }, | |
| 428 | 1736 { XD_END } |
| 1737 }; | |
| 1738 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1739 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("vector", vector, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1740 mark_vector, print_vector, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1741 vector_equal, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1742 vector_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1743 vector_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1744 size_vector, Lisp_Vector); |
| 428 | 1745 /* #### should allocate `small' vectors from a frob-block */ |
| 1746 static Lisp_Vector * | |
| 665 | 1747 make_vector_internal (Elemcount sizei) |
| 428 | 1748 { |
| 1204 | 1749 /* no `next' field; we use lcrecords */ |
| 665 | 1750 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, |
| 1204 | 1751 contents, sizei); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1752 Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, vector); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1753 Lisp_Vector *p = XVECTOR (obj); |
| 428 | 1754 |
| 1755 p->size = sizei; | |
| 1756 return p; | |
| 1757 } | |
| 1758 | |
| 1759 Lisp_Object | |
| 665 | 1760 make_vector (Elemcount length, Lisp_Object object) |
| 428 | 1761 { |
| 1762 Lisp_Vector *vecp = make_vector_internal (length); | |
| 1763 Lisp_Object *p = vector_data (vecp); | |
| 1764 | |
| 1765 while (length--) | |
| 444 | 1766 *p++ = object; |
| 428 | 1767 |
| 793 | 1768 return wrap_vector (vecp); |
| 428 | 1769 } |
| 1770 | |
| 1771 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /* | |
| 444 | 1772 Return a new vector of length LENGTH, with each element being OBJECT. |
| 428 | 1773 See also the function `vector'. |
| 1774 */ | |
| 444 | 1775 (length, object)) |
| 428 | 1776 { |
| 1777 CONCHECK_NATNUM (length); | |
| 444 | 1778 return make_vector (XINT (length), object); |
| 428 | 1779 } |
| 1780 | |
| 1781 DEFUN ("vector", Fvector, 0, MANY, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1782 Return a newly created vector with specified ARGS as elements. |
| 428 | 1783 Any number of arguments, even zero arguments, are allowed. |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1784 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1785 arguments: (&rest ARGS) |
| 428 | 1786 */ |
| 1787 (int nargs, Lisp_Object *args)) | |
| 1788 { | |
| 1789 Lisp_Vector *vecp = make_vector_internal (nargs); | |
| 1790 Lisp_Object *p = vector_data (vecp); | |
| 1791 | |
| 1792 while (nargs--) | |
| 1793 *p++ = *args++; | |
| 1794 | |
| 793 | 1795 return wrap_vector (vecp); |
| 428 | 1796 } |
| 1797 | |
| 1798 Lisp_Object | |
| 1799 vector1 (Lisp_Object obj0) | |
| 1800 { | |
| 1801 return Fvector (1, &obj0); | |
| 1802 } | |
| 1803 | |
| 1804 Lisp_Object | |
| 1805 vector2 (Lisp_Object obj0, Lisp_Object obj1) | |
| 1806 { | |
| 1807 Lisp_Object args[2]; | |
| 1808 args[0] = obj0; | |
| 1809 args[1] = obj1; | |
| 1810 return Fvector (2, args); | |
| 1811 } | |
| 1812 | |
| 1813 Lisp_Object | |
| 1814 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1815 { | |
| 1816 Lisp_Object args[3]; | |
| 1817 args[0] = obj0; | |
| 1818 args[1] = obj1; | |
| 1819 args[2] = obj2; | |
| 1820 return Fvector (3, args); | |
| 1821 } | |
| 1822 | |
| 1823 #if 0 /* currently unused */ | |
| 1824 | |
| 1825 Lisp_Object | |
| 1826 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1827 Lisp_Object obj3) | |
| 1828 { | |
| 1829 Lisp_Object args[4]; | |
| 1830 args[0] = obj0; | |
| 1831 args[1] = obj1; | |
| 1832 args[2] = obj2; | |
| 1833 args[3] = obj3; | |
| 1834 return Fvector (4, args); | |
| 1835 } | |
| 1836 | |
| 1837 Lisp_Object | |
| 1838 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1839 Lisp_Object obj3, Lisp_Object obj4) | |
| 1840 { | |
| 1841 Lisp_Object args[5]; | |
| 1842 args[0] = obj0; | |
| 1843 args[1] = obj1; | |
| 1844 args[2] = obj2; | |
| 1845 args[3] = obj3; | |
| 1846 args[4] = obj4; | |
| 1847 return Fvector (5, args); | |
| 1848 } | |
| 1849 | |
| 1850 Lisp_Object | |
| 1851 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1852 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5) | |
| 1853 { | |
| 1854 Lisp_Object args[6]; | |
| 1855 args[0] = obj0; | |
| 1856 args[1] = obj1; | |
| 1857 args[2] = obj2; | |
| 1858 args[3] = obj3; | |
| 1859 args[4] = obj4; | |
| 1860 args[5] = obj5; | |
| 1861 return Fvector (6, args); | |
| 1862 } | |
| 1863 | |
| 1864 Lisp_Object | |
| 1865 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1866 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
| 1867 Lisp_Object obj6) | |
| 1868 { | |
| 1869 Lisp_Object args[7]; | |
| 1870 args[0] = obj0; | |
| 1871 args[1] = obj1; | |
| 1872 args[2] = obj2; | |
| 1873 args[3] = obj3; | |
| 1874 args[4] = obj4; | |
| 1875 args[5] = obj5; | |
| 1876 args[6] = obj6; | |
| 1877 return Fvector (7, args); | |
| 1878 } | |
| 1879 | |
| 1880 Lisp_Object | |
| 1881 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1882 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
| 1883 Lisp_Object obj6, Lisp_Object obj7) | |
| 1884 { | |
| 1885 Lisp_Object args[8]; | |
| 1886 args[0] = obj0; | |
| 1887 args[1] = obj1; | |
| 1888 args[2] = obj2; | |
| 1889 args[3] = obj3; | |
| 1890 args[4] = obj4; | |
| 1891 args[5] = obj5; | |
| 1892 args[6] = obj6; | |
| 1893 args[7] = obj7; | |
| 1894 return Fvector (8, args); | |
| 1895 } | |
| 1896 #endif /* unused */ | |
| 1897 | |
| 1898 /************************************************************************/ | |
| 1899 /* Bit Vector allocation */ | |
| 1900 /************************************************************************/ | |
| 1901 | |
| 1902 /* #### should allocate `small' bit vectors from a frob-block */ | |
| 440 | 1903 static Lisp_Bit_Vector * |
| 665 | 1904 make_bit_vector_internal (Elemcount sizei) |
| 428 | 1905 { |
| 1204 | 1906 /* no `next' field; we use lcrecords */ |
| 665 | 1907 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei); |
| 1908 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, | |
| 1204 | 1909 unsigned long, |
| 1910 bits, num_longs); | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1911 Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, bit_vector); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1912 Lisp_Bit_Vector *p = XBIT_VECTOR (obj); |
| 428 | 1913 |
| 1914 bit_vector_length (p) = sizei; | |
| 1915 return p; | |
| 1916 } | |
| 1917 | |
| 1918 Lisp_Object | |
| 665 | 1919 make_bit_vector (Elemcount length, Lisp_Object bit) |
| 428 | 1920 { |
| 440 | 1921 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
| 665 | 1922 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length); |
| 428 | 1923 |
| 444 | 1924 CHECK_BIT (bit); |
| 1925 | |
| 1926 if (ZEROP (bit)) | |
| 428 | 1927 memset (p->bits, 0, num_longs * sizeof (long)); |
| 1928 else | |
| 1929 { | |
| 665 | 1930 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1); |
| 428 | 1931 memset (p->bits, ~0, num_longs * sizeof (long)); |
| 1932 /* But we have to make sure that the unused bits in the | |
| 1933 last long are 0, so that equal/hash is easy. */ | |
| 1934 if (bits_in_last) | |
| 1935 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1; | |
| 1936 } | |
| 1937 | |
| 793 | 1938 return wrap_bit_vector (p); |
| 428 | 1939 } |
| 1940 | |
| 1941 Lisp_Object | |
| 665 | 1942 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length) |
| 428 | 1943 { |
| 665 | 1944 Elemcount i; |
| 428 | 1945 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
| 1946 | |
| 1947 for (i = 0; i < length; i++) | |
| 1948 set_bit_vector_bit (p, i, bytevec[i]); | |
| 1949 | |
| 793 | 1950 return wrap_bit_vector (p); |
| 428 | 1951 } |
| 1952 | |
| 1953 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /* | |
| 444 | 1954 Return a new bit vector of length LENGTH. with each bit set to BIT. |
| 1955 BIT must be one of the integers 0 or 1. See also the function `bit-vector'. | |
| 428 | 1956 */ |
| 444 | 1957 (length, bit)) |
| 428 | 1958 { |
| 1959 CONCHECK_NATNUM (length); | |
| 1960 | |
| 444 | 1961 return make_bit_vector (XINT (length), bit); |
| 428 | 1962 } |
| 1963 | |
| 1964 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /* | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1965 Return a newly created bit vector with specified ARGS as elements. |
| 428 | 1966 Any number of arguments, even zero arguments, are allowed. |
| 444 | 1967 Each argument must be one of the integers 0 or 1. |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1968 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1969 arguments: (&rest ARGS) |
| 428 | 1970 */ |
| 1971 (int nargs, Lisp_Object *args)) | |
| 1972 { | |
| 1973 int i; | |
| 1974 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs); | |
| 1975 | |
| 1976 for (i = 0; i < nargs; i++) | |
| 1977 { | |
| 1978 CHECK_BIT (args[i]); | |
| 1979 set_bit_vector_bit (p, i, !ZEROP (args[i])); | |
| 1980 } | |
| 1981 | |
| 793 | 1982 return wrap_bit_vector (p); |
| 428 | 1983 } |
| 1984 | |
| 1985 | |
| 1986 /************************************************************************/ | |
| 1987 /* Compiled-function allocation */ | |
| 1988 /************************************************************************/ | |
| 1989 | |
| 1990 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function); | |
| 1991 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 | |
| 1992 | |
| 1993 static Lisp_Object | |
| 1994 make_compiled_function (void) | |
| 1995 { | |
| 1996 Lisp_Compiled_Function *f; | |
| 1997 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1998 ALLOC_FROB_BLOCK_LISP_OBJECT (compiled_function, Lisp_Compiled_Function, |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1999 f, &lrecord_compiled_function); |
| 428 | 2000 |
| 2001 f->stack_depth = 0; | |
| 2002 f->specpdl_depth = 0; | |
| 2003 f->flags.documentationp = 0; | |
| 2004 f->flags.interactivep = 0; | |
| 2005 f->flags.domainp = 0; /* I18N3 */ | |
| 2006 f->instructions = Qzero; | |
| 2007 f->constants = Qzero; | |
| 2008 f->arglist = Qnil; | |
| 3092 | 2009 #ifdef NEW_GC |
| 2010 f->arguments = Qnil; | |
| 2011 #else /* not NEW_GC */ | |
| 1739 | 2012 f->args = NULL; |
| 3092 | 2013 #endif /* not NEW_GC */ |
| 1739 | 2014 f->max_args = f->min_args = f->args_in_array = 0; |
| 428 | 2015 f->doc_and_interactive = Qnil; |
| 2016 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2017 f->annotated = Qnil; | |
| 2018 #endif | |
| 793 | 2019 return wrap_compiled_function (f); |
| 428 | 2020 } |
| 2021 | |
| 2022 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* | |
| 2023 Return a new compiled-function object. | |
| 2024 Note that, unlike all other emacs-lisp functions, calling this with five | |
| 2025 arguments is NOT the same as calling it with six arguments, the last of | |
| 2026 which is nil. If the INTERACTIVE arg is specified as nil, then that means | |
| 2027 that this function was defined with `(interactive)'. If the arg is not | |
| 2028 specified, then that means the function is not interactive. | |
| 2029 This is terrible behavior which is retained for compatibility with old | |
| 2030 `.elc' files which expect these semantics. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
2031 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
2032 arguments: (ARGLIST INSTRUCTIONS CONSTANTS STACK-DEPTH &optional DOC-STRING INTERACTIVE) |
| 428 | 2033 */ |
| 2034 (int nargs, Lisp_Object *args)) | |
| 2035 { | |
| 2036 /* In a non-insane world this function would have this arglist... | |
| 2037 (arglist instructions constants stack_depth &optional doc_string interactive) | |
| 2038 */ | |
| 2039 Lisp_Object fun = make_compiled_function (); | |
| 2040 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 2041 | |
| 2042 Lisp_Object arglist = args[0]; | |
| 2043 Lisp_Object instructions = args[1]; | |
| 2044 Lisp_Object constants = args[2]; | |
| 2045 Lisp_Object stack_depth = args[3]; | |
| 2046 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil; | |
| 2047 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound; | |
| 2048 | |
| 2049 if (nargs < 4 || nargs > 6) | |
| 2050 return Fsignal (Qwrong_number_of_arguments, | |
| 2051 list2 (intern ("make-byte-code"), make_int (nargs))); | |
| 2052 | |
| 2053 /* Check for valid formal parameter list now, to allow us to use | |
| 2054 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */ | |
| 2055 { | |
| 814 | 2056 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 2057 { |
| 2058 CHECK_SYMBOL (symbol); | |
| 2059 if (EQ (symbol, Qt) || | |
| 2060 EQ (symbol, Qnil) || | |
| 2061 SYMBOL_IS_KEYWORD (symbol)) | |
| 563 | 2062 invalid_constant_2 |
| 428 | 2063 ("Invalid constant symbol in formal parameter list", |
| 2064 symbol, arglist); | |
| 2065 } | |
| 2066 } | |
| 2067 f->arglist = arglist; | |
| 2068 | |
| 2069 /* `instructions' is a string or a cons (string . int) for a | |
| 2070 lazy-loaded function. */ | |
| 2071 if (CONSP (instructions)) | |
| 2072 { | |
| 2073 CHECK_STRING (XCAR (instructions)); | |
| 2074 CHECK_INT (XCDR (instructions)); | |
| 2075 } | |
| 2076 else | |
| 2077 { | |
| 2078 CHECK_STRING (instructions); | |
| 2079 } | |
| 2080 f->instructions = instructions; | |
| 2081 | |
| 2082 if (!NILP (constants)) | |
| 2083 CHECK_VECTOR (constants); | |
| 2084 f->constants = constants; | |
| 2085 | |
| 2086 CHECK_NATNUM (stack_depth); | |
| 442 | 2087 f->stack_depth = (unsigned short) XINT (stack_depth); |
| 428 | 2088 |
| 2089 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
|
4923
8ee3c10d1ed5
remove old no-longer-useful kludgy compiled-fun annotations hack
Ben Wing <ben@xemacs.org>
parents:
4921
diff
changeset
|
2090 f->annotated = Vload_file_name_internal; |
| 428 | 2091 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ |
| 2092 | |
| 2093 /* doc_string may be nil, string, int, or a cons (string . int). | |
| 2094 interactive may be list or string (or unbound). */ | |
| 2095 f->doc_and_interactive = Qunbound; | |
| 2096 #ifdef I18N3 | |
| 2097 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0) | |
| 2098 f->doc_and_interactive = Vfile_domain; | |
| 2099 #endif | |
| 2100 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0) | |
| 2101 { | |
| 2102 f->doc_and_interactive | |
| 2103 = (UNBOUNDP (f->doc_and_interactive) ? interactive : | |
| 2104 Fcons (interactive, f->doc_and_interactive)); | |
| 2105 } | |
| 2106 if ((f->flags.documentationp = !NILP (doc_string)) != 0) | |
| 2107 { | |
| 2108 f->doc_and_interactive | |
| 2109 = (UNBOUNDP (f->doc_and_interactive) ? doc_string : | |
| 2110 Fcons (doc_string, f->doc_and_interactive)); | |
| 2111 } | |
| 2112 if (UNBOUNDP (f->doc_and_interactive)) | |
| 2113 f->doc_and_interactive = Qnil; | |
| 2114 | |
| 2115 return fun; | |
| 2116 } | |
| 2117 | |
| 2118 | |
| 2119 /************************************************************************/ | |
| 2120 /* Symbol allocation */ | |
| 2121 /************************************************************************/ | |
| 2122 | |
| 440 | 2123 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol); |
| 428 | 2124 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 |
| 2125 | |
| 2126 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /* | |
| 2127 Return a newly allocated uninterned symbol whose name is NAME. | |
| 2128 Its value and function definition are void, and its property list is nil. | |
| 2129 */ | |
| 2130 (name)) | |
| 2131 { | |
| 440 | 2132 Lisp_Symbol *p; |
| 428 | 2133 |
| 2134 CHECK_STRING (name); | |
| 2135 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2136 ALLOC_FROB_BLOCK_LISP_OBJECT (symbol, Lisp_Symbol, p, &lrecord_symbol); |
| 793 | 2137 p->name = name; |
| 428 | 2138 p->plist = Qnil; |
| 2139 p->value = Qunbound; | |
| 2140 p->function = Qunbound; | |
| 2141 symbol_next (p) = 0; | |
| 793 | 2142 return wrap_symbol (p); |
| 428 | 2143 } |
| 2144 | |
| 2145 | |
| 2146 /************************************************************************/ | |
| 2147 /* Extent allocation */ | |
| 2148 /************************************************************************/ | |
| 2149 | |
| 2150 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); | |
| 2151 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 | |
| 2152 | |
| 2153 struct extent * | |
| 2154 allocate_extent (void) | |
| 2155 { | |
| 2156 struct extent *e; | |
| 2157 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2158 ALLOC_FROB_BLOCK_LISP_OBJECT (extent, struct extent, e, &lrecord_extent); |
| 428 | 2159 extent_object (e) = Qnil; |
| 2160 set_extent_start (e, -1); | |
| 2161 set_extent_end (e, -1); | |
| 2162 e->plist = Qnil; | |
| 2163 | |
| 2164 xzero (e->flags); | |
| 2165 | |
| 2166 extent_face (e) = Qnil; | |
| 2167 e->flags.end_open = 1; /* default is for endpoints to behave like markers */ | |
| 2168 e->flags.detachable = 1; | |
| 2169 | |
| 2170 return e; | |
| 2171 } | |
| 2172 | |
| 2173 | |
| 2174 /************************************************************************/ | |
| 2175 /* Event allocation */ | |
| 2176 /************************************************************************/ | |
| 2177 | |
| 440 | 2178 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event); |
| 428 | 2179 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 |
| 2180 | |
| 2181 Lisp_Object | |
| 2182 allocate_event (void) | |
| 2183 { | |
| 440 | 2184 Lisp_Event *e; |
| 2185 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2186 ALLOC_FROB_BLOCK_LISP_OBJECT (event, Lisp_Event, e, &lrecord_event); |
| 428 | 2187 |
| 793 | 2188 return wrap_event (e); |
| 428 | 2189 } |
| 2190 | |
| 1204 | 2191 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 2192 DECLARE_FIXED_TYPE_ALLOC (key_data, Lisp_Key_Data); |
| 2193 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_key_data 1000 | |
| 2194 | |
| 2195 Lisp_Object | |
| 1204 | 2196 make_key_data (void) |
| 934 | 2197 { |
| 2198 Lisp_Key_Data *d; | |
| 2199 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2200 ALLOC_FROB_BLOCK_LISP_OBJECT (key_data, Lisp_Key_Data, d, |
| 3017 | 2201 &lrecord_key_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2202 zero_nonsized_lisp_object (wrap_key_data (d)); |
| 1204 | 2203 d->keysym = Qnil; |
| 2204 | |
| 2205 return wrap_key_data (d); | |
| 934 | 2206 } |
| 2207 | |
| 2208 DECLARE_FIXED_TYPE_ALLOC (button_data, Lisp_Button_Data); | |
| 2209 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_button_data 1000 | |
| 2210 | |
| 2211 Lisp_Object | |
| 1204 | 2212 make_button_data (void) |
| 934 | 2213 { |
| 2214 Lisp_Button_Data *d; | |
| 2215 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2216 ALLOC_FROB_BLOCK_LISP_OBJECT (button_data, Lisp_Button_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2217 &lrecord_button_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2218 zero_nonsized_lisp_object (wrap_button_data (d)); |
| 1204 | 2219 return wrap_button_data (d); |
| 934 | 2220 } |
| 2221 | |
| 2222 DECLARE_FIXED_TYPE_ALLOC (motion_data, Lisp_Motion_Data); | |
| 2223 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_motion_data 1000 | |
| 2224 | |
| 2225 Lisp_Object | |
| 1204 | 2226 make_motion_data (void) |
| 934 | 2227 { |
| 2228 Lisp_Motion_Data *d; | |
| 2229 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2230 ALLOC_FROB_BLOCK_LISP_OBJECT (motion_data, Lisp_Motion_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2231 &lrecord_motion_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2232 zero_nonsized_lisp_object (wrap_motion_data (d)); |
| 934 | 2233 |
| 1204 | 2234 return wrap_motion_data (d); |
| 934 | 2235 } |
| 2236 | |
| 2237 DECLARE_FIXED_TYPE_ALLOC (process_data, Lisp_Process_Data); | |
| 2238 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_process_data 1000 | |
| 2239 | |
| 2240 Lisp_Object | |
| 1204 | 2241 make_process_data (void) |
| 934 | 2242 { |
| 2243 Lisp_Process_Data *d; | |
| 2244 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2245 ALLOC_FROB_BLOCK_LISP_OBJECT (process_data, Lisp_Process_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2246 &lrecord_process_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2247 zero_nonsized_lisp_object (wrap_process_data (d)); |
| 1204 | 2248 d->process = Qnil; |
| 2249 | |
| 2250 return wrap_process_data (d); | |
| 934 | 2251 } |
| 2252 | |
| 2253 DECLARE_FIXED_TYPE_ALLOC (timeout_data, Lisp_Timeout_Data); | |
| 2254 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_timeout_data 1000 | |
| 2255 | |
| 2256 Lisp_Object | |
| 1204 | 2257 make_timeout_data (void) |
| 934 | 2258 { |
| 2259 Lisp_Timeout_Data *d; | |
| 2260 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2261 ALLOC_FROB_BLOCK_LISP_OBJECT (timeout_data, Lisp_Timeout_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2262 &lrecord_timeout_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2263 zero_nonsized_lisp_object (wrap_timeout_data (d)); |
| 1204 | 2264 d->function = Qnil; |
| 2265 d->object = Qnil; | |
| 2266 | |
| 2267 return wrap_timeout_data (d); | |
| 934 | 2268 } |
| 2269 | |
| 2270 DECLARE_FIXED_TYPE_ALLOC (magic_data, Lisp_Magic_Data); | |
| 2271 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_data 1000 | |
| 2272 | |
| 2273 Lisp_Object | |
| 1204 | 2274 make_magic_data (void) |
| 934 | 2275 { |
| 2276 Lisp_Magic_Data *d; | |
| 2277 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2278 ALLOC_FROB_BLOCK_LISP_OBJECT (magic_data, Lisp_Magic_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2279 &lrecord_magic_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2280 zero_nonsized_lisp_object (wrap_magic_data (d)); |
| 934 | 2281 |
| 1204 | 2282 return wrap_magic_data (d); |
| 934 | 2283 } |
| 2284 | |
| 2285 DECLARE_FIXED_TYPE_ALLOC (magic_eval_data, Lisp_Magic_Eval_Data); | |
| 2286 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_eval_data 1000 | |
| 2287 | |
| 2288 Lisp_Object | |
| 1204 | 2289 make_magic_eval_data (void) |
| 934 | 2290 { |
| 2291 Lisp_Magic_Eval_Data *d; | |
| 2292 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2293 ALLOC_FROB_BLOCK_LISP_OBJECT (magic_eval_data, Lisp_Magic_Eval_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2294 &lrecord_magic_eval_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2295 zero_nonsized_lisp_object (wrap_magic_eval_data (d)); |
| 1204 | 2296 d->object = Qnil; |
| 2297 | |
| 2298 return wrap_magic_eval_data (d); | |
| 934 | 2299 } |
| 2300 | |
| 2301 DECLARE_FIXED_TYPE_ALLOC (eval_data, Lisp_Eval_Data); | |
| 2302 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_eval_data 1000 | |
| 2303 | |
| 2304 Lisp_Object | |
| 1204 | 2305 make_eval_data (void) |
| 934 | 2306 { |
| 2307 Lisp_Eval_Data *d; | |
| 2308 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2309 ALLOC_FROB_BLOCK_LISP_OBJECT (eval_data, Lisp_Eval_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2310 &lrecord_eval_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2311 zero_nonsized_lisp_object (wrap_eval_data (d)); |
| 1204 | 2312 d->function = Qnil; |
| 2313 d->object = Qnil; | |
| 2314 | |
| 2315 return wrap_eval_data (d); | |
| 934 | 2316 } |
| 2317 | |
| 2318 DECLARE_FIXED_TYPE_ALLOC (misc_user_data, Lisp_Misc_User_Data); | |
| 2319 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_misc_user_data 1000 | |
| 2320 | |
| 2321 Lisp_Object | |
| 1204 | 2322 make_misc_user_data (void) |
| 934 | 2323 { |
| 2324 Lisp_Misc_User_Data *d; | |
| 2325 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2326 ALLOC_FROB_BLOCK_LISP_OBJECT (misc_user_data, Lisp_Misc_User_Data, d, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2327 &lrecord_misc_user_data); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2328 zero_nonsized_lisp_object (wrap_misc_user_data (d)); |
| 1204 | 2329 d->function = Qnil; |
| 2330 d->object = Qnil; | |
| 2331 | |
| 2332 return wrap_misc_user_data (d); | |
| 934 | 2333 } |
| 1204 | 2334 |
| 2335 #endif /* EVENT_DATA_AS_OBJECTS */ | |
| 428 | 2336 |
| 2337 /************************************************************************/ | |
| 2338 /* Marker allocation */ | |
| 2339 /************************************************************************/ | |
| 2340 | |
| 440 | 2341 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker); |
| 428 | 2342 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 |
| 2343 | |
| 2344 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /* | |
| 2345 Return a new marker which does not point at any place. | |
| 2346 */ | |
| 2347 ()) | |
| 2348 { | |
| 440 | 2349 Lisp_Marker *p; |
| 2350 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2351 ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, &lrecord_marker); |
| 428 | 2352 p->buffer = 0; |
| 665 | 2353 p->membpos = 0; |
| 428 | 2354 marker_next (p) = 0; |
| 2355 marker_prev (p) = 0; | |
| 2356 p->insertion_type = 0; | |
| 793 | 2357 return wrap_marker (p); |
| 428 | 2358 } |
| 2359 | |
| 2360 Lisp_Object | |
| 2361 noseeum_make_marker (void) | |
| 2362 { | |
| 440 | 2363 Lisp_Marker *p; |
| 2364 | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2365 NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2366 &lrecord_marker); |
| 428 | 2367 p->buffer = 0; |
| 665 | 2368 p->membpos = 0; |
| 428 | 2369 marker_next (p) = 0; |
| 2370 marker_prev (p) = 0; | |
| 2371 p->insertion_type = 0; | |
| 793 | 2372 return wrap_marker (p); |
| 428 | 2373 } |
| 2374 | |
| 2375 | |
| 2376 /************************************************************************/ | |
| 2377 /* String allocation */ | |
| 2378 /************************************************************************/ | |
| 2379 | |
| 2380 /* The data for "short" strings generally resides inside of structs of type | |
| 2381 string_chars_block. The Lisp_String structure is allocated just like any | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2382 other frob-block lrecord, and these are freelisted when they get garbage |
| 1204 | 2383 collected. The data for short strings get compacted, but the data for |
| 2384 large strings do not. | |
| 428 | 2385 |
| 2386 Previously Lisp_String structures were relocated, but this caused a lot | |
| 2387 of bus-errors because the C code didn't include enough GCPRO's for | |
| 2388 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so | |
| 2389 that the reference would get relocated). | |
| 2390 | |
| 2391 This new method makes things somewhat bigger, but it is MUCH safer. */ | |
| 2392 | |
| 438 | 2393 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String); |
| 428 | 2394 /* strings are used and freed quite often */ |
| 2395 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ | |
| 2396 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 | |
| 2397 | |
| 2398 static Lisp_Object | |
| 2399 mark_string (Lisp_Object obj) | |
| 2400 { | |
| 793 | 2401 if (CONSP (XSTRING_PLIST (obj)) && EXTENT_INFOP (XCAR (XSTRING_PLIST (obj)))) |
| 2402 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj))); | |
| 2403 return XSTRING_PLIST (obj); | |
| 428 | 2404 } |
| 2405 | |
| 2406 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2407 string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2408 int foldcase) |
| 428 | 2409 { |
| 2410 Bytecount len; | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2411 if (foldcase) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2412 return !lisp_strcasecmp_i18n (obj1, obj2); |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2413 else |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2414 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2415 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); |
| 428 | 2416 } |
| 2417 | |
| 1204 | 2418 static const struct memory_description string_description[] = { |
| 3092 | 2419 #ifdef NEW_GC |
| 2420 { XD_LISP_OBJECT, offsetof (Lisp_String, data_object) }, | |
| 2421 #else /* not NEW_GC */ | |
| 793 | 2422 { XD_BYTECOUNT, offsetof (Lisp_String, size_) }, |
| 2423 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) }, | |
| 3092 | 2424 #endif /* not NEW_GC */ |
| 440 | 2425 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) }, |
| 428 | 2426 { XD_END } |
| 2427 }; | |
| 2428 | |
| 442 | 2429 /* We store the string's extent info as the first element of the string's |
| 2430 property list; and the string's MODIFF as the first or second element | |
| 2431 of the string's property list (depending on whether the extent info | |
| 2432 is present), but only if the string has been modified. This is ugly | |
| 2433 but it reduces the memory allocated for the string in the vast | |
| 2434 majority of cases, where the string is never modified and has no | |
| 2435 extent info. | |
| 2436 | |
| 2437 #### This means you can't use an int as a key in a string's plist. */ | |
| 2438 | |
| 2439 static Lisp_Object * | |
| 2440 string_plist_ptr (Lisp_Object string) | |
| 2441 { | |
| 793 | 2442 Lisp_Object *ptr = &XSTRING_PLIST (string); |
| 442 | 2443 |
| 2444 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
| 2445 ptr = &XCDR (*ptr); | |
| 2446 if (CONSP (*ptr) && INTP (XCAR (*ptr))) | |
| 2447 ptr = &XCDR (*ptr); | |
| 2448 return ptr; | |
| 2449 } | |
| 2450 | |
| 2451 static Lisp_Object | |
| 2452 string_getprop (Lisp_Object string, Lisp_Object property) | |
| 2453 { | |
| 2454 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME); | |
| 2455 } | |
| 2456 | |
| 2457 static int | |
| 2458 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value) | |
| 2459 { | |
| 2460 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME); | |
| 2461 return 1; | |
| 2462 } | |
| 2463 | |
| 2464 static int | |
| 2465 string_remprop (Lisp_Object string, Lisp_Object property) | |
| 2466 { | |
| 2467 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME); | |
| 2468 } | |
| 2469 | |
| 2470 static Lisp_Object | |
| 2471 string_plist (Lisp_Object string) | |
| 2472 { | |
| 2473 return *string_plist_ptr (string); | |
| 2474 } | |
| 2475 | |
| 3263 | 2476 #ifndef NEW_GC |
| 442 | 2477 /* No `finalize', or `hash' methods. |
| 2478 internal_hash() already knows how to hash strings and finalization | |
| 2479 is done with the ADDITIONAL_FREE_string macro, which is the | |
| 2480 standard way to do finalization when using | |
| 2481 SWEEP_FIXED_TYPE_BLOCK(). */ | |
| 2720 | 2482 |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2483 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("string", string, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2484 mark_string, print_string, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2485 0, string_equal, 0, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2486 string_description, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2487 Lisp_String); |
| 3263 | 2488 #endif /* not NEW_GC */ |
| 2720 | 2489 |
| 3092 | 2490 #ifdef NEW_GC |
| 2491 #define STRING_FULLSIZE(size) \ | |
| 2492 ALIGN_SIZE (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_String_Direct_Data, Lisp_Object, data, (size) + 1), sizeof (Lisp_Object *)); | |
| 2493 #else /* not NEW_GC */ | |
| 428 | 2494 /* String blocks contain this many useful bytes. */ |
| 2495 #define STRING_CHARS_BLOCK_SIZE \ | |
| 814 | 2496 ((Bytecount) (8192 - MALLOC_OVERHEAD - \ |
| 2497 ((2 * sizeof (struct string_chars_block *)) \ | |
| 2498 + sizeof (EMACS_INT)))) | |
| 428 | 2499 /* Block header for small strings. */ |
| 2500 struct string_chars_block | |
| 2501 { | |
| 2502 EMACS_INT pos; | |
| 2503 struct string_chars_block *next; | |
| 2504 struct string_chars_block *prev; | |
| 2505 /* Contents of string_chars_block->string_chars are interleaved | |
| 2506 string_chars structures (see below) and the actual string data */ | |
| 2507 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE]; | |
| 2508 }; | |
| 2509 | |
| 2510 static struct string_chars_block *first_string_chars_block; | |
| 2511 static struct string_chars_block *current_string_chars_block; | |
| 2512 | |
| 2513 /* If SIZE is the length of a string, this returns how many bytes | |
| 2514 * the string occupies in string_chars_block->string_chars | |
| 2515 * (including alignment padding). | |
| 2516 */ | |
| 438 | 2517 #define STRING_FULLSIZE(size) \ |
| 826 | 2518 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *) |
| 428 | 2519 |
| 2520 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE) | |
| 2521 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size))) | |
| 2522 | |
| 454 | 2523 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL) |
| 2524 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL)) | |
| 3092 | 2525 #endif /* not NEW_GC */ |
| 454 | 2526 |
| 3263 | 2527 #ifdef NEW_GC |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2528 DEFINE_DUMPABLE_LISP_OBJECT ("string", string, mark_string, print_string, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2529 0, string_equal, 0, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2530 string_description, Lisp_String); |
| 3092 | 2531 |
| 2532 | |
| 2533 static const struct memory_description string_direct_data_description[] = { | |
| 3514 | 2534 { XD_BYTECOUNT, offsetof (Lisp_String_Direct_Data, size) }, |
| 3092 | 2535 { XD_END } |
| 2536 }; | |
| 2537 | |
| 2538 static Bytecount | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2539 size_string_direct_data (Lisp_Object obj) |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2540 { |
|
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2541 return STRING_FULLSIZE (XSTRING_DIRECT_DATA (obj)->size); |
| 3092 | 2542 } |
| 2543 | |
| 2544 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2545 DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("string-direct-data", |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2546 string_direct_data, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2547 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2548 string_direct_data_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2549 size_string_direct_data, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2550 Lisp_String_Direct_Data); |
| 3092 | 2551 |
| 2552 | |
| 2553 static const struct memory_description string_indirect_data_description[] = { | |
| 2554 { XD_BYTECOUNT, offsetof (Lisp_String_Indirect_Data, size) }, | |
| 2555 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String_Indirect_Data, data), | |
| 2556 XD_INDIRECT(0, 1) }, | |
| 2557 { XD_END } | |
| 2558 }; | |
| 2559 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2560 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("string-indirect-data", |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2561 string_indirect_data, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2562 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2563 string_indirect_data_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2564 Lisp_String_Indirect_Data); |
| 3092 | 2565 #endif /* NEW_GC */ |
| 2720 | 2566 |
| 3092 | 2567 #ifndef NEW_GC |
| 428 | 2568 struct string_chars |
| 2569 { | |
| 438 | 2570 Lisp_String *string; |
| 428 | 2571 unsigned char chars[1]; |
| 2572 }; | |
| 2573 | |
| 2574 struct unused_string_chars | |
| 2575 { | |
| 438 | 2576 Lisp_String *string; |
| 428 | 2577 EMACS_INT fullsize; |
| 2578 }; | |
| 2579 | |
| 2580 static void | |
| 2581 init_string_chars_alloc (void) | |
| 2582 { | |
| 2583 first_string_chars_block = xnew (struct string_chars_block); | |
| 2584 first_string_chars_block->prev = 0; | |
| 2585 first_string_chars_block->next = 0; | |
| 2586 first_string_chars_block->pos = 0; | |
| 2587 current_string_chars_block = first_string_chars_block; | |
| 2588 } | |
| 2589 | |
| 1550 | 2590 static Ibyte * |
| 2591 allocate_big_string_chars (Bytecount length) | |
| 2592 { | |
| 2593 Ibyte *p = xnew_array (Ibyte, length); | |
| 2594 INCREMENT_CONS_COUNTER (length, "string chars"); | |
| 2595 return p; | |
| 2596 } | |
| 2597 | |
| 428 | 2598 static struct string_chars * |
| 793 | 2599 allocate_string_chars_struct (Lisp_Object string_it_goes_with, |
| 814 | 2600 Bytecount fullsize) |
| 428 | 2601 { |
| 2602 struct string_chars *s_chars; | |
| 2603 | |
| 438 | 2604 if (fullsize <= |
| 2605 (countof (current_string_chars_block->string_chars) | |
| 2606 - current_string_chars_block->pos)) | |
| 428 | 2607 { |
| 2608 /* This string can fit in the current string chars block */ | |
| 2609 s_chars = (struct string_chars *) | |
| 2610 (current_string_chars_block->string_chars | |
| 2611 + current_string_chars_block->pos); | |
| 2612 current_string_chars_block->pos += fullsize; | |
| 2613 } | |
| 2614 else | |
| 2615 { | |
| 2616 /* Make a new current string chars block */ | |
| 2617 struct string_chars_block *new_scb = xnew (struct string_chars_block); | |
| 2618 | |
| 2619 current_string_chars_block->next = new_scb; | |
| 2620 new_scb->prev = current_string_chars_block; | |
| 2621 new_scb->next = 0; | |
| 2622 current_string_chars_block = new_scb; | |
| 2623 new_scb->pos = fullsize; | |
| 2624 s_chars = (struct string_chars *) | |
| 2625 current_string_chars_block->string_chars; | |
| 2626 } | |
| 2627 | |
| 793 | 2628 s_chars->string = XSTRING (string_it_goes_with); |
| 428 | 2629 |
| 2630 INCREMENT_CONS_COUNTER (fullsize, "string chars"); | |
| 2631 | |
| 2632 return s_chars; | |
| 2633 } | |
| 3092 | 2634 #endif /* not NEW_GC */ |
| 428 | 2635 |
| 771 | 2636 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN |
| 2637 void | |
| 2638 sledgehammer_check_ascii_begin (Lisp_Object str) | |
| 2639 { | |
| 2640 Bytecount i; | |
| 2641 | |
| 2642 for (i = 0; i < XSTRING_LENGTH (str); i++) | |
| 2643 { | |
| 826 | 2644 if (!byte_ascii_p (string_byte (str, i))) |
| 771 | 2645 break; |
| 2646 } | |
| 2647 | |
| 2648 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) || | |
| 2649 (i > MAX_STRING_ASCII_BEGIN && | |
| 2650 (Bytecount) XSTRING_ASCII_BEGIN (str) == | |
| 2651 (Bytecount) MAX_STRING_ASCII_BEGIN)); | |
| 2652 } | |
| 2653 #endif | |
| 2654 | |
| 2655 /* You do NOT want to be calling this! (And if you do, you must call | |
| 851 | 2656 XSET_STRING_ASCII_BEGIN() after modifying the string.) Use ALLOCA () |
| 771 | 2657 instead and then call make_string() like the rest of the world. */ |
| 2658 | |
| 428 | 2659 Lisp_Object |
| 2660 make_uninit_string (Bytecount length) | |
| 2661 { | |
| 438 | 2662 Lisp_String *s; |
| 814 | 2663 Bytecount fullsize = STRING_FULLSIZE (length); |
| 428 | 2664 |
| 438 | 2665 assert (length >= 0 && fullsize > 0); |
| 428 | 2666 |
| 3263 | 2667 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2668 s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string)); |
| 3263 | 2669 #else /* not NEW_GC */ |
| 428 | 2670 /* Allocate the string header */ |
| 438 | 2671 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
| 793 | 2672 xzero (*s); |
| 771 | 2673 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
| 3263 | 2674 #endif /* not NEW_GC */ |
| 2720 | 2675 |
| 3063 | 2676 /* The above allocations set the UID field, which overlaps with the |
| 2677 ascii-length field, to some non-zero value. We need to zero it. */ | |
| 2678 XSET_STRING_ASCII_BEGIN (wrap_string (s), 0); | |
| 2679 | |
| 3092 | 2680 #ifdef NEW_GC |
| 3304 | 2681 set_lispstringp_direct (s); |
| 3092 | 2682 STRING_DATA_OBJECT (s) = |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2683 alloc_sized_lrecord (fullsize, &lrecord_string_direct_data); |
| 3092 | 2684 #else /* not NEW_GC */ |
| 826 | 2685 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize) |
| 2720 | 2686 ? allocate_big_string_chars (length + 1) |
| 2687 : allocate_string_chars_struct (wrap_string (s), | |
| 2688 fullsize)->chars); | |
| 3092 | 2689 #endif /* not NEW_GC */ |
| 438 | 2690 |
| 826 | 2691 set_lispstringp_length (s, length); |
| 428 | 2692 s->plist = Qnil; |
| 793 | 2693 set_string_byte (wrap_string (s), length, 0); |
| 2694 | |
| 2695 return wrap_string (s); | |
| 428 | 2696 } |
| 2697 | |
| 2698 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
| 2699 static void verify_string_chars_integrity (void); | |
| 2700 #endif | |
| 2701 | |
| 2702 /* Resize the string S so that DELTA bytes can be inserted starting | |
| 2703 at POS. If DELTA < 0, it means deletion starting at POS. If | |
| 2704 POS < 0, resize the string but don't copy any characters. Use | |
| 2705 this if you're planning on completely overwriting the string. | |
| 2706 */ | |
| 2707 | |
| 2708 void | |
| 793 | 2709 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta) |
| 428 | 2710 { |
| 3092 | 2711 #ifdef NEW_GC |
| 2712 Bytecount newfullsize, len; | |
| 2713 #else /* not NEW_GC */ | |
| 438 | 2714 Bytecount oldfullsize, newfullsize; |
| 3092 | 2715 #endif /* not NEW_GC */ |
| 428 | 2716 #ifdef VERIFY_STRING_CHARS_INTEGRITY |
| 2717 verify_string_chars_integrity (); | |
| 2718 #endif | |
| 800 | 2719 #ifdef ERROR_CHECK_TEXT |
| 428 | 2720 if (pos >= 0) |
| 2721 { | |
| 793 | 2722 assert (pos <= XSTRING_LENGTH (s)); |
| 428 | 2723 if (delta < 0) |
| 793 | 2724 assert (pos + (-delta) <= XSTRING_LENGTH (s)); |
| 428 | 2725 } |
| 2726 else | |
| 2727 { | |
| 2728 if (delta < 0) | |
| 793 | 2729 assert ((-delta) <= XSTRING_LENGTH (s)); |
| 428 | 2730 } |
| 800 | 2731 #endif /* ERROR_CHECK_TEXT */ |
| 428 | 2732 |
| 2733 if (delta == 0) | |
| 2734 /* simplest case: no size change. */ | |
| 2735 return; | |
| 438 | 2736 |
| 2737 if (pos >= 0 && delta < 0) | |
| 2738 /* If DELTA < 0, the functions below will delete the characters | |
| 2739 before POS. We want to delete characters *after* POS, however, | |
| 2740 so convert this to the appropriate form. */ | |
| 2741 pos += -delta; | |
| 2742 | |
| 3092 | 2743 #ifdef NEW_GC |
| 2744 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); | |
| 2745 | |
| 2746 len = XSTRING_LENGTH (s) + 1 - pos; | |
| 2747 | |
| 2748 if (delta < 0 && pos >= 0) | |
| 2749 memmove (XSTRING_DATA (s) + pos + delta, | |
| 2750 XSTRING_DATA (s) + pos, len); | |
| 2751 | |
| 2752 XSTRING_DATA_OBJECT (s) = | |
| 2753 wrap_string_direct_data (mc_realloc (XPNTR (XSTRING_DATA_OBJECT (s)), | |
| 2754 newfullsize)); | |
| 2755 if (delta > 0 && pos >= 0) | |
| 2756 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos, | |
| 2757 len); | |
| 2758 | |
| 3263 | 2759 #else /* not NEW_GC */ |
| 793 | 2760 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s)); |
| 2761 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); | |
| 438 | 2762 |
| 2763 if (BIG_STRING_FULLSIZE_P (oldfullsize)) | |
| 428 | 2764 { |
| 438 | 2765 if (BIG_STRING_FULLSIZE_P (newfullsize)) |
| 428 | 2766 { |
| 440 | 2767 /* Both strings are big. We can just realloc(). |
| 2768 But careful! If the string is shrinking, we have to | |
| 2769 memmove() _before_ realloc(), and if growing, we have to | |
| 2770 memmove() _after_ realloc() - otherwise the access is | |
| 2771 illegal, and we might crash. */ | |
| 793 | 2772 Bytecount len = XSTRING_LENGTH (s) + 1 - pos; |
| 440 | 2773 |
| 2774 if (delta < 0 && pos >= 0) | |
| 793 | 2775 memmove (XSTRING_DATA (s) + pos + delta, |
| 2776 XSTRING_DATA (s) + pos, len); | |
| 2777 XSET_STRING_DATA | |
| 867 | 2778 (s, (Ibyte *) xrealloc (XSTRING_DATA (s), |
| 793 | 2779 XSTRING_LENGTH (s) + delta + 1)); |
| 440 | 2780 if (delta > 0 && pos >= 0) |
| 793 | 2781 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos, |
| 2782 len); | |
| 1550 | 2783 /* Bump the cons counter. |
| 2784 Conservative; Martin let the increment be delta. */ | |
| 2785 INCREMENT_CONS_COUNTER (newfullsize, "string chars"); | |
| 428 | 2786 } |
| 438 | 2787 else /* String has been demoted from BIG_STRING. */ |
| 428 | 2788 { |
| 867 | 2789 Ibyte *new_data = |
| 438 | 2790 allocate_string_chars_struct (s, newfullsize)->chars; |
| 867 | 2791 Ibyte *old_data = XSTRING_DATA (s); |
| 438 | 2792 |
| 2793 if (pos >= 0) | |
| 2794 { | |
| 2795 memcpy (new_data, old_data, pos); | |
| 2796 memcpy (new_data + pos + delta, old_data + pos, | |
| 793 | 2797 XSTRING_LENGTH (s) + 1 - pos); |
| 438 | 2798 } |
| 793 | 2799 XSET_STRING_DATA (s, new_data); |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2800 xfree (old_data); |
| 438 | 2801 } |
| 2802 } | |
| 2803 else /* old string is small */ | |
| 2804 { | |
| 2805 if (oldfullsize == newfullsize) | |
| 2806 { | |
| 2807 /* special case; size change but the necessary | |
| 2808 allocation size won't change (up or down; code | |
| 2809 somewhere depends on there not being any unused | |
| 2810 allocation space, modulo any alignment | |
| 2811 constraints). */ | |
| 428 | 2812 if (pos >= 0) |
| 2813 { | |
| 867 | 2814 Ibyte *addroff = pos + XSTRING_DATA (s); |
| 428 | 2815 |
| 2816 memmove (addroff + delta, addroff, | |
| 2817 /* +1 due to zero-termination. */ | |
| 793 | 2818 XSTRING_LENGTH (s) + 1 - pos); |
| 428 | 2819 } |
| 2820 } | |
| 2821 else | |
| 2822 { | |
| 867 | 2823 Ibyte *old_data = XSTRING_DATA (s); |
| 2824 Ibyte *new_data = | |
| 438 | 2825 BIG_STRING_FULLSIZE_P (newfullsize) |
| 1550 | 2826 ? allocate_big_string_chars (XSTRING_LENGTH (s) + delta + 1) |
| 438 | 2827 : allocate_string_chars_struct (s, newfullsize)->chars; |
| 2828 | |
| 428 | 2829 if (pos >= 0) |
| 2830 { | |
| 438 | 2831 memcpy (new_data, old_data, pos); |
| 2832 memcpy (new_data + pos + delta, old_data + pos, | |
| 793 | 2833 XSTRING_LENGTH (s) + 1 - pos); |
| 428 | 2834 } |
| 793 | 2835 XSET_STRING_DATA (s, new_data); |
| 438 | 2836 |
|
4776
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2837 if (!DUMPEDP (old_data)) /* Can't free dumped data. */ |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2838 { |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2839 /* We need to mark this chunk of the string_chars_block |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2840 as unused so that compact_string_chars() doesn't |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2841 freak. */ |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2842 struct string_chars *old_s_chars = (struct string_chars *) |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2843 ((char *) old_data - offsetof (struct string_chars, chars)); |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2844 /* Sanity check to make sure we aren't hosed by strange |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2845 alignment/padding. */ |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2846 assert (old_s_chars->string == XSTRING (s)); |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2847 MARK_STRING_CHARS_AS_FREE (old_s_chars); |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2848 ((struct unused_string_chars *) old_s_chars)->fullsize = |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2849 oldfullsize; |
|
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2850 } |
| 428 | 2851 } |
| 438 | 2852 } |
| 3092 | 2853 #endif /* not NEW_GC */ |
| 438 | 2854 |
| 793 | 2855 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta); |
| 438 | 2856 /* If pos < 0, the string won't be zero-terminated. |
| 2857 Terminate now just to make sure. */ | |
| 793 | 2858 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0'; |
| 438 | 2859 |
| 2860 if (pos >= 0) | |
| 793 | 2861 /* We also have to adjust all of the extent indices after the |
| 2862 place we did the change. We say "pos - 1" because | |
| 2863 adjust_extents() is exclusive of the starting position | |
| 2864 passed to it. */ | |
| 2865 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta); | |
| 428 | 2866 |
| 2867 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
| 2868 verify_string_chars_integrity (); | |
| 2869 #endif | |
| 2870 } | |
| 2871 | |
| 2872 #ifdef MULE | |
| 2873 | |
| 771 | 2874 /* WARNING: If you modify an existing string, you must call |
| 2875 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */ | |
| 428 | 2876 void |
| 867 | 2877 set_string_char (Lisp_Object s, Charcount i, Ichar c) |
| 428 | 2878 { |
| 867 | 2879 Ibyte newstr[MAX_ICHAR_LEN]; |
| 771 | 2880 Bytecount bytoff = string_index_char_to_byte (s, i); |
| 867 | 2881 Bytecount oldlen = itext_ichar_len (XSTRING_DATA (s) + bytoff); |
| 2882 Bytecount newlen = set_itext_ichar (newstr, c); | |
| 428 | 2883 |
| 793 | 2884 sledgehammer_check_ascii_begin (s); |
| 428 | 2885 if (oldlen != newlen) |
| 2886 resize_string (s, bytoff, newlen - oldlen); | |
| 793 | 2887 /* Remember, XSTRING_DATA (s) might have changed so we can't cache it. */ |
| 2888 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen); | |
| 771 | 2889 if (oldlen != newlen) |
| 2890 { | |
| 793 | 2891 if (newlen > 1 && i <= (Charcount) XSTRING_ASCII_BEGIN (s)) |
| 771 | 2892 /* Everything starting with the new char is no longer part of |
| 2893 ascii_begin */ | |
| 793 | 2894 XSET_STRING_ASCII_BEGIN (s, i); |
| 2895 else if (newlen == 1 && i == (Charcount) XSTRING_ASCII_BEGIN (s)) | |
| 771 | 2896 /* We've extended ascii_begin, and we have to figure out how much by */ |
| 2897 { | |
| 2898 Bytecount j; | |
| 814 | 2899 for (j = (Bytecount) i + 1; j < XSTRING_LENGTH (s); j++) |
| 771 | 2900 { |
| 826 | 2901 if (!byte_ascii_p (XSTRING_DATA (s)[j])) |
| 771 | 2902 break; |
| 2903 } | |
| 814 | 2904 XSET_STRING_ASCII_BEGIN (s, min (j, (Bytecount) MAX_STRING_ASCII_BEGIN)); |
| 771 | 2905 } |
| 2906 } | |
| 793 | 2907 sledgehammer_check_ascii_begin (s); |
| 428 | 2908 } |
| 2909 | |
| 2910 #endif /* MULE */ | |
| 2911 | |
| 2912 DEFUN ("make-string", Fmake_string, 2, 2, 0, /* | |
| 444 | 2913 Return a new string consisting of LENGTH copies of CHARACTER. |
| 2914 LENGTH must be a non-negative integer. | |
| 428 | 2915 */ |
| 444 | 2916 (length, character)) |
| 428 | 2917 { |
| 2918 CHECK_NATNUM (length); | |
| 444 | 2919 CHECK_CHAR_COERCE_INT (character); |
| 428 | 2920 { |
| 867 | 2921 Ibyte init_str[MAX_ICHAR_LEN]; |
| 2922 int len = set_itext_ichar (init_str, XCHAR (character)); | |
| 428 | 2923 Lisp_Object val = make_uninit_string (len * XINT (length)); |
| 2924 | |
| 2925 if (len == 1) | |
| 771 | 2926 { |
| 2927 /* Optimize the single-byte case */ | |
| 2928 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val)); | |
| 793 | 2929 XSET_STRING_ASCII_BEGIN (val, min (MAX_STRING_ASCII_BEGIN, |
| 2930 len * XINT (length))); | |
| 771 | 2931 } |
| 428 | 2932 else |
| 2933 { | |
| 647 | 2934 EMACS_INT i; |
| 867 | 2935 Ibyte *ptr = XSTRING_DATA (val); |
| 428 | 2936 |
| 2937 for (i = XINT (length); i; i--) | |
| 2938 { | |
| 867 | 2939 Ibyte *init_ptr = init_str; |
| 428 | 2940 switch (len) |
| 2941 { | |
| 2942 case 4: *ptr++ = *init_ptr++; | |
| 2943 case 3: *ptr++ = *init_ptr++; | |
| 2944 case 2: *ptr++ = *init_ptr++; | |
| 2945 case 1: *ptr++ = *init_ptr++; | |
| 2946 } | |
| 2947 } | |
| 2948 } | |
| 771 | 2949 sledgehammer_check_ascii_begin (val); |
| 428 | 2950 return val; |
| 2951 } | |
| 2952 } | |
| 2953 | |
| 2954 DEFUN ("string", Fstring, 0, MANY, 0, /* | |
| 2955 Concatenate all the argument characters and make the result a string. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
2956 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
2957 arguments: (&rest ARGS) |
| 428 | 2958 */ |
| 2959 (int nargs, Lisp_Object *args)) | |
| 2960 { | |
| 2367 | 2961 Ibyte *storage = alloca_ibytes (nargs * MAX_ICHAR_LEN); |
| 867 | 2962 Ibyte *p = storage; |
| 428 | 2963 |
| 2964 for (; nargs; nargs--, args++) | |
| 2965 { | |
| 2966 Lisp_Object lisp_char = *args; | |
| 2967 CHECK_CHAR_COERCE_INT (lisp_char); | |
| 867 | 2968 p += set_itext_ichar (p, XCHAR (lisp_char)); |
| 428 | 2969 } |
| 2970 return make_string (storage, p - storage); | |
| 2971 } | |
| 2972 | |
| 771 | 2973 /* Initialize the ascii_begin member of a string to the correct value. */ |
| 2974 | |
| 2975 void | |
| 2976 init_string_ascii_begin (Lisp_Object string) | |
| 2977 { | |
| 2978 #ifdef MULE | |
| 2979 int i; | |
| 2980 Bytecount length = XSTRING_LENGTH (string); | |
| 867 | 2981 Ibyte *contents = XSTRING_DATA (string); |
| 771 | 2982 |
| 2983 for (i = 0; i < length; i++) | |
| 2984 { | |
| 826 | 2985 if (!byte_ascii_p (contents[i])) |
| 771 | 2986 break; |
| 2987 } | |
| 793 | 2988 XSET_STRING_ASCII_BEGIN (string, min (i, MAX_STRING_ASCII_BEGIN)); |
| 771 | 2989 #else |
| 793 | 2990 XSET_STRING_ASCII_BEGIN (string, min (XSTRING_LENGTH (string), |
| 2991 MAX_STRING_ASCII_BEGIN)); | |
| 771 | 2992 #endif |
| 2993 sledgehammer_check_ascii_begin (string); | |
| 2994 } | |
| 428 | 2995 |
| 2996 /* Take some raw memory, which MUST already be in internal format, | |
| 2997 and package it up into a Lisp string. */ | |
| 2998 Lisp_Object | |
| 867 | 2999 make_string (const Ibyte *contents, Bytecount length) |
| 428 | 3000 { |
| 3001 Lisp_Object val; | |
| 3002 | |
| 3003 /* Make sure we find out about bad make_string's when they happen */ | |
| 800 | 3004 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
| 428 | 3005 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
| 3006 #endif | |
| 3007 | |
| 3008 val = make_uninit_string (length); | |
| 3009 memcpy (XSTRING_DATA (val), contents, length); | |
| 771 | 3010 init_string_ascii_begin (val); |
| 3011 sledgehammer_check_ascii_begin (val); | |
| 428 | 3012 return val; |
| 3013 } | |
| 3014 | |
| 3015 /* Take some raw memory, encoded in some external data format, | |
| 3016 and convert it into a Lisp string. */ | |
| 3017 Lisp_Object | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3018 make_extstring (const Extbyte *contents, EMACS_INT length, |
| 440 | 3019 Lisp_Object coding_system) |
| 428 | 3020 { |
| 440 | 3021 Lisp_Object string; |
| 3022 TO_INTERNAL_FORMAT (DATA, (contents, length), | |
| 3023 LISP_STRING, string, | |
| 3024 coding_system); | |
| 3025 return string; | |
| 428 | 3026 } |
| 3027 | |
| 3028 Lisp_Object | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3029 build_istring (const Ibyte *str) |
| 771 | 3030 { |
| 3031 /* Some strlen's crash and burn if passed null. */ | |
| 814 | 3032 return make_string (str, (str ? qxestrlen (str) : (Bytecount) 0)); |
| 771 | 3033 } |
| 3034 | |
| 3035 Lisp_Object | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3036 build_cistring (const CIbyte *str) |
|
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3037 { |
|
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3038 return build_istring ((const Ibyte *) str); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3039 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3040 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3041 Lisp_Object |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3042 build_ascstring (const Ascbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3043 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3044 ASSERT_ASCTEXT_ASCII (str); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3045 return build_istring ((const Ibyte *) str); |
| 428 | 3046 } |
| 3047 | |
| 3048 Lisp_Object | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3049 build_extstring (const Extbyte *str, Lisp_Object coding_system) |
| 428 | 3050 { |
| 3051 /* Some strlen's crash and burn if passed null. */ | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3052 return make_extstring ((const Extbyte *) str, |
| 2367 | 3053 (str ? dfc_external_data_len (str, coding_system) : |
| 3054 0), | |
| 440 | 3055 coding_system); |
| 428 | 3056 } |
| 3057 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3058 /* Build a string whose content is a translatable message, and translate |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3059 the message according to the current language environment. */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3060 |
| 428 | 3061 Lisp_Object |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3062 build_msg_istring (const Ibyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3063 { |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3064 return build_istring (IGETTEXT (str)); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3065 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3066 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3067 /* Build a string whose content is a translatable message, and translate |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3068 the message according to the current language environment. */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3069 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3070 Lisp_Object |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3071 build_msg_cistring (const CIbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3072 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3073 return build_msg_istring ((const Ibyte *) str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3074 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3075 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3076 /* Build a string whose content is a translatable message, and translate |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3077 the message according to the current language environment. |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3078 String must be pure-ASCII, and when compiled with error-checking, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3079 an abort will have if not pure-ASCII. */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3080 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3081 Lisp_Object |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3082 build_msg_ascstring (const Ascbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3083 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3084 ASSERT_ASCTEXT_ASCII (str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3085 return build_msg_istring ((const Ibyte *) str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3086 } |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3087 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3088 /* Build a string whose content is a translatable message, but don't |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3089 translate the message immediately. Perhaps do something else instead, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3090 such as put a property on the string indicating that it needs to be |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3091 translated. |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3092 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3093 This is useful for strings that are built at dump time or init time, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3094 rather than on-the-fly when the current language environment is set |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3095 properly. */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3096 |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3097 Lisp_Object |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3098 build_defer_istring (const Ibyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3099 { |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3100 Lisp_Object retval = build_istring ((Ibyte *) str); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3101 /* Possibly do something to the return value */ |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3102 return retval; |
| 771 | 3103 } |
| 3104 | |
| 428 | 3105 Lisp_Object |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3106 build_defer_cistring (const CIbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3107 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3108 return build_defer_istring ((Ibyte *) str); |
| 771 | 3109 } |
| 3110 | |
| 3111 Lisp_Object | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3112 build_defer_ascstring (const Ascbyte *str) |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3113 { |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3114 ASSERT_ASCTEXT_ASCII (str); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3115 return build_defer_istring ((Ibyte *) str); |
| 428 | 3116 } |
| 3117 | |
| 3118 Lisp_Object | |
| 867 | 3119 make_string_nocopy (const Ibyte *contents, Bytecount length) |
| 428 | 3120 { |
| 438 | 3121 Lisp_String *s; |
| 428 | 3122 Lisp_Object val; |
| 3123 | |
| 3124 /* Make sure we find out about bad make_string_nocopy's when they happen */ | |
| 800 | 3125 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
| 428 | 3126 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
| 3127 #endif | |
| 3128 | |
| 3263 | 3129 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3130 s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string)); |
| 2720 | 3131 mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get |
| 3132 collected and static data is tried to | |
| 3133 be freed. */ | |
| 3263 | 3134 #else /* not NEW_GC */ |
| 428 | 3135 /* Allocate the string header */ |
| 438 | 3136 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
| 771 | 3137 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
| 3138 SET_C_READONLY_RECORD_HEADER (&s->u.lheader); | |
| 3263 | 3139 #endif /* not NEW_GC */ |
| 3063 | 3140 /* Don't need to XSET_STRING_ASCII_BEGIN() here because it happens in |
| 3141 init_string_ascii_begin(). */ | |
| 428 | 3142 s->plist = Qnil; |
| 3092 | 3143 #ifdef NEW_GC |
| 3144 set_lispstringp_indirect (s); | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3145 STRING_DATA_OBJECT (s) = ALLOC_NORMAL_LISP_OBJECT (string_indirect_data); |
| 3092 | 3146 XSTRING_INDIRECT_DATA_DATA (STRING_DATA_OBJECT (s)) = (Ibyte *) contents; |
| 3147 XSTRING_INDIRECT_DATA_SIZE (STRING_DATA_OBJECT (s)) = length; | |
| 3148 #else /* not NEW_GC */ | |
| 867 | 3149 set_lispstringp_data (s, (Ibyte *) contents); |
| 826 | 3150 set_lispstringp_length (s, length); |
| 3092 | 3151 #endif /* not NEW_GC */ |
| 793 | 3152 val = wrap_string (s); |
| 771 | 3153 init_string_ascii_begin (val); |
| 3154 sledgehammer_check_ascii_begin (val); | |
| 3155 | |
| 428 | 3156 return val; |
| 3157 } | |
| 3158 | |
| 3159 | |
| 3263 | 3160 #ifndef NEW_GC |
| 428 | 3161 /************************************************************************/ |
| 3162 /* lcrecord lists */ | |
| 3163 /************************************************************************/ | |
| 3164 | |
| 3165 /* Lcrecord lists are used to manage the allocation of particular | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3166 sorts of lcrecords, to avoid calling ALLOC_NORMAL_LISP_OBJECT() (and thus |
| 428 | 3167 malloc() and garbage-collection junk) as much as possible. |
| 3168 It is similar to the Blocktype class. | |
| 3169 | |
| 1204 | 3170 See detailed comment in lcrecord.h. |
| 3171 */ | |
| 3172 | |
| 3173 const struct memory_description free_description[] = { | |
| 2551 | 3174 { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, { 0 }, |
| 1204 | 3175 XD_FLAG_FREE_LISP_OBJECT }, |
| 3176 { XD_END } | |
| 3177 }; | |
| 3178 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3179 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("free", free, 0, free_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3180 struct free_lcrecord_header); |
| 1204 | 3181 |
| 3182 const struct memory_description lcrecord_list_description[] = { | |
| 2551 | 3183 { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 }, |
| 1204 | 3184 XD_FLAG_FREE_LISP_OBJECT }, |
| 3185 { XD_END } | |
| 3186 }; | |
| 428 | 3187 |
| 3188 static Lisp_Object | |
| 3189 mark_lcrecord_list (Lisp_Object obj) | |
| 3190 { | |
| 3191 struct lcrecord_list *list = XLCRECORD_LIST (obj); | |
| 3192 Lisp_Object chain = list->free; | |
| 3193 | |
| 3194 while (!NILP (chain)) | |
| 3195 { | |
| 3196 struct lrecord_header *lheader = XRECORD_LHEADER (chain); | |
| 3197 struct free_lcrecord_header *free_header = | |
| 3198 (struct free_lcrecord_header *) lheader; | |
| 3199 | |
| 442 | 3200 gc_checking_assert |
| 3201 (/* There should be no other pointers to the free list. */ | |
| 3202 ! MARKED_RECORD_HEADER_P (lheader) | |
| 3203 && | |
| 3204 /* Only lcrecords should be here. */ | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3205 ! list->implementation->frob_block_p |
| 442 | 3206 && |
| 3207 /* Only free lcrecords should be here. */ | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3208 lheader->free |
| 442 | 3209 && |
| 3210 /* The type of the lcrecord must be right. */ | |
| 1204 | 3211 lheader->type == lrecord_type_free |
| 442 | 3212 && |
| 3213 /* So must the size. */ | |
| 1204 | 3214 (list->implementation->static_size == 0 || |
| 3215 list->implementation->static_size == list->size) | |
| 442 | 3216 ); |
| 428 | 3217 |
| 3218 MARK_RECORD_HEADER (lheader); | |
| 3219 chain = free_header->chain; | |
| 3220 } | |
| 3221 | |
| 3222 return Qnil; | |
| 3223 } | |
| 3224 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3225 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("lcrecord-list", lcrecord_list, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3226 mark_lcrecord_list, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3227 lcrecord_list_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3228 struct lcrecord_list); |
| 934 | 3229 |
| 428 | 3230 Lisp_Object |
| 665 | 3231 make_lcrecord_list (Elemcount size, |
| 442 | 3232 const struct lrecord_implementation *implementation) |
| 428 | 3233 { |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3234 /* Don't use alloc_automanaged_lcrecord() avoid infinite recursion |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3235 allocating this. */ |
| 1204 | 3236 struct lcrecord_list *p = (struct lcrecord_list *) |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3237 old_alloc_lcrecord (&lrecord_lcrecord_list); |
| 428 | 3238 |
| 3239 p->implementation = implementation; | |
| 3240 p->size = size; | |
| 3241 p->free = Qnil; | |
| 793 | 3242 return wrap_lcrecord_list (p); |
| 428 | 3243 } |
| 3244 | |
| 3245 Lisp_Object | |
| 1204 | 3246 alloc_managed_lcrecord (Lisp_Object lcrecord_list) |
| 428 | 3247 { |
| 3248 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
| 3249 if (!NILP (list->free)) | |
| 3250 { | |
| 3251 Lisp_Object val = list->free; | |
| 3252 struct free_lcrecord_header *free_header = | |
| 3253 (struct free_lcrecord_header *) XPNTR (val); | |
| 1204 | 3254 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
| 428 | 3255 |
| 3256 #ifdef ERROR_CHECK_GC | |
| 1204 | 3257 /* Major overkill here. */ |
| 428 | 3258 /* There should be no other pointers to the free list. */ |
| 442 | 3259 assert (! MARKED_RECORD_HEADER_P (lheader)); |
| 428 | 3260 /* Only free lcrecords should be here. */ |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3261 assert (lheader->free); |
| 1204 | 3262 assert (lheader->type == lrecord_type_free); |
| 3263 /* Only lcrecords should be here. */ | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3264 assert (! (list->implementation->frob_block_p)); |
| 1204 | 3265 #if 0 /* Not used anymore, now that we set the type of the header to |
| 3266 lrecord_type_free. */ | |
| 428 | 3267 /* The type of the lcrecord must be right. */ |
| 442 | 3268 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation); |
| 1204 | 3269 #endif /* 0 */ |
| 428 | 3270 /* So must the size. */ |
| 1204 | 3271 assert (list->implementation->static_size == 0 || |
| 3272 list->implementation->static_size == list->size); | |
| 428 | 3273 #endif /* ERROR_CHECK_GC */ |
| 442 | 3274 |
| 428 | 3275 list->free = free_header->chain; |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3276 lheader->free = 0; |
| 1204 | 3277 /* Put back the correct type, as we set it to lrecord_type_free. */ |
| 3278 lheader->type = list->implementation->lrecord_type_index; | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3279 zero_sized_lisp_object (val, list->size); |
| 428 | 3280 return val; |
| 3281 } | |
| 3282 else | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3283 return wrap_pointer_1 (old_alloc_sized_lcrecord (list->size, |
| 3024 | 3284 list->implementation)); |
| 428 | 3285 } |
| 3286 | |
| 771 | 3287 /* "Free" a Lisp object LCRECORD by placing it on its associated free list |
| 1204 | 3288 LCRECORD_LIST; next time alloc_managed_lcrecord() is called with the |
| 771 | 3289 same LCRECORD_LIST as its parameter, it will return an object from the |
| 3290 free list, which may be this one. Be VERY VERY SURE there are no | |
| 3291 pointers to this object hanging around anywhere where they might be | |
| 3292 used! | |
| 3293 | |
| 3294 The first thing this does before making any global state change is to | |
| 3295 call the finalize method of the object, if it exists. */ | |
| 3296 | |
| 428 | 3297 void |
| 3298 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord) | |
| 3299 { | |
| 3300 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
| 3301 struct free_lcrecord_header *free_header = | |
| 3302 (struct free_lcrecord_header *) XPNTR (lcrecord); | |
| 442 | 3303 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
| 3304 const struct lrecord_implementation *implementation | |
| 428 | 3305 = LHEADER_IMPLEMENTATION (lheader); |
| 3306 | |
|
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3307 /* If we try to debug-print during GC, we'll likely get a crash on the |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3308 following assert (called from Lstream_delete(), from prin1_to_string()). |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3309 Instead, just don't do anything. Worst comes to worst, we have a |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3310 small memory leak -- and programs being debugged usually won't be |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3311 super long-lived afterwards, anyway. */ |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3312 if (gc_in_progress && in_debug_print) |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3313 return; |
|
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3314 |
| 771 | 3315 /* Finalizer methods may try to free objects within them, which typically |
| 3316 won't be marked and thus are scheduled for demolition. Putting them | |
| 3317 on the free list would be very bad, as we'd have xfree()d memory in | |
| 3318 the list. Even if for some reason the objects are still live | |
| 3319 (generally a logic error!), we still will have problems putting such | |
| 3320 an object on the free list right now (e.g. we'd have to avoid calling | |
| 3321 the finalizer twice, etc.). So basically, those finalizers should not | |
| 3322 be freeing any objects if during GC. Abort now to catch those | |
| 3323 problems. */ | |
| 3324 gc_checking_assert (!gc_in_progress); | |
| 3325 | |
| 428 | 3326 /* Make sure the size is correct. This will catch, for example, |
| 3327 putting a window configuration on the wrong free list. */ | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3328 gc_checking_assert (lisp_object_size (lcrecord) == list->size); |
| 771 | 3329 /* Make sure the object isn't already freed. */ |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3330 gc_checking_assert (!lheader->free); |
| 2367 | 3331 /* Freeing stuff in dumped memory is bad. If you trip this, you |
| 3332 may need to check for this before freeing. */ | |
| 3333 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord)); | |
| 771 | 3334 |
| 428 | 3335 if (implementation->finalizer) |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3336 implementation->finalizer (lcrecord); |
| 1204 | 3337 /* Yes, there are two ways to indicate freeness -- the type is |
| 3338 lrecord_type_free or the ->free flag is set. We used to do only the | |
| 3339 latter; now we do the former as well for KKCC purposes. Probably | |
| 3340 safer in any case, as we will lose quicker this way than keeping | |
| 3341 around an lrecord of apparently correct type but bogus junk in it. */ | |
| 3342 MARK_LRECORD_AS_FREE (lheader); | |
| 428 | 3343 free_header->chain = list->free; |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3344 lheader->free = 1; |
| 428 | 3345 list->free = lcrecord; |
| 3346 } | |
| 3347 | |
| 771 | 3348 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)]; |
| 3349 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3350 Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3351 alloc_automanaged_sized_lcrecord (Bytecount size, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3352 const struct lrecord_implementation *imp) |
| 771 | 3353 { |
| 3354 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero)) | |
| 3355 all_lcrecord_lists[imp->lrecord_type_index] = | |
| 3356 make_lcrecord_list (size, imp); | |
| 3357 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3358 return alloc_managed_lcrecord (all_lcrecord_lists[imp->lrecord_type_index]); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3359 } |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3360 |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3361 Lisp_Object |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3362 alloc_automanaged_lcrecord (const struct lrecord_implementation *imp) |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3363 { |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3364 type_checking_assert (imp->static_size > 0); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3365 return alloc_automanaged_sized_lcrecord (imp->static_size, imp); |
| 771 | 3366 } |
| 3367 | |
| 3368 void | |
| 3024 | 3369 old_free_lcrecord (Lisp_Object rec) |
| 771 | 3370 { |
| 3371 int type = XRECORD_LHEADER (rec)->type; | |
| 3372 | |
| 3373 assert (!EQ (all_lcrecord_lists[type], Qzero)); | |
| 3374 | |
| 3375 free_managed_lcrecord (all_lcrecord_lists[type], rec); | |
| 3376 } | |
| 3263 | 3377 #endif /* not NEW_GC */ |
| 428 | 3378 |
| 3379 | |
| 3380 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /* | |
| 3381 Kept for compatibility, returns its argument. | |
| 3382 Old: | |
| 3383 Make a copy of OBJECT in pure storage. | |
| 3384 Recursively copies contents of vectors and cons cells. | |
| 3385 Does not copy symbols. | |
| 3386 */ | |
| 444 | 3387 (object)) |
| 428 | 3388 { |
| 444 | 3389 return object; |
| 428 | 3390 } |
| 3391 | |
| 3392 | |
| 3393 /************************************************************************/ | |
| 3394 /* Garbage Collection */ | |
| 3395 /************************************************************************/ | |
| 3396 | |
| 1676 | 3397 #ifndef USE_KKCC |
| 442 | 3398 /* Object marker functions are in the lrecord_implementation structure. |
| 3399 But copying them to a parallel array is much more cache-friendly. | |
| 3400 This hack speeds up (garbage-collect) by about 5%. */ | |
| 3401 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object); | |
| 1676 | 3402 #endif /* not USE_KKCC */ |
| 428 | 3403 |
| 3404 struct gcpro *gcprolist; | |
| 3405 | |
| 771 | 3406 /* We want the staticpro list relocated, but not the pointers found |
| 3407 therein, because they refer to locations in the global data segment, not | |
| 3408 in the heap; we only dump heap objects. Hence we use a trivial | |
| 3409 description, as for pointerless objects. (Note that the data segment | |
| 3410 objects, which are global variables like Qfoo or Vbar, themselves are | |
| 3411 pointers to heap objects. Each needs to be described to pdump as a | |
| 3412 "root pointer"; this happens in the call to staticpro(). */ | |
| 1204 | 3413 static const struct memory_description staticpro_description_1[] = { |
| 452 | 3414 { XD_END } |
| 3415 }; | |
| 3416 | |
| 1204 | 3417 static const struct sized_memory_description staticpro_description = { |
| 452 | 3418 sizeof (Lisp_Object *), |
| 3419 staticpro_description_1 | |
| 3420 }; | |
| 3421 | |
| 1204 | 3422 static const struct memory_description staticpros_description_1[] = { |
| 452 | 3423 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description), |
| 3424 { XD_END } | |
| 3425 }; | |
| 3426 | |
| 1204 | 3427 static const struct sized_memory_description staticpros_description = { |
| 452 | 3428 sizeof (Lisp_Object_ptr_dynarr), |
| 3429 staticpros_description_1 | |
| 3430 }; | |
| 3431 | |
| 771 | 3432 #ifdef DEBUG_XEMACS |
| 3433 | |
| 3434 /* Help debug crashes gc-marking a staticpro'ed object. */ | |
| 3435 | |
| 3436 Lisp_Object_ptr_dynarr *staticpros; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3437 const_Ascbyte_ptr_dynarr *staticpro_names; |
| 771 | 3438 |
| 3439 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3440 garbage collection, and for dumping. */ | |
| 3441 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3442 staticpro_1 (Lisp_Object *varaddress, const Ascbyte *varname) |
| 771 | 3443 { |
| 3444 Dynarr_add (staticpros, varaddress); | |
| 3445 Dynarr_add (staticpro_names, varname); | |
| 1204 | 3446 dump_add_root_lisp_object (varaddress); |
| 771 | 3447 } |
| 3448 | |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3449 const Ascbyte *staticpro_name (int count); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3450 |
|
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3451 /* External debugging function: Return the name of the variable at offset |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3452 COUNT. */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3453 const Ascbyte * |
|
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3454 staticpro_name (int count) |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3455 { |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3456 return Dynarr_at (staticpro_names, count); |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3457 } |
| 771 | 3458 |
| 3459 Lisp_Object_ptr_dynarr *staticpros_nodump; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3460 const_Ascbyte_ptr_dynarr *staticpro_nodump_names; |
| 771 | 3461 |
| 3462 /* Mark the Lisp_Object at heap VARADDRESS as a root object for | |
| 3463 garbage collection, but not for dumping. (See below.) */ | |
| 3464 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3465 staticpro_nodump_1 (Lisp_Object *varaddress, const Ascbyte *varname) |
| 771 | 3466 { |
| 3467 Dynarr_add (staticpros_nodump, varaddress); | |
| 3468 Dynarr_add (staticpro_nodump_names, varname); | |
| 3469 } | |
| 3470 | |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3471 const Ascbyte *staticpro_nodump_name (int count); |
|
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3472 |
|
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3473 /* External debugging function: Return the name of the variable at offset |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3474 COUNT. */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3475 const Ascbyte * |
|
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3476 staticpro_nodump_name (int count) |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3477 { |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3478 return Dynarr_at (staticpro_nodump_names, count); |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3479 } |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3480 |
| 996 | 3481 #ifdef HAVE_SHLIB |
| 3482 /* Stop treating the Lisp_Object at non-heap VARADDRESS as a root object | |
| 3483 for garbage collection, but not for dumping. */ | |
| 3484 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3485 unstaticpro_nodump_1 (Lisp_Object *varaddress, const Ascbyte *varname) |
| 996 | 3486 { |
| 3487 Dynarr_delete_object (staticpros, varaddress); | |
| 3488 Dynarr_delete_object (staticpro_names, varname); | |
| 3489 } | |
| 3490 #endif | |
| 3491 | |
| 771 | 3492 #else /* not DEBUG_XEMACS */ |
| 3493 | |
| 452 | 3494 Lisp_Object_ptr_dynarr *staticpros; |
| 3495 | |
| 3496 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3497 garbage collection, and for dumping. */ | |
| 428 | 3498 void |
| 3499 staticpro (Lisp_Object *varaddress) | |
| 3500 { | |
| 452 | 3501 Dynarr_add (staticpros, varaddress); |
| 1204 | 3502 dump_add_root_lisp_object (varaddress); |
| 428 | 3503 } |
| 3504 | |
| 442 | 3505 |
| 452 | 3506 Lisp_Object_ptr_dynarr *staticpros_nodump; |
| 3507 | |
| 771 | 3508 /* Mark the Lisp_Object at heap VARADDRESS as a root object for garbage |
| 3509 collection, but not for dumping. This is used for objects where the | |
| 3510 only sure pointer is in the heap (rather than in the global data | |
| 3511 segment, as must be the case for pdump root pointers), but not inside of | |
| 3512 another Lisp object (where it will be marked as a result of that Lisp | |
| 3513 object's mark method). The call to staticpro_nodump() must occur *BOTH* | |
| 3514 at initialization time and at "reinitialization" time (startup, after | |
| 3515 pdump load.) (For example, this is the case with the predicate symbols | |
| 3516 for specifier and coding system types. The pointer to this symbol is | |
| 3517 inside of a methods structure, which is allocated on the heap. The | |
| 3518 methods structure will be written out to the pdump data file, and may be | |
| 3519 reloaded at a different address.) | |
| 3520 | |
| 3521 #### The necessity for reinitialization is a bug in pdump. Pdump should | |
| 3522 automatically regenerate the staticpro()s for these symbols when it | |
| 3523 loads the data in. */ | |
| 3524 | |
| 428 | 3525 void |
| 3526 staticpro_nodump (Lisp_Object *varaddress) | |
| 3527 { | |
| 452 | 3528 Dynarr_add (staticpros_nodump, varaddress); |
| 428 | 3529 } |
| 3530 | |
| 996 | 3531 #ifdef HAVE_SHLIB |
| 3532 /* Unmark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3533 garbage collection, but not for dumping. */ | |
| 3534 void | |
| 3535 unstaticpro_nodump (Lisp_Object *varaddress) | |
| 3536 { | |
| 3537 Dynarr_delete_object (staticpros, varaddress); | |
| 3538 } | |
| 3539 #endif | |
| 3540 | |
| 771 | 3541 #endif /* not DEBUG_XEMACS */ |
| 3542 | |
| 2720 | 3543 |
| 3544 | |
| 3545 | |
| 3546 | |
| 3263 | 3547 #ifdef NEW_GC |
| 2720 | 3548 static const struct memory_description mcpro_description_1[] = { |
| 3549 { XD_END } | |
| 3550 }; | |
| 3551 | |
| 3552 static const struct sized_memory_description mcpro_description = { | |
| 3553 sizeof (Lisp_Object *), | |
| 3554 mcpro_description_1 | |
| 3555 }; | |
| 3556 | |
| 3557 static const struct memory_description mcpros_description_1[] = { | |
| 3558 XD_DYNARR_DESC (Lisp_Object_dynarr, &mcpro_description), | |
| 3559 { XD_END } | |
| 3560 }; | |
| 3561 | |
| 3562 static const struct sized_memory_description mcpros_description = { | |
| 3563 sizeof (Lisp_Object_dynarr), | |
| 3564 mcpros_description_1 | |
| 3565 }; | |
| 3566 | |
| 3567 #ifdef DEBUG_XEMACS | |
| 3568 | |
| 3569 /* Help debug crashes gc-marking a mcpro'ed object. */ | |
| 3570 | |
| 3571 Lisp_Object_dynarr *mcpros; | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3572 const_Ascbyte_ptr_dynarr *mcpro_names; |
| 2720 | 3573 |
| 3574 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3575 garbage collection, and for dumping. */ | |
| 3576 void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3577 mcpro_1 (Lisp_Object varaddress, const Ascbyte *varname) |
| 2720 | 3578 { |
| 3579 Dynarr_add (mcpros, varaddress); | |
| 3580 Dynarr_add (mcpro_names, varname); | |
| 3581 } | |
| 3582 | |
| 5046 | 3583 const Ascbyte *mcpro_name (int count); |
| 3584 | |
|
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3585 /* External debugging function: Return the name of the variable at offset |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3586 COUNT. */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3587 const Ascbyte * |
|
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3588 mcpro_name (int count) |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3589 { |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3590 return Dynarr_at (mcpro_names, count); |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3591 } |
|
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3592 |
| 2720 | 3593 #else /* not DEBUG_XEMACS */ |
| 3594 | |
| 3595 Lisp_Object_dynarr *mcpros; | |
| 3596 | |
| 3597 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3598 garbage collection, and for dumping. */ | |
| 3599 void | |
| 3600 mcpro (Lisp_Object varaddress) | |
| 3601 { | |
| 3602 Dynarr_add (mcpros, varaddress); | |
| 3603 } | |
| 3604 | |
| 3605 #endif /* not DEBUG_XEMACS */ | |
| 3263 | 3606 #endif /* NEW_GC */ |
| 3607 | |
| 3608 | |
| 3609 #ifndef NEW_GC | |
| 428 | 3610 static int gc_count_num_short_string_in_use; |
| 647 | 3611 static Bytecount gc_count_string_total_size; |
| 3612 static Bytecount gc_count_short_string_total_size; | |
| 428 | 3613 |
| 3614 /* static int gc_count_total_records_used, gc_count_records_total_size; */ | |
| 3615 | |
| 3616 | |
| 3617 /* stats on lcrecords in use - kinda kludgy */ | |
| 3618 | |
| 3619 static struct | |
| 3620 { | |
| 3621 int instances_in_use; | |
| 3622 int bytes_in_use; | |
| 3623 int instances_freed; | |
| 3624 int bytes_freed; | |
| 3625 int instances_on_free_list; | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3626 int bytes_on_free_list; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3627 } lrecord_stats [countof (lrecord_implementations_table)]; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3628 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3629 void |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3630 tick_lrecord_stats (const struct lrecord_header *h, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3631 enum lrecord_alloc_status status) |
| 428 | 3632 { |
| 647 | 3633 int type_index = h->type; |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3634 Bytecount sz = detagged_lisp_object_size (h); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3635 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3636 switch (status) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3637 { |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3638 case ALLOC_IN_USE: |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3639 lrecord_stats[type_index].instances_in_use++; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3640 lrecord_stats[type_index].bytes_in_use += sz; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3641 break; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3642 case ALLOC_FREE: |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3643 lrecord_stats[type_index].instances_freed++; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3644 lrecord_stats[type_index].bytes_freed += sz; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3645 break; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3646 case ALLOC_ON_FREE_LIST: |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3647 lrecord_stats[type_index].instances_on_free_list++; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3648 lrecord_stats[type_index].bytes_on_free_list += sz; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3649 break; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3650 default: |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3651 ABORT (); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3652 } |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3653 } |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3654 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3655 inline static void |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3656 tick_lcrecord_stats (const struct lrecord_header *h, int free_p) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3657 { |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3658 if (h->free) |
| 428 | 3659 { |
| 442 | 3660 gc_checking_assert (!free_p); |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3661 tick_lrecord_stats (h, ALLOC_ON_FREE_LIST); |
| 428 | 3662 } |
| 3663 else | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3664 tick_lrecord_stats (h, free_p ? ALLOC_FREE : ALLOC_IN_USE); |
| 428 | 3665 } |
| 3263 | 3666 #endif /* not NEW_GC */ |
| 428 | 3667 |
| 3668 | |
| 3263 | 3669 #ifndef NEW_GC |
| 428 | 3670 /* Free all unmarked records */ |
| 3671 static void | |
| 3024 | 3672 sweep_lcrecords_1 (struct old_lcrecord_header **prev, int *used) |
| 3673 { | |
| 3674 struct old_lcrecord_header *header; | |
| 428 | 3675 int num_used = 0; |
| 3676 /* int total_size = 0; */ | |
| 3677 | |
| 3678 /* First go through and call all the finalize methods. | |
| 3679 Then go through and free the objects. There used to | |
| 3680 be only one loop here, with the call to the finalizer | |
| 3681 occurring directly before the xfree() below. That | |
| 3682 is marginally faster but much less safe -- if the | |
| 3683 finalize method for an object needs to reference any | |
| 3684 other objects contained within it (and many do), | |
| 3685 we could easily be screwed by having already freed that | |
| 3686 other object. */ | |
| 3687 | |
| 3688 for (header = *prev; header; header = header->next) | |
| 3689 { | |
| 3690 struct lrecord_header *h = &(header->lheader); | |
| 442 | 3691 |
| 3692 GC_CHECK_LHEADER_INVARIANTS (h); | |
| 3693 | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3694 if (! MARKED_RECORD_HEADER_P (h) && !h->free) |
| 428 | 3695 { |
| 3696 if (LHEADER_IMPLEMENTATION (h)->finalizer) | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3697 LHEADER_IMPLEMENTATION (h)->finalizer (wrap_pointer_1 (h)); |
| 428 | 3698 } |
| 3699 } | |
| 3700 | |
| 3701 for (header = *prev; header; ) | |
| 3702 { | |
| 3703 struct lrecord_header *h = &(header->lheader); | |
| 442 | 3704 if (MARKED_RECORD_HEADER_P (h)) |
| 428 | 3705 { |
| 442 | 3706 if (! C_READONLY_RECORD_HEADER_P (h)) |
| 428 | 3707 UNMARK_RECORD_HEADER (h); |
| 3708 num_used++; | |
| 3709 /* total_size += n->implementation->size_in_bytes (h);*/ | |
| 440 | 3710 /* #### May modify header->next on a C_READONLY lcrecord */ |
| 428 | 3711 prev = &(header->next); |
| 3712 header = *prev; | |
| 3713 tick_lcrecord_stats (h, 0); | |
| 3714 } | |
| 3715 else | |
| 3716 { | |
| 3024 | 3717 struct old_lcrecord_header *next = header->next; |
| 428 | 3718 *prev = next; |
| 3719 tick_lcrecord_stats (h, 1); | |
| 3720 /* used to call finalizer right here. */ | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
3721 xfree (header); |
| 428 | 3722 header = next; |
| 3723 } | |
| 3724 } | |
| 3725 *used = num_used; | |
| 3726 /* *total = total_size; */ | |
| 3727 } | |
| 3728 | |
| 3729 /* And the Lord said: Thou shalt use the `c-backslash-region' command | |
| 3730 to make macros prettier. */ | |
| 3731 | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3732 #define COUNT_FROB_BLOCK_USAGE(type) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3733 EMACS_INT s = 0; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3734 struct type##_block *x = current_##type##_block; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3735 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3736 DO_NOTHING |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3737 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3738 #define COPY_INTO_LRECORD_STATS(type) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3739 do { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3740 COUNT_FROB_BLOCK_USAGE (type); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3741 lrecord_stats[lrecord_type_##type].bytes_in_use += s; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3742 lrecord_stats[lrecord_type_##type].instances_on_free_list += \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3743 gc_count_num_##type##_freelist; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3744 lrecord_stats[lrecord_type_##type].instances_in_use += \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3745 gc_count_num_##type##_in_use; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3746 } while (0) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3747 |
| 428 | 3748 #ifdef ERROR_CHECK_GC |
| 3749 | |
| 771 | 3750 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
| 428 | 3751 do { \ |
| 3752 struct typename##_block *SFTB_current; \ | |
| 3753 int SFTB_limit; \ | |
| 3754 int num_free = 0, num_used = 0; \ | |
| 3755 \ | |
| 444 | 3756 for (SFTB_current = current_##typename##_block, \ |
| 428 | 3757 SFTB_limit = current_##typename##_block_index; \ |
| 3758 SFTB_current; \ | |
| 3759 ) \ | |
| 3760 { \ | |
| 3761 int SFTB_iii; \ | |
| 3762 \ | |
| 3763 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
| 3764 { \ | |
| 3765 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
| 3766 \ | |
| 454 | 3767 if (LRECORD_FREE_P (SFTB_victim)) \ |
| 428 | 3768 { \ |
| 3769 num_free++; \ | |
| 3770 } \ | |
| 3771 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 3772 { \ | |
| 3773 num_used++; \ | |
| 3774 } \ | |
| 442 | 3775 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
| 428 | 3776 { \ |
| 3777 num_free++; \ | |
| 3778 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
| 3779 } \ | |
| 3780 else \ | |
| 3781 { \ | |
| 3782 num_used++; \ | |
| 3783 UNMARK_##typename (SFTB_victim); \ | |
| 3784 } \ | |
| 3785 } \ | |
| 3786 SFTB_current = SFTB_current->prev; \ | |
| 3787 SFTB_limit = countof (current_##typename##_block->block); \ | |
| 3788 } \ | |
| 3789 \ | |
| 3790 gc_count_num_##typename##_in_use = num_used; \ | |
| 3791 gc_count_num_##typename##_freelist = num_free; \ | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3792 COPY_INTO_LRECORD_STATS (typename); \ |
| 428 | 3793 } while (0) |
| 3794 | |
| 3795 #else /* !ERROR_CHECK_GC */ | |
| 3796 | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3797 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3798 do { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3799 struct typename##_block *SFTB_current; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3800 struct typename##_block **SFTB_prev; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3801 int SFTB_limit; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3802 int num_free = 0, num_used = 0; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3803 \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3804 typename##_free_list = 0; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3805 \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3806 for (SFTB_prev = ¤t_##typename##_block, \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3807 SFTB_current = current_##typename##_block, \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3808 SFTB_limit = current_##typename##_block_index; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3809 SFTB_current; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3810 ) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3811 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3812 int SFTB_iii; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3813 int SFTB_empty = 1; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3814 Lisp_Free *SFTB_old_free_list = typename##_free_list; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3815 \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3816 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3817 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3818 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3819 \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3820 if (LRECORD_FREE_P (SFTB_victim)) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3821 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3822 num_free++; \ |
| 771 | 3823 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3824 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3825 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3826 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3827 SFTB_empty = 0; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3828 num_used++; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3829 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3830 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3831 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3832 num_free++; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3833 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3834 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3835 else \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3836 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3837 SFTB_empty = 0; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3838 num_used++; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3839 UNMARK_##typename (SFTB_victim); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3840 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3841 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3842 if (!SFTB_empty) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3843 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3844 SFTB_prev = &(SFTB_current->prev); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3845 SFTB_current = SFTB_current->prev; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3846 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3847 else if (SFTB_current == current_##typename##_block \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3848 && !SFTB_current->prev) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3849 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3850 /* No real point in freeing sole allocation block */ \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3851 break; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3852 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3853 else \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3854 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3855 struct typename##_block *SFTB_victim_block = SFTB_current; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3856 if (SFTB_victim_block == current_##typename##_block) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3857 current_##typename##_block_index \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3858 = countof (current_##typename##_block->block); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3859 SFTB_current = SFTB_current->prev; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3860 { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3861 *SFTB_prev = SFTB_current; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3862 xfree (SFTB_victim_block); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3863 /* Restore free list to what it was before victim was swept */ \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3864 typename##_free_list = SFTB_old_free_list; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3865 num_free -= SFTB_limit; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3866 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3867 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3868 SFTB_limit = countof (current_##typename##_block->block); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3869 } \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3870 \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3871 gc_count_num_##typename##_in_use = num_used; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3872 gc_count_num_##typename##_freelist = num_free; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3873 COPY_INTO_LRECORD_STATS (typename); \ |
| 428 | 3874 } while (0) |
| 3875 | |
| 3876 #endif /* !ERROR_CHECK_GC */ | |
| 3877 | |
| 771 | 3878 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ |
| 3879 SWEEP_FIXED_TYPE_BLOCK_1 (typename, obj_type, lheader) | |
| 3880 | |
| 3263 | 3881 #endif /* not NEW_GC */ |
| 2720 | 3882 |
| 428 | 3883 |
| 3263 | 3884 #ifndef NEW_GC |
| 428 | 3885 static void |
| 3886 sweep_conses (void) | |
| 3887 { | |
| 3888 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3889 #define ADDITIONAL_FREE_cons(ptr) | |
| 3890 | |
| 440 | 3891 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons); |
| 428 | 3892 } |
| 3263 | 3893 #endif /* not NEW_GC */ |
| 428 | 3894 |
| 3895 /* Explicitly free a cons cell. */ | |
| 3896 void | |
| 853 | 3897 free_cons (Lisp_Object cons) |
| 428 | 3898 { |
| 3263 | 3899 #ifndef NEW_GC /* to avoid compiler warning */ |
| 853 | 3900 Lisp_Cons *ptr = XCONS (cons); |
| 3263 | 3901 #endif /* not NEW_GC */ |
| 853 | 3902 |
| 428 | 3903 #ifdef ERROR_CHECK_GC |
| 3263 | 3904 #ifdef NEW_GC |
| 2720 | 3905 Lisp_Cons *ptr = XCONS (cons); |
| 3263 | 3906 #endif /* NEW_GC */ |
| 428 | 3907 /* If the CAR is not an int, then it will be a pointer, which will |
| 3908 always be four-byte aligned. If this cons cell has already been | |
| 3909 placed on the free list, however, its car will probably contain | |
| 3910 a chain pointer to the next cons on the list, which has cleverly | |
| 3911 had all its 0's and 1's inverted. This allows for a quick | |
| 1204 | 3912 check to make sure we're not freeing something already freed. |
| 3913 | |
| 3914 NOTE: This check may not be necessary. Freeing an object sets its | |
| 3915 type to lrecord_type_free, which will trip up the XCONS() above -- as | |
| 3916 well as a check in FREE_FIXED_TYPE(). */ | |
| 853 | 3917 if (POINTER_TYPE_P (XTYPE (cons_car (ptr)))) |
| 3918 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr))); | |
| 428 | 3919 #endif /* ERROR_CHECK_GC */ |
| 3920 | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3921 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, cons, Lisp_Cons, ptr); |
| 428 | 3922 } |
| 3923 | |
| 3924 /* explicitly free a list. You **must make sure** that you have | |
| 3925 created all the cons cells that make up this list and that there | |
| 3926 are no pointers to any of these cons cells anywhere else. If there | |
| 3927 are, you will lose. */ | |
| 3928 | |
| 3929 void | |
| 3930 free_list (Lisp_Object list) | |
| 3931 { | |
| 3932 Lisp_Object rest, next; | |
| 3933 | |
| 3934 for (rest = list; !NILP (rest); rest = next) | |
| 3935 { | |
| 3936 next = XCDR (rest); | |
| 853 | 3937 free_cons (rest); |
| 428 | 3938 } |
| 3939 } | |
| 3940 | |
| 3941 /* explicitly free an alist. You **must make sure** that you have | |
| 3942 created all the cons cells that make up this alist and that there | |
| 3943 are no pointers to any of these cons cells anywhere else. If there | |
| 3944 are, you will lose. */ | |
| 3945 | |
| 3946 void | |
| 3947 free_alist (Lisp_Object alist) | |
| 3948 { | |
| 3949 Lisp_Object rest, next; | |
| 3950 | |
| 3951 for (rest = alist; !NILP (rest); rest = next) | |
| 3952 { | |
| 3953 next = XCDR (rest); | |
| 853 | 3954 free_cons (XCAR (rest)); |
| 3955 free_cons (rest); | |
| 428 | 3956 } |
| 3957 } | |
| 3958 | |
| 3263 | 3959 #ifndef NEW_GC |
| 428 | 3960 static void |
| 3961 sweep_compiled_functions (void) | |
| 3962 { | |
| 3963 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 945 | 3964 #define ADDITIONAL_FREE_compiled_function(ptr) \ |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
3965 if (ptr->args_in_array) xfree (ptr->args) |
| 428 | 3966 |
| 3967 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function); | |
| 3968 } | |
| 3969 | |
| 3970 static void | |
| 3971 sweep_floats (void) | |
| 3972 { | |
| 3973 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3974 #define ADDITIONAL_FREE_float(ptr) | |
| 3975 | |
| 440 | 3976 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float); |
| 428 | 3977 } |
| 3978 | |
| 1983 | 3979 #ifdef HAVE_BIGNUM |
| 3980 static void | |
| 3981 sweep_bignums (void) | |
| 3982 { | |
| 3983 #define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3984 #define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data) | |
| 3985 | |
| 3986 SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum); | |
| 3987 } | |
| 3988 #endif /* HAVE_BIGNUM */ | |
| 3989 | |
| 3990 #ifdef HAVE_RATIO | |
| 3991 static void | |
| 3992 sweep_ratios (void) | |
| 3993 { | |
| 3994 #define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3995 #define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data) | |
| 3996 | |
| 3997 SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio); | |
| 3998 } | |
| 3999 #endif /* HAVE_RATIO */ | |
| 4000 | |
| 4001 #ifdef HAVE_BIGFLOAT | |
| 4002 static void | |
| 4003 sweep_bigfloats (void) | |
| 4004 { | |
| 4005 #define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4006 #define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf) | |
| 4007 | |
| 4008 SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat); | |
| 4009 } | |
| 4010 #endif | |
| 4011 | |
| 428 | 4012 static void |
| 4013 sweep_symbols (void) | |
| 4014 { | |
| 4015 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4016 #define ADDITIONAL_FREE_symbol(ptr) | |
| 4017 | |
| 440 | 4018 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol); |
| 428 | 4019 } |
| 4020 | |
| 4021 static void | |
| 4022 sweep_extents (void) | |
| 4023 { | |
| 4024 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4025 #define ADDITIONAL_FREE_extent(ptr) | |
| 4026 | |
| 4027 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent); | |
| 4028 } | |
| 4029 | |
| 4030 static void | |
| 4031 sweep_events (void) | |
| 4032 { | |
| 4033 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4034 #define ADDITIONAL_FREE_event(ptr) | |
| 4035 | |
| 440 | 4036 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event); |
| 428 | 4037 } |
| 3263 | 4038 #endif /* not NEW_GC */ |
| 428 | 4039 |
| 1204 | 4040 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 4041 |
| 3263 | 4042 #ifndef NEW_GC |
| 934 | 4043 static void |
| 4044 sweep_key_data (void) | |
| 4045 { | |
| 4046 #define UNMARK_key_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4047 #define ADDITIONAL_FREE_key_data(ptr) | |
| 4048 | |
| 4049 SWEEP_FIXED_TYPE_BLOCK (key_data, Lisp_Key_Data); | |
| 4050 } | |
| 3263 | 4051 #endif /* not NEW_GC */ |
| 934 | 4052 |
| 1204 | 4053 void |
| 4054 free_key_data (Lisp_Object ptr) | |
| 4055 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4056 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, key_data, Lisp_Key_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4057 XKEY_DATA (ptr)); |
| 2720 | 4058 } |
| 4059 | |
| 3263 | 4060 #ifndef NEW_GC |
| 934 | 4061 static void |
| 4062 sweep_button_data (void) | |
| 4063 { | |
| 4064 #define UNMARK_button_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4065 #define ADDITIONAL_FREE_button_data(ptr) | |
| 4066 | |
| 4067 SWEEP_FIXED_TYPE_BLOCK (button_data, Lisp_Button_Data); | |
| 4068 } | |
| 3263 | 4069 #endif /* not NEW_GC */ |
| 934 | 4070 |
| 1204 | 4071 void |
| 4072 free_button_data (Lisp_Object ptr) | |
| 4073 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4074 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, button_data, Lisp_Button_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4075 XBUTTON_DATA (ptr)); |
| 2720 | 4076 } |
| 4077 | |
| 3263 | 4078 #ifndef NEW_GC |
| 934 | 4079 static void |
| 4080 sweep_motion_data (void) | |
| 4081 { | |
| 4082 #define UNMARK_motion_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4083 #define ADDITIONAL_FREE_motion_data(ptr) | |
| 4084 | |
| 4085 SWEEP_FIXED_TYPE_BLOCK (motion_data, Lisp_Motion_Data); | |
| 4086 } | |
| 3263 | 4087 #endif /* not NEW_GC */ |
| 934 | 4088 |
| 1204 | 4089 void |
| 4090 free_motion_data (Lisp_Object ptr) | |
| 4091 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4092 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, motion_data, Lisp_Motion_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4093 XMOTION_DATA (ptr)); |
| 2720 | 4094 } |
| 4095 | |
| 3263 | 4096 #ifndef NEW_GC |
| 934 | 4097 static void |
| 4098 sweep_process_data (void) | |
| 4099 { | |
| 4100 #define UNMARK_process_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4101 #define ADDITIONAL_FREE_process_data(ptr) | |
| 4102 | |
| 4103 SWEEP_FIXED_TYPE_BLOCK (process_data, Lisp_Process_Data); | |
| 4104 } | |
| 3263 | 4105 #endif /* not NEW_GC */ |
| 934 | 4106 |
| 1204 | 4107 void |
| 4108 free_process_data (Lisp_Object ptr) | |
| 4109 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4110 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, process_data, Lisp_Process_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4111 XPROCESS_DATA (ptr)); |
| 2720 | 4112 } |
| 4113 | |
| 3263 | 4114 #ifndef NEW_GC |
| 934 | 4115 static void |
| 4116 sweep_timeout_data (void) | |
| 4117 { | |
| 4118 #define UNMARK_timeout_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4119 #define ADDITIONAL_FREE_timeout_data(ptr) | |
| 4120 | |
| 4121 SWEEP_FIXED_TYPE_BLOCK (timeout_data, Lisp_Timeout_Data); | |
| 4122 } | |
| 3263 | 4123 #endif /* not NEW_GC */ |
| 934 | 4124 |
| 1204 | 4125 void |
| 4126 free_timeout_data (Lisp_Object ptr) | |
| 4127 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4128 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, timeout_data, Lisp_Timeout_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4129 XTIMEOUT_DATA (ptr)); |
| 2720 | 4130 } |
| 4131 | |
| 3263 | 4132 #ifndef NEW_GC |
| 934 | 4133 static void |
| 4134 sweep_magic_data (void) | |
| 4135 { | |
| 4136 #define UNMARK_magic_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4137 #define ADDITIONAL_FREE_magic_data(ptr) | |
| 4138 | |
| 4139 SWEEP_FIXED_TYPE_BLOCK (magic_data, Lisp_Magic_Data); | |
| 4140 } | |
| 3263 | 4141 #endif /* not NEW_GC */ |
| 934 | 4142 |
| 1204 | 4143 void |
| 4144 free_magic_data (Lisp_Object ptr) | |
| 4145 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4146 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, magic_data, Lisp_Magic_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4147 XMAGIC_DATA (ptr)); |
| 2720 | 4148 } |
| 4149 | |
| 3263 | 4150 #ifndef NEW_GC |
| 934 | 4151 static void |
| 4152 sweep_magic_eval_data (void) | |
| 4153 { | |
| 4154 #define UNMARK_magic_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4155 #define ADDITIONAL_FREE_magic_eval_data(ptr) | |
| 4156 | |
| 4157 SWEEP_FIXED_TYPE_BLOCK (magic_eval_data, Lisp_Magic_Eval_Data); | |
| 4158 } | |
| 3263 | 4159 #endif /* not NEW_GC */ |
| 934 | 4160 |
| 1204 | 4161 void |
| 4162 free_magic_eval_data (Lisp_Object ptr) | |
| 4163 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4164 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, magic_eval_data, Lisp_Magic_Eval_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4165 XMAGIC_EVAL_DATA (ptr)); |
| 2720 | 4166 } |
| 4167 | |
| 3263 | 4168 #ifndef NEW_GC |
| 934 | 4169 static void |
| 4170 sweep_eval_data (void) | |
| 4171 { | |
| 4172 #define UNMARK_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4173 #define ADDITIONAL_FREE_eval_data(ptr) | |
| 4174 | |
| 4175 SWEEP_FIXED_TYPE_BLOCK (eval_data, Lisp_Eval_Data); | |
| 4176 } | |
| 3263 | 4177 #endif /* not NEW_GC */ |
| 934 | 4178 |
| 1204 | 4179 void |
| 4180 free_eval_data (Lisp_Object ptr) | |
| 4181 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4182 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, eval_data, Lisp_Eval_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4183 XEVAL_DATA (ptr)); |
| 2720 | 4184 } |
| 4185 | |
| 3263 | 4186 #ifndef NEW_GC |
| 934 | 4187 static void |
| 4188 sweep_misc_user_data (void) | |
| 4189 { | |
| 4190 #define UNMARK_misc_user_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4191 #define ADDITIONAL_FREE_misc_user_data(ptr) | |
| 4192 | |
| 4193 SWEEP_FIXED_TYPE_BLOCK (misc_user_data, Lisp_Misc_User_Data); | |
| 4194 } | |
| 3263 | 4195 #endif /* not NEW_GC */ |
| 934 | 4196 |
| 1204 | 4197 void |
| 4198 free_misc_user_data (Lisp_Object ptr) | |
| 4199 { | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4200 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, misc_user_data, Lisp_Misc_User_Data, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4201 XMISC_USER_DATA (ptr)); |
| 1204 | 4202 } |
| 4203 | |
| 4204 #endif /* EVENT_DATA_AS_OBJECTS */ | |
| 934 | 4205 |
| 3263 | 4206 #ifndef NEW_GC |
| 428 | 4207 static void |
| 4208 sweep_markers (void) | |
| 4209 { | |
| 4210 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4211 #define ADDITIONAL_FREE_marker(ptr) \ | |
| 4212 do { Lisp_Object tem; \ | |
| 793 | 4213 tem = wrap_marker (ptr); \ |
| 428 | 4214 unchain_marker (tem); \ |
| 4215 } while (0) | |
| 4216 | |
| 440 | 4217 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker); |
| 428 | 4218 } |
| 3263 | 4219 #endif /* not NEW_GC */ |
| 428 | 4220 |
| 4221 /* Explicitly free a marker. */ | |
| 4222 void | |
| 1204 | 4223 free_marker (Lisp_Object ptr) |
| 428 | 4224 { |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4225 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, marker, Lisp_Marker, XMARKER (ptr)); |
| 428 | 4226 } |
| 4227 | |
| 4228 | |
| 4229 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) | |
| 4230 | |
| 4231 static void | |
| 4232 verify_string_chars_integrity (void) | |
| 4233 { | |
| 4234 struct string_chars_block *sb; | |
| 4235 | |
| 4236 /* Scan each existing string block sequentially, string by string. */ | |
| 4237 for (sb = first_string_chars_block; sb; sb = sb->next) | |
| 4238 { | |
| 4239 int pos = 0; | |
| 4240 /* POS is the index of the next string in the block. */ | |
| 4241 while (pos < sb->pos) | |
| 4242 { | |
| 4243 struct string_chars *s_chars = | |
| 4244 (struct string_chars *) &(sb->string_chars[pos]); | |
| 438 | 4245 Lisp_String *string; |
| 428 | 4246 int size; |
| 4247 int fullsize; | |
| 4248 | |
| 454 | 4249 /* If the string_chars struct is marked as free (i.e. the |
| 4250 STRING pointer is NULL) then this is an unused chunk of | |
| 4251 string storage. (See below.) */ | |
| 4252 | |
| 4253 if (STRING_CHARS_FREE_P (s_chars)) | |
| 428 | 4254 { |
| 4255 fullsize = ((struct unused_string_chars *) s_chars)->fullsize; | |
| 4256 pos += fullsize; | |
| 4257 continue; | |
| 4258 } | |
| 4259 | |
| 4260 string = s_chars->string; | |
| 4261 /* Must be 32-bit aligned. */ | |
| 4262 assert ((((int) string) & 3) == 0); | |
| 4263 | |
| 793 | 4264 size = string->size_; |
| 428 | 4265 fullsize = STRING_FULLSIZE (size); |
| 4266 | |
| 4267 assert (!BIG_STRING_FULLSIZE_P (fullsize)); | |
| 2720 | 4268 assert (XSTRING_DATA (string) == s_chars->chars); |
| 428 | 4269 pos += fullsize; |
| 4270 } | |
| 4271 assert (pos == sb->pos); | |
| 4272 } | |
| 4273 } | |
| 4274 | |
| 1204 | 4275 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */ |
| 428 | 4276 |
| 3092 | 4277 #ifndef NEW_GC |
| 428 | 4278 /* Compactify string chars, relocating the reference to each -- |
| 4279 free any empty string_chars_block we see. */ | |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
4280 static void |
| 428 | 4281 compact_string_chars (void) |
| 4282 { | |
| 4283 struct string_chars_block *to_sb = first_string_chars_block; | |
| 4284 int to_pos = 0; | |
| 4285 struct string_chars_block *from_sb; | |
| 4286 | |
| 4287 /* Scan each existing string block sequentially, string by string. */ | |
| 4288 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next) | |
| 4289 { | |
| 4290 int from_pos = 0; | |
| 4291 /* FROM_POS is the index of the next string in the block. */ | |
| 4292 while (from_pos < from_sb->pos) | |
| 4293 { | |
| 4294 struct string_chars *from_s_chars = | |
| 4295 (struct string_chars *) &(from_sb->string_chars[from_pos]); | |
| 4296 struct string_chars *to_s_chars; | |
| 438 | 4297 Lisp_String *string; |
| 428 | 4298 int size; |
| 4299 int fullsize; | |
| 4300 | |
| 454 | 4301 /* If the string_chars struct is marked as free (i.e. the |
| 4302 STRING pointer is NULL) then this is an unused chunk of | |
| 4303 string storage. This happens under Mule when a string's | |
| 4304 size changes in such a way that its fullsize changes. | |
| 4305 (Strings can change size because a different-length | |
| 4306 character can be substituted for another character.) | |
| 4307 In this case, after the bogus string pointer is the | |
| 4308 "fullsize" of this entry, i.e. how many bytes to skip. */ | |
| 4309 | |
| 4310 if (STRING_CHARS_FREE_P (from_s_chars)) | |
| 428 | 4311 { |
| 4312 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize; | |
| 4313 from_pos += fullsize; | |
| 4314 continue; | |
| 4315 } | |
| 4316 | |
| 4317 string = from_s_chars->string; | |
| 1204 | 4318 gc_checking_assert (!(LRECORD_FREE_P (string))); |
| 428 | 4319 |
| 793 | 4320 size = string->size_; |
| 428 | 4321 fullsize = STRING_FULLSIZE (size); |
| 4322 | |
| 442 | 4323 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize)); |
| 428 | 4324 |
| 4325 /* Just skip it if it isn't marked. */ | |
| 771 | 4326 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader))) |
| 428 | 4327 { |
| 4328 from_pos += fullsize; | |
| 4329 continue; | |
| 4330 } | |
| 4331 | |
| 4332 /* If it won't fit in what's left of TO_SB, close TO_SB out | |
| 4333 and go on to the next string_chars_block. We know that TO_SB | |
| 4334 cannot advance past FROM_SB here since FROM_SB is large enough | |
| 4335 to currently contain this string. */ | |
| 4336 if ((to_pos + fullsize) > countof (to_sb->string_chars)) | |
| 4337 { | |
| 4338 to_sb->pos = to_pos; | |
| 4339 to_sb = to_sb->next; | |
| 4340 to_pos = 0; | |
| 4341 } | |
| 4342 | |
| 4343 /* Compute new address of this string | |
| 4344 and update TO_POS for the space being used. */ | |
| 4345 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]); | |
| 4346 | |
| 4347 /* Copy the string_chars to the new place. */ | |
| 4348 if (from_s_chars != to_s_chars) | |
| 4349 memmove (to_s_chars, from_s_chars, fullsize); | |
| 4350 | |
| 4351 /* Relocate FROM_S_CHARS's reference */ | |
| 826 | 4352 set_lispstringp_data (string, &(to_s_chars->chars[0])); |
| 428 | 4353 |
| 4354 from_pos += fullsize; | |
| 4355 to_pos += fullsize; | |
| 4356 } | |
| 4357 } | |
| 4358 | |
| 4359 /* Set current to the last string chars block still used and | |
| 4360 free any that follow. */ | |
| 4361 { | |
| 4362 struct string_chars_block *victim; | |
| 4363 | |
| 4364 for (victim = to_sb->next; victim; ) | |
| 4365 { | |
| 4366 struct string_chars_block *next = victim->next; | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
4367 xfree (victim); |
| 428 | 4368 victim = next; |
| 4369 } | |
| 4370 | |
| 4371 current_string_chars_block = to_sb; | |
| 4372 current_string_chars_block->pos = to_pos; | |
| 4373 current_string_chars_block->next = 0; | |
| 4374 } | |
| 4375 } | |
| 3092 | 4376 #endif /* not NEW_GC */ |
| 428 | 4377 |
| 3263 | 4378 #ifndef NEW_GC |
| 428 | 4379 #if 1 /* Hack to debug missing purecopy's */ |
| 4380 static int debug_string_purity; | |
| 4381 | |
| 4382 static void | |
| 793 | 4383 debug_string_purity_print (Lisp_Object p) |
| 428 | 4384 { |
| 4385 Charcount i; | |
| 826 | 4386 Charcount s = string_char_length (p); |
| 442 | 4387 stderr_out ("\""); |
| 428 | 4388 for (i = 0; i < s; i++) |
| 4389 { | |
| 867 | 4390 Ichar ch = string_ichar (p, i); |
| 428 | 4391 if (ch < 32 || ch >= 126) |
| 4392 stderr_out ("\\%03o", ch); | |
| 4393 else if (ch == '\\' || ch == '\"') | |
| 4394 stderr_out ("\\%c", ch); | |
| 4395 else | |
| 4396 stderr_out ("%c", ch); | |
| 4397 } | |
| 4398 stderr_out ("\"\n"); | |
| 4399 } | |
| 4400 #endif /* 1 */ | |
| 3263 | 4401 #endif /* not NEW_GC */ |
| 4402 | |
| 4403 #ifndef NEW_GC | |
| 428 | 4404 static void |
| 4405 sweep_strings (void) | |
| 4406 { | |
| 647 | 4407 int num_small_used = 0; |
| 4408 Bytecount num_small_bytes = 0, num_bytes = 0; | |
| 428 | 4409 int debug = debug_string_purity; |
| 4410 | |
| 793 | 4411 #define UNMARK_string(ptr) do { \ |
| 4412 Lisp_String *p = (ptr); \ | |
| 4413 Bytecount size = p->size_; \ | |
| 4414 UNMARK_RECORD_HEADER (&(p->u.lheader)); \ | |
| 4415 num_bytes += size; \ | |
| 4416 if (!BIG_STRING_SIZE_P (size)) \ | |
| 4417 { \ | |
| 4418 num_small_bytes += size; \ | |
| 4419 num_small_used++; \ | |
| 4420 } \ | |
| 4421 if (debug) \ | |
| 4422 debug_string_purity_print (wrap_string (p)); \ | |
| 438 | 4423 } while (0) |
| 4424 #define ADDITIONAL_FREE_string(ptr) do { \ | |
| 793 | 4425 Bytecount size = ptr->size_; \ |
| 438 | 4426 if (BIG_STRING_SIZE_P (size)) \ |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
4427 xfree (ptr->data_); \ |
| 438 | 4428 } while (0) |
| 4429 | |
| 771 | 4430 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader); |
| 428 | 4431 |
| 4432 gc_count_num_short_string_in_use = num_small_used; | |
| 4433 gc_count_string_total_size = num_bytes; | |
| 4434 gc_count_short_string_total_size = num_small_bytes; | |
| 4435 } | |
| 3263 | 4436 #endif /* not NEW_GC */ |
| 428 | 4437 |
| 3092 | 4438 #ifndef NEW_GC |
| 4439 void | |
| 4440 gc_sweep_1 (void) | |
| 428 | 4441 { |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4442 /* Reset all statistics to 0. They will be incremented when |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4443 sweeping lcrecords, frob-block lrecords and dumped objects. */ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4444 xzero (lrecord_stats); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4445 |
| 428 | 4446 /* Free all unmarked records. Do this at the very beginning, |
| 4447 before anything else, so that the finalize methods can safely | |
| 4448 examine items in the objects. sweep_lcrecords_1() makes | |
| 4449 sure to call all the finalize methods *before* freeing anything, | |
| 4450 to complete the safety. */ | |
| 4451 { | |
| 4452 int ignored; | |
| 4453 sweep_lcrecords_1 (&all_lcrecords, &ignored); | |
| 4454 } | |
| 4455 | |
| 4456 compact_string_chars (); | |
| 4457 | |
| 4458 /* Finalize methods below (called through the ADDITIONAL_FREE_foo | |
| 4459 macros) must be *extremely* careful to make sure they're not | |
| 4460 referencing freed objects. The only two existing finalize | |
| 4461 methods (for strings and markers) pass muster -- the string | |
| 4462 finalizer doesn't look at anything but its own specially- | |
| 4463 created block, and the marker finalizer only looks at live | |
| 4464 buffers (which will never be freed) and at the markers before | |
| 4465 and after it in the chain (which, by induction, will never be | |
| 4466 freed because if so, they would have already removed themselves | |
| 4467 from the chain). */ | |
| 4468 | |
| 4469 /* Put all unmarked strings on free list, free'ing the string chars | |
| 4470 of large unmarked strings */ | |
| 4471 sweep_strings (); | |
| 4472 | |
| 4473 /* Put all unmarked conses on free list */ | |
| 4474 sweep_conses (); | |
| 4475 | |
| 4476 /* Free all unmarked compiled-function objects */ | |
| 4477 sweep_compiled_functions (); | |
| 4478 | |
| 4479 /* Put all unmarked floats on free list */ | |
| 4480 sweep_floats (); | |
| 4481 | |
| 1983 | 4482 #ifdef HAVE_BIGNUM |
| 4483 /* Put all unmarked bignums on free list */ | |
| 4484 sweep_bignums (); | |
| 4485 #endif | |
| 4486 | |
| 4487 #ifdef HAVE_RATIO | |
| 4488 /* Put all unmarked ratios on free list */ | |
| 4489 sweep_ratios (); | |
| 4490 #endif | |
| 4491 | |
| 4492 #ifdef HAVE_BIGFLOAT | |
| 4493 /* Put all unmarked bigfloats on free list */ | |
| 4494 sweep_bigfloats (); | |
| 4495 #endif | |
| 4496 | |
| 428 | 4497 /* Put all unmarked symbols on free list */ |
| 4498 sweep_symbols (); | |
| 4499 | |
| 4500 /* Put all unmarked extents on free list */ | |
| 4501 sweep_extents (); | |
| 4502 | |
| 4503 /* Put all unmarked markers on free list. | |
| 4504 Dechain each one first from the buffer into which it points. */ | |
| 4505 sweep_markers (); | |
| 4506 | |
| 4507 sweep_events (); | |
| 4508 | |
| 1204 | 4509 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 4510 sweep_key_data (); |
| 4511 sweep_button_data (); | |
| 4512 sweep_motion_data (); | |
| 4513 sweep_process_data (); | |
| 4514 sweep_timeout_data (); | |
| 4515 sweep_magic_data (); | |
| 4516 sweep_magic_eval_data (); | |
| 4517 sweep_eval_data (); | |
| 4518 sweep_misc_user_data (); | |
| 1204 | 4519 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 3263 | 4520 #endif /* not NEW_GC */ |
| 4521 | |
| 4522 #ifndef NEW_GC | |
| 428 | 4523 #ifdef PDUMP |
| 442 | 4524 pdump_objects_unmark (); |
| 428 | 4525 #endif |
| 4526 } | |
| 3092 | 4527 #endif /* not NEW_GC */ |
| 428 | 4528 |
| 4529 /* Clearing for disksave. */ | |
| 4530 | |
| 4531 void | |
| 4532 disksave_object_finalization (void) | |
| 4533 { | |
| 4534 /* It's important that certain information from the environment not get | |
| 4535 dumped with the executable (pathnames, environment variables, etc.). | |
| 4536 To make it easier to tell when this has happened with strings(1) we | |
| 4537 clear some known-to-be-garbage blocks of memory, so that leftover | |
| 4538 results of old evaluation don't look like potential problems. | |
| 4539 But first we set some notable variables to nil and do one more GC, | |
| 4540 to turn those strings into garbage. | |
| 440 | 4541 */ |
| 428 | 4542 |
| 4543 /* Yeah, this list is pretty ad-hoc... */ | |
| 4544 Vprocess_environment = Qnil; | |
| 771 | 4545 env_initted = 0; |
| 428 | 4546 Vexec_directory = Qnil; |
| 4547 Vdata_directory = Qnil; | |
| 4548 Vsite_directory = Qnil; | |
| 4549 Vdoc_directory = Qnil; | |
| 4550 Vexec_path = Qnil; | |
| 4551 Vload_path = Qnil; | |
| 4552 /* Vdump_load_path = Qnil; */ | |
| 4553 /* Release hash tables for locate_file */ | |
| 4554 Flocate_file_clear_hashing (Qt); | |
| 771 | 4555 uncache_home_directory (); |
| 776 | 4556 zero_out_command_line_status_vars (); |
| 872 | 4557 clear_default_devices (); |
| 428 | 4558 |
| 4559 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \ | |
| 4560 defined(LOADHIST_BUILTIN)) | |
| 4561 Vload_history = Qnil; | |
| 4562 #endif | |
| 4563 Vshell_file_name = Qnil; | |
| 4564 | |
| 3092 | 4565 #ifdef NEW_GC |
| 4566 gc_full (); | |
| 4567 #else /* not NEW_GC */ | |
| 428 | 4568 garbage_collect_1 (); |
| 3092 | 4569 #endif /* not NEW_GC */ |
| 428 | 4570 |
| 4571 /* Run the disksave finalization methods of all live objects. */ | |
| 4572 disksave_object_finalization_1 (); | |
| 4573 | |
| 3092 | 4574 #ifndef NEW_GC |
| 428 | 4575 /* Zero out the uninitialized (really, unused) part of the containers |
| 4576 for the live strings. */ | |
| 4577 { | |
| 4578 struct string_chars_block *scb; | |
| 4579 for (scb = first_string_chars_block; scb; scb = scb->next) | |
| 4580 { | |
| 4581 int count = sizeof (scb->string_chars) - scb->pos; | |
| 4582 | |
| 4583 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE); | |
| 440 | 4584 if (count != 0) |
| 4585 { | |
| 4586 /* from the block's fill ptr to the end */ | |
| 4587 memset ((scb->string_chars + scb->pos), 0, count); | |
| 4588 } | |
| 428 | 4589 } |
| 4590 } | |
| 3092 | 4591 #endif /* not NEW_GC */ |
| 428 | 4592 |
| 4593 /* There, that ought to be enough... */ | |
| 4594 | |
| 4595 } | |
| 4596 | |
| 2994 | 4597 #ifdef ALLOC_TYPE_STATS |
| 4598 | |
| 2720 | 4599 static Lisp_Object |
| 2994 | 4600 gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail) |
| 2720 | 4601 { |
| 4602 /* C doesn't have local functions (or closures, or GC, or readable syntax, | |
| 4603 or portable numeric datatypes, or bit-vectors, or characters, or | |
| 4604 arrays, or exceptions, or ...) */ | |
| 4605 return cons3 (intern (name), make_int (value), tail); | |
| 4606 } | |
| 2775 | 4607 |
|
5058
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4608 /* Pluralize a lowercase English word stored in BUF, assuming BUF has |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4609 enough space to hold the extra letters (at most 2). */ |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4610 static void |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4611 pluralize_word (Ascbyte *buf) |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4612 { |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4613 Bytecount len = strlen (buf); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4614 int upper = 0; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4615 Ascbyte d, e; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4616 |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4617 if (len == 0 || len == 1) |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4618 goto pluralize_apostrophe_s; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4619 e = buf[len - 1]; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4620 d = buf[len - 2]; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4621 upper = isupper (e); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4622 e = tolower (e); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4623 d = tolower (d); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4624 if (e == 'y') |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4625 { |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4626 switch (d) |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4627 { |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4628 case 'a': |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4629 case 'e': |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4630 case 'i': |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4631 case 'o': |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4632 case 'u': |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4633 goto pluralize_s; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4634 default: |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4635 buf[len - 1] = (upper ? 'I' : 'i'); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4636 goto pluralize_es; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4637 } |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4638 } |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4639 else if (e == 's' || e == 'x' || (e == 'h' && (d == 's' || d == 'c'))) |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4640 { |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4641 pluralize_es: |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4642 buf[len++] = (upper ? 'E' : 'e'); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4643 } |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4644 pluralize_s: |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4645 buf[len++] = (upper ? 'S' : 's'); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4646 buf[len] = '\0'; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4647 return; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4648 |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4649 pluralize_apostrophe_s: |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4650 buf[len++] = '\''; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4651 goto pluralize_s; |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4652 } |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4653 |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4654 static void |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4655 pluralize_and_append (Ascbyte *buf, const Ascbyte *name, const Ascbyte *suffix) |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4656 { |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4657 strcpy (buf, name); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4658 pluralize_word (buf); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4659 strcat (buf, suffix); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4660 } |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4661 |
| 2994 | 4662 static Lisp_Object |
| 4663 object_memory_usage_stats (int set_total_gc_usage) | |
| 2720 | 4664 { |
| 4665 Lisp_Object pl = Qnil; | |
| 4666 int i; | |
| 2994 | 4667 EMACS_INT tgu_val = 0; |
| 4668 | |
| 3263 | 4669 #ifdef NEW_GC |
| 2775 | 4670 |
| 3461 | 4671 for (i = 0; i < countof (lrecord_implementations_table); i++) |
| 2720 | 4672 { |
| 4673 if (lrecord_stats[i].instances_in_use != 0) | |
| 4674 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
4675 Ascbyte buf[255]; |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
4676 const Ascbyte *name = lrecord_implementations_table[i]->name; |
| 2720 | 4677 |
| 4678 if (lrecord_stats[i].bytes_in_use_including_overhead != | |
| 4679 lrecord_stats[i].bytes_in_use) | |
| 4680 { | |
| 4681 sprintf (buf, "%s-storage-including-overhead", name); | |
| 4682 pl = gc_plist_hack (buf, | |
| 4683 lrecord_stats[i] | |
| 4684 .bytes_in_use_including_overhead, | |
| 4685 pl); | |
| 4686 } | |
| 4687 | |
| 4688 sprintf (buf, "%s-storage", name); | |
| 4689 pl = gc_plist_hack (buf, | |
| 4690 lrecord_stats[i].bytes_in_use, | |
| 4691 pl); | |
| 2994 | 4692 tgu_val += lrecord_stats[i].bytes_in_use_including_overhead; |
|
5058
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4693 |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4694 pluralize_and_append (buf, name, "-used"); |
| 2720 | 4695 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); |
| 4696 } | |
| 4697 } | |
| 2994 | 4698 |
| 3263 | 4699 #else /* not NEW_GC */ |
| 428 | 4700 |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4701 #define HACK_O_MATIC(type, name, pl) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4702 do { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4703 COUNT_FROB_BLOCK_USAGE (type); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4704 tgu_val += s; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4705 (pl) = gc_plist_hack ((name), s, (pl)); \ |
| 428 | 4706 } while (0) |
| 4707 | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4708 #define FROB(type) \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4709 do { \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4710 COUNT_FROB_BLOCK_USAGE (type); \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4711 tgu_val += s; \ |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4712 } while (0) |
|
5058
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4713 |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4714 FROB (extent); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4715 FROB (event); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4716 FROB (marker); |
|
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4717 FROB (float); |
| 1983 | 4718 #ifdef HAVE_BIGNUM |
|
5058
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4719 FROB (bignum); |
| 1983 | 4720 #endif /* HAVE_BIGNUM */ |
| 4721 #ifdef HAVE_RATIO | |
|
5058
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4722 FROB (ratio); |
| 1983 | 4723 #endif /* HAVE_RATIO */ |
| 4724 #ifdef HAVE_BIGFLOAT | |
|
5058
eb17f0c176ac
clean up a bit the object-memory-usage-stats after gc
Ben Wing <ben@xemacs.org>
parents:
5046
diff
changeset
|
4725 FROB (bigfloat); |
| 1983 | 4726 #endif /* HAVE_BIGFLOAT */ |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4727 FROB (compiled_function); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4728 FROB (symbol); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4729 FROB (cons); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4730 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4731 #undef FROB |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4732 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4733 for (i = 0; i < lrecord_type_count; i++) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4734 { |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4735 if (lrecord_stats[i].bytes_in_use != 0 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4736 || lrecord_stats[i].bytes_freed != 0 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4737 || lrecord_stats[i].instances_on_free_list != 0) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4738 { |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4739 Ascbyte buf[255]; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4740 const Ascbyte *name = lrecord_implementations_table[i]->name; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4741 |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4742 sprintf (buf, "%s-storage", name); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4743 pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use, pl); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4744 tgu_val += lrecord_stats[i].bytes_in_use; |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4745 pluralize_and_append (buf, name, "-freed"); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4746 if (lrecord_stats[i].instances_freed != 0) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4747 pl = gc_plist_hack (buf, lrecord_stats[i].instances_freed, pl); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4748 pluralize_and_append (buf, name, "-on-free-list"); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4749 if (lrecord_stats[i].instances_on_free_list != 0) |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4750 pl = gc_plist_hack (buf, lrecord_stats[i].instances_on_free_list, |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4751 pl); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4752 pluralize_and_append (buf, name, "-used"); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4753 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4754 } |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4755 } |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4756 |
| 428 | 4757 HACK_O_MATIC (string, "string-header-storage", pl); |
| 4758 pl = gc_plist_hack ("long-strings-total-length", | |
| 4759 gc_count_string_total_size | |
| 4760 - gc_count_short_string_total_size, pl); | |
| 4761 HACK_O_MATIC (string_chars, "short-string-storage", pl); | |
| 4762 pl = gc_plist_hack ("short-strings-total-length", | |
| 4763 gc_count_short_string_total_size, pl); | |
| 4764 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl); | |
| 4765 pl = gc_plist_hack ("long-strings-used", | |
| 4766 gc_count_num_string_in_use | |
| 4767 - gc_count_num_short_string_in_use, pl); | |
| 4768 pl = gc_plist_hack ("short-strings-used", | |
| 4769 gc_count_num_short_string_in_use, pl); | |
| 4770 | |
| 2994 | 4771 #undef HACK_O_MATIC |
| 4772 | |
| 3263 | 4773 #endif /* NEW_GC */ |
| 2994 | 4774 |
| 4775 if (set_total_gc_usage) | |
| 4776 { | |
| 4777 total_gc_usage = tgu_val; | |
| 4778 total_gc_usage_set = 1; | |
| 4779 } | |
| 4780 | |
| 4781 return pl; | |
| 4782 } | |
| 4783 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4784 DEFUN ("object-memory-usage-stats", Fobject_memory_usage_stats, 0, 0, 0, /* |
| 2994 | 4785 Return statistics about memory usage of Lisp objects. |
| 4786 */ | |
| 4787 ()) | |
| 4788 { | |
| 4789 return object_memory_usage_stats (0); | |
| 4790 } | |
| 4791 | |
| 4792 #endif /* ALLOC_TYPE_STATS */ | |
| 4793 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4794 #ifdef MEMORY_USAGE_STATS |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4795 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4796 /* Compute the number of extra memory-usage statistics associated with an |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4797 object. We can't compute this at the time INIT_LISP_OBJECT() is called |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4798 because the value of the `memusage_stats_list' property is generally |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4799 set afterwards. So we compute the values for all types of objects |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4800 after all objects have been initialized. */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4801 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4802 static void |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4803 compute_memusage_stats_length (void) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4804 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4805 int i; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4806 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4807 for (i = 0; i < countof (lrecord_implementations_table); i++) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4808 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4809 int len = 0; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4810 struct lrecord_implementation *imp = lrecord_implementations_table[i]; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4811 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4812 if (!imp) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4813 continue; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4814 /* For some of the early objects, Qnil was not yet initialized at |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4815 the time of object initialization, so it came up as Qnull_pointer. |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4816 Fix that now. */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4817 if (EQ (imp->memusage_stats_list, Qnull_pointer)) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4818 imp->memusage_stats_list = Qnil; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4819 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4820 LIST_LOOP_2 (item, imp->memusage_stats_list) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4821 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4822 if (!NILP (item) && !EQ (item, Qt)) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4823 len++; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4824 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4825 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4826 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4827 imp->num_extra_memusage_stats = len; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4828 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4829 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4830 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4831 DEFUN ("object-memory-usage", Fobject_memory_usage, 1, 1, 0, /* |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4832 Return stats about the memory usage of OBJECT. |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4833 The values returned are in the form of an alist of usage types and byte |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4834 counts. The byte counts attempt to encompass all the memory used |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4835 by the object (separate from the memory logically associated with any |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4836 other object), including internal structures and any malloc() |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4837 overhead associated with them. In practice, the byte counts are |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4838 underestimated because certain memory usage is very hard to determine |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4839 \(e.g. the amount of memory used inside the Xt library or inside the |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4840 X server). |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4841 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4842 Multiple slices of the total memory usage may be returned, separated |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4843 by a nil. Each slice represents a particular view of the memory, a |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4844 particular way of partitioning it into groups. Within a slice, there |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4845 is no overlap between the groups of memory, and each slice collectively |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4846 represents all the memory concerned. The rightmost slice typically |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4847 represents the total memory used plus malloc and dynarr overhead. |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4848 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4849 Slices describing other Lisp objects logically associated with the |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4850 object may be included, separated from other slices by `t' and from |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4851 each other by nil if there is more than one. |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4852 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4853 #### We have to figure out how to handle the memory used by the object |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4854 itself vs. the memory used by substructures. Probably the memory_usage |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4855 method should return info only about substructures and related Lisp |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4856 objects, since the caller can always find and all info about the object |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4857 itself. |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4858 */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4859 (object)) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4860 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4861 struct generic_usage_stats gustats; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4862 struct usage_stats object_stats; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4863 int i; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4864 Lisp_Object val = Qnil; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4865 Lisp_Object stats_list = OBJECT_PROPERTY (object, memusage_stats_list); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4866 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4867 xzero (object_stats); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4868 lisp_object_storage_size (object, &object_stats); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4869 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4870 val = acons (Qobject_actually_requested, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4871 make_int (object_stats.was_requested), val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4872 val = acons (Qobject_malloc_overhead, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4873 make_int (object_stats.malloc_overhead), val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4874 assert (!object_stats.dynarr_overhead); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4875 assert (!object_stats.gap_overhead); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4876 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4877 if (!NILP (stats_list)) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4878 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4879 xzero (gustats); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4880 MAYBE_OBJECT_METH (object, memory_usage, (object, &gustats)); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4881 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4882 val = Fcons (Qt, val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4883 val = acons (Qother_memory_actually_requested, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4884 make_int (gustats.u.was_requested), val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4885 val = acons (Qother_memory_malloc_overhead, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4886 make_int (gustats.u.malloc_overhead), val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4887 if (gustats.u.dynarr_overhead) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4888 val = acons (Qother_memory_dynarr_overhead, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4889 make_int (gustats.u.dynarr_overhead), val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4890 if (gustats.u.gap_overhead) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4891 val = acons (Qother_memory_gap_overhead, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4892 make_int (gustats.u.gap_overhead), val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4893 val = Fcons (Qnil, val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4894 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4895 i = 0; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4896 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4897 LIST_LOOP_2 (item, stats_list) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4898 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4899 if (NILP (item) || EQ (item, Qt)) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4900 val = Fcons (item, val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4901 else |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4902 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4903 val = acons (item, make_int (gustats.othervals[i]), val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4904 i++; |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4905 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4906 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4907 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4908 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4909 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4910 return Fnreverse (val); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4911 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4912 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4913 #endif /* MEMORY_USAGE_STATS */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
4914 |
| 2994 | 4915 /* Debugging aids. */ |
| 4916 | |
| 4917 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* | |
| 4918 Reclaim storage for Lisp objects no longer needed. | |
| 4919 Return info on amount of space in use: | |
| 4920 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) | |
| 4921 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS | |
| 4922 PLIST) | |
| 4923 where `PLIST' is a list of alternating keyword/value pairs providing | |
| 4924 more detailed information. | |
| 4925 Garbage collection happens automatically if you cons more than | |
| 4926 `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
| 4927 */ | |
| 4928 ()) | |
| 4929 { | |
| 4930 /* Record total usage for purposes of determining next GC */ | |
| 3092 | 4931 #ifdef NEW_GC |
| 4932 gc_full (); | |
| 4933 #else /* not NEW_GC */ | |
| 2994 | 4934 garbage_collect_1 (); |
| 3092 | 4935 #endif /* not NEW_GC */ |
| 2994 | 4936 |
| 4937 /* This will get set to 1, and total_gc_usage computed, as part of the | |
| 4938 call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */ | |
| 4939 total_gc_usage_set = 0; | |
| 4940 #ifdef ALLOC_TYPE_STATS | |
| 428 | 4941 /* The things we do for backwards-compatibility */ |
| 3263 | 4942 #ifdef NEW_GC |
| 2994 | 4943 return |
| 4944 list6 | |
| 4945 (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use), | |
| 4946 make_int (lrecord_stats[lrecord_type_cons] | |
| 4947 .bytes_in_use_including_overhead)), | |
| 4948 Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use), | |
| 4949 make_int (lrecord_stats[lrecord_type_symbol] | |
| 4950 .bytes_in_use_including_overhead)), | |
| 4951 Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use), | |
| 4952 make_int (lrecord_stats[lrecord_type_marker] | |
| 4953 .bytes_in_use_including_overhead)), | |
| 4954 make_int (lrecord_stats[lrecord_type_string] | |
| 4955 .bytes_in_use_including_overhead), | |
| 4956 make_int (lrecord_stats[lrecord_type_vector] | |
| 4957 .bytes_in_use_including_overhead), | |
| 4958 object_memory_usage_stats (1)); | |
| 3263 | 4959 #else /* not NEW_GC */ |
| 428 | 4960 return |
| 4961 list6 (Fcons (make_int (gc_count_num_cons_in_use), | |
| 4962 make_int (gc_count_num_cons_freelist)), | |
| 4963 Fcons (make_int (gc_count_num_symbol_in_use), | |
| 4964 make_int (gc_count_num_symbol_freelist)), | |
| 4965 Fcons (make_int (gc_count_num_marker_in_use), | |
| 4966 make_int (gc_count_num_marker_freelist)), | |
| 4967 make_int (gc_count_string_total_size), | |
|
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4968 make_int (lrecord_stats[lrecord_type_vector].bytes_in_use + |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4969 lrecord_stats[lrecord_type_vector].bytes_freed + |
|
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4970 lrecord_stats[lrecord_type_vector].bytes_on_free_list), |
| 2994 | 4971 object_memory_usage_stats (1)); |
| 3263 | 4972 #endif /* not NEW_GC */ |
| 2994 | 4973 #else /* not ALLOC_TYPE_STATS */ |
| 4974 return Qnil; | |
| 4975 #endif /* ALLOC_TYPE_STATS */ | |
| 4976 } | |
| 428 | 4977 |
| 4978 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /* | |
| 4979 Return the number of bytes consed since the last garbage collection. | |
| 4980 \"Consed\" is a misnomer in that this actually counts allocation | |
| 4981 of all different kinds of objects, not just conses. | |
| 4982 | |
| 4983 If this value exceeds `gc-cons-threshold', a garbage collection happens. | |
| 4984 */ | |
| 4985 ()) | |
| 4986 { | |
| 4987 return make_int (consing_since_gc); | |
| 4988 } | |
| 4989 | |
| 440 | 4990 #if 0 |
| 444 | 4991 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /* |
| 801 | 4992 Return the address of the last byte XEmacs has allocated, divided by 1024. |
| 4993 This may be helpful in debugging XEmacs's memory usage. | |
| 428 | 4994 The value is divided by 1024 to make sure it will fit in a lisp integer. |
| 4995 */ | |
| 4996 ()) | |
| 4997 { | |
| 4998 return make_int ((EMACS_INT) sbrk (0) / 1024); | |
| 4999 } | |
| 440 | 5000 #endif |
| 428 | 5001 |
| 2994 | 5002 DEFUN ("total-memory-usage", Ftotal_memory_usage, 0, 0, 0, /* |
| 801 | 5003 Return the total number of bytes used by the data segment in XEmacs. |
| 5004 This may be helpful in debugging XEmacs's memory usage. | |
| 2994 | 5005 NOTE: This may or may not be accurate! It is hard to determine this |
| 5006 value in a system-independent fashion. On Windows, for example, the | |
| 5007 returned number tends to be much greater than reality. | |
| 801 | 5008 */ |
| 5009 ()) | |
| 5010 { | |
| 5011 return make_int (total_data_usage ()); | |
| 5012 } | |
| 5013 | |
| 2994 | 5014 #ifdef ALLOC_TYPE_STATS |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5015 DEFUN ("total-object-memory-usage", Ftotal_object_memory_usage, 0, 0, 0, /* |
| 2994 | 5016 Return total number of bytes used for object storage in XEmacs. |
| 5017 This may be helpful in debugging XEmacs's memory usage. | |
| 5018 See also `consing-since-gc' and `object-memory-usage-stats'. | |
| 5019 */ | |
| 5020 ()) | |
| 5021 { | |
| 5022 return make_int (total_gc_usage + consing_since_gc); | |
| 5023 } | |
| 5024 #endif /* ALLOC_TYPE_STATS */ | |
| 5025 | |
|
4803
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5026 #ifdef USE_VALGRIND |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5027 DEFUN ("valgrind-leak-check", Fvalgrind_leak_check, 0, 0, "", /* |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5028 Ask valgrind to perform a memory leak check. |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5029 The results of the leak check are sent to stderr. |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5030 */ |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5031 ()) |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5032 { |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5033 VALGRIND_DO_LEAK_CHECK; |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5034 return Qnil; |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5035 } |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5036 |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5037 DEFUN ("valgrind-quick-leak-check", Fvalgrind_quick_leak_check, 0, 0, "", /* |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5038 Ask valgrind to perform a quick memory leak check. |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5039 This just prints a summary of leaked memory, rather than all the details. |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5040 The results of the leak check are sent to stderr. |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5041 */ |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5042 ()) |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5043 { |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5044 VALGRIND_DO_QUICK_LEAK_CHECK; |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5045 return Qnil; |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5046 } |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5047 #endif /* USE_VALGRIND */ |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5048 |
| 851 | 5049 void |
| 5050 recompute_funcall_allocation_flag (void) | |
| 5051 { | |
| 887 | 5052 funcall_allocation_flag = |
| 5053 need_to_garbage_collect || | |
| 5054 need_to_check_c_alloca || | |
| 5055 need_to_signal_post_gc; | |
| 851 | 5056 } |
| 5057 | |
| 428 | 5058 |
| 5059 int | |
| 5060 object_dead_p (Lisp_Object obj) | |
| 5061 { | |
| 5062 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) || | |
| 5063 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) || | |
| 5064 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) || | |
| 5065 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) || | |
| 5066 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) || | |
| 5067 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) || | |
| 5068 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj)))); | |
| 5069 } | |
| 5070 | |
| 5071 #ifdef MEMORY_USAGE_STATS | |
| 5072 | |
| 5073 /* Attempt to determine the actual amount of space that is used for | |
| 5074 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE". | |
| 5075 | |
| 5076 It seems that the following holds: | |
| 5077 | |
| 5078 1. When using the old allocator (malloc.c): | |
| 5079 | |
| 5080 -- blocks are always allocated in chunks of powers of two. For | |
| 5081 each block, there is an overhead of 8 bytes if rcheck is not | |
| 5082 defined, 20 bytes if it is defined. In other words, a | |
| 5083 one-byte allocation needs 8 bytes of overhead for a total of | |
| 5084 9 bytes, and needs to have 16 bytes of memory chunked out for | |
| 5085 it. | |
| 5086 | |
| 5087 2. When using the new allocator (gmalloc.c): | |
| 5088 | |
| 5089 -- blocks are always allocated in chunks of powers of two up | |
| 5090 to 4096 bytes. Larger blocks are allocated in chunks of | |
| 5091 an integral multiple of 4096 bytes. The minimum block | |
| 5092 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG | |
| 5093 is defined. There is no per-block overhead, but there | |
| 5094 is an overhead of 3*sizeof (size_t) for each 4096 bytes | |
| 5095 allocated. | |
| 5096 | |
| 5097 3. When using the system malloc, anything goes, but they are | |
| 5098 generally slower and more space-efficient than the GNU | |
| 5099 allocators. One possibly reasonable assumption to make | |
| 5100 for want of better data is that sizeof (void *), or maybe | |
| 5101 2 * sizeof (void *), is required as overhead and that | |
| 5102 blocks are allocated in the minimum required size except | |
| 5103 that some minimum block size is imposed (e.g. 16 bytes). */ | |
| 5104 | |
| 665 | 5105 Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
5106 malloced_storage_size (void * UNUSED (ptr), Bytecount claimed_size, |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5107 struct usage_stats *stats) |
| 428 | 5108 { |
| 665 | 5109 Bytecount orig_claimed_size = claimed_size; |
| 428 | 5110 |
|
4735
80d74fed5399
Remove "old" GNU malloc in src/malloc.c, and all references to it. Drop the
Jerry James <james@xemacs.org>
parents:
4693
diff
changeset
|
5111 #ifndef SYSTEM_MALLOC |
| 665 | 5112 if (claimed_size < (Bytecount) (2 * sizeof (void *))) |
| 428 | 5113 claimed_size = 2 * sizeof (void *); |
| 5114 # ifdef SUNOS_LOCALTIME_BUG | |
| 5115 if (claimed_size < 16) | |
| 5116 claimed_size = 16; | |
| 5117 # endif | |
| 5118 if (claimed_size < 4096) | |
| 5119 { | |
| 2260 | 5120 /* fxg: rename log->log2 to supress gcc3 shadow warning */ |
| 5121 int log2 = 1; | |
| 428 | 5122 |
| 5123 /* compute the log base two, more or less, then use it to compute | |
| 5124 the block size needed. */ | |
| 5125 claimed_size--; | |
| 5126 /* It's big, it's heavy, it's wood! */ | |
| 5127 while ((claimed_size /= 2) != 0) | |
| 2260 | 5128 ++log2; |
| 428 | 5129 claimed_size = 1; |
| 5130 /* It's better than bad, it's good! */ | |
| 2260 | 5131 while (log2 > 0) |
| 428 | 5132 { |
| 5133 claimed_size *= 2; | |
| 2260 | 5134 log2--; |
| 428 | 5135 } |
| 5136 /* We have to come up with some average about the amount of | |
| 5137 blocks used. */ | |
| 665 | 5138 if ((Bytecount) (rand () & 4095) < claimed_size) |
| 428 | 5139 claimed_size += 3 * sizeof (void *); |
| 5140 } | |
| 5141 else | |
| 5142 { | |
| 5143 claimed_size += 4095; | |
| 5144 claimed_size &= ~4095; | |
| 5145 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t); | |
| 5146 } | |
| 5147 | |
|
4735
80d74fed5399
Remove "old" GNU malloc in src/malloc.c, and all references to it. Drop the
Jerry James <james@xemacs.org>
parents:
4693
diff
changeset
|
5148 #else |
| 428 | 5149 |
| 5150 if (claimed_size < 16) | |
| 5151 claimed_size = 16; | |
| 5152 claimed_size += 2 * sizeof (void *); | |
| 5153 | |
|
4735
80d74fed5399
Remove "old" GNU malloc in src/malloc.c, and all references to it. Drop the
Jerry James <james@xemacs.org>
parents:
4693
diff
changeset
|
5154 #endif /* system allocator */ |
| 428 | 5155 |
| 5156 if (stats) | |
| 5157 { | |
| 5158 stats->was_requested += orig_claimed_size; | |
| 5159 stats->malloc_overhead += claimed_size - orig_claimed_size; | |
| 5160 } | |
| 5161 return claimed_size; | |
| 5162 } | |
| 5163 | |
| 3263 | 5164 #ifndef NEW_GC |
| 665 | 5165 Bytecount |
| 5166 fixed_type_block_overhead (Bytecount size) | |
| 428 | 5167 { |
| 665 | 5168 Bytecount per_block = TYPE_ALLOC_SIZE (cons, unsigned char); |
| 5169 Bytecount overhead = 0; | |
| 5170 Bytecount storage_size = malloced_storage_size (0, per_block, 0); | |
| 428 | 5171 while (size >= per_block) |
| 5172 { | |
| 5173 size -= per_block; | |
| 5174 overhead += sizeof (void *) + per_block - storage_size; | |
| 5175 } | |
| 5176 if (rand () % per_block < size) | |
| 5177 overhead += sizeof (void *) + per_block - storage_size; | |
| 5178 return overhead; | |
| 5179 } | |
| 3263 | 5180 #endif /* not NEW_GC */ |
| 428 | 5181 #endif /* MEMORY_USAGE_STATS */ |
| 5182 | |
| 5183 | |
| 5184 /* Initialization */ | |
| 771 | 5185 static void |
| 1204 | 5186 common_init_alloc_early (void) |
| 428 | 5187 { |
| 771 | 5188 #ifndef Qzero |
| 5189 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ | |
| 5190 #endif | |
| 5191 | |
| 5192 #ifndef Qnull_pointer | |
| 5193 /* C guarantees that Qnull_pointer will be initialized to all 0 bits, | |
| 5194 so the following is actually a no-op. */ | |
| 793 | 5195 Qnull_pointer = wrap_pointer_1 (0); |
| 771 | 5196 #endif |
| 5197 | |
| 3263 | 5198 #ifndef NEW_GC |
| 428 | 5199 breathing_space = 0; |
| 5200 all_lcrecords = 0; | |
| 3263 | 5201 #endif /* not NEW_GC */ |
| 428 | 5202 ignore_malloc_warnings = 1; |
| 5203 #ifdef DOUG_LEA_MALLOC | |
| 5204 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ | |
| 5205 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ | |
| 5206 #if 0 /* Moved to emacs.c */ | |
| 5207 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */ | |
| 5208 #endif | |
| 5209 #endif | |
| 3092 | 5210 #ifndef NEW_GC |
| 2720 | 5211 init_string_chars_alloc (); |
| 428 | 5212 init_string_alloc (); |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5213 /* #### Is it intentional that this is called twice? --ben */ |
| 428 | 5214 init_string_chars_alloc (); |
| 5215 init_cons_alloc (); | |
| 5216 init_symbol_alloc (); | |
| 5217 init_compiled_function_alloc (); | |
| 5218 init_float_alloc (); | |
| 1983 | 5219 #ifdef HAVE_BIGNUM |
| 5220 init_bignum_alloc (); | |
| 5221 #endif | |
| 5222 #ifdef HAVE_RATIO | |
| 5223 init_ratio_alloc (); | |
| 5224 #endif | |
| 5225 #ifdef HAVE_BIGFLOAT | |
| 5226 init_bigfloat_alloc (); | |
| 5227 #endif | |
| 428 | 5228 init_marker_alloc (); |
| 5229 init_extent_alloc (); | |
| 5230 init_event_alloc (); | |
| 1204 | 5231 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 5232 init_key_data_alloc (); |
| 5233 init_button_data_alloc (); | |
| 5234 init_motion_data_alloc (); | |
| 5235 init_process_data_alloc (); | |
| 5236 init_timeout_data_alloc (); | |
| 5237 init_magic_data_alloc (); | |
| 5238 init_magic_eval_data_alloc (); | |
| 5239 init_eval_data_alloc (); | |
| 5240 init_misc_user_data_alloc (); | |
| 1204 | 5241 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 3263 | 5242 #endif /* not NEW_GC */ |
| 428 | 5243 |
| 5244 ignore_malloc_warnings = 0; | |
| 5245 | |
| 452 | 5246 if (staticpros_nodump) |
| 5247 Dynarr_free (staticpros_nodump); | |
| 5248 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); | |
| 5249 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */ | |
| 771 | 5250 #ifdef DEBUG_XEMACS |
| 5251 if (staticpro_nodump_names) | |
| 5252 Dynarr_free (staticpro_nodump_names); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5253 staticpro_nodump_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5254 const Ascbyte *); |
| 771 | 5255 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */ |
| 5256 #endif | |
| 428 | 5257 |
| 3263 | 5258 #ifdef NEW_GC |
| 2720 | 5259 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); |
| 5260 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
| 5261 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
| 5262 #ifdef DEBUG_XEMACS | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5263 mcpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *); |
| 2720 | 5264 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5265 dump_add_root_block_ptr (&mcpro_names, |
| 4964 | 5266 &const_Ascbyte_ptr_dynarr_description); |
| 2720 | 5267 #endif |
| 3263 | 5268 #endif /* NEW_GC */ |
| 2720 | 5269 |
| 428 | 5270 consing_since_gc = 0; |
| 851 | 5271 need_to_check_c_alloca = 0; |
| 5272 funcall_allocation_flag = 0; | |
| 5273 funcall_alloca_count = 0; | |
| 814 | 5274 |
| 3263 | 5275 #ifndef NEW_GC |
| 428 | 5276 debug_string_purity = 0; |
| 3263 | 5277 #endif /* not NEW_GC */ |
| 428 | 5278 |
| 800 | 5279 #ifdef ERROR_CHECK_TYPES |
| 428 | 5280 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = |
| 5281 666; | |
| 5282 ERROR_ME_NOT. | |
| 5283 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42; | |
| 5284 ERROR_ME_WARN. | |
| 5285 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 5286 3333632; | |
| 793 | 5287 ERROR_ME_DEBUG_WARN. |
| 5288 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 5289 8675309; | |
| 800 | 5290 #endif /* ERROR_CHECK_TYPES */ |
| 428 | 5291 } |
| 5292 | |
| 3263 | 5293 #ifndef NEW_GC |
| 771 | 5294 static void |
| 5295 init_lcrecord_lists (void) | |
| 5296 { | |
| 5297 int i; | |
| 5298 | |
| 5299 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 5300 { | |
| 5301 all_lcrecord_lists[i] = Qzero; /* Qnil not yet set */ | |
| 5302 staticpro_nodump (&all_lcrecord_lists[i]); | |
| 5303 } | |
| 5304 } | |
| 3263 | 5305 #endif /* not NEW_GC */ |
| 771 | 5306 |
| 5307 void | |
| 1204 | 5308 init_alloc_early (void) |
| 771 | 5309 { |
| 1204 | 5310 #if defined (__cplusplus) && defined (ERROR_CHECK_GC) |
| 5311 static struct gcpro initial_gcpro; | |
| 5312 | |
| 5313 initial_gcpro.next = 0; | |
| 5314 initial_gcpro.var = &Qnil; | |
| 5315 initial_gcpro.nvars = 1; | |
| 5316 gcprolist = &initial_gcpro; | |
| 5317 #else | |
| 5318 gcprolist = 0; | |
| 5319 #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */ | |
| 5320 } | |
| 5321 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5322 static void |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5323 reinit_alloc_objects_early (void) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5324 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5325 OBJECT_HAS_METHOD (string, getprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5326 OBJECT_HAS_METHOD (string, putprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5327 OBJECT_HAS_METHOD (string, remprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5328 OBJECT_HAS_METHOD (string, plist); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5329 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5330 |
| 1204 | 5331 void |
| 5332 reinit_alloc_early (void) | |
| 5333 { | |
| 5334 common_init_alloc_early (); | |
| 3263 | 5335 #ifndef NEW_GC |
| 771 | 5336 init_lcrecord_lists (); |
| 3263 | 5337 #endif /* not NEW_GC */ |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5338 reinit_alloc_objects_early (); |
| 771 | 5339 } |
| 5340 | |
| 428 | 5341 void |
| 5342 init_alloc_once_early (void) | |
| 5343 { | |
| 1204 | 5344 common_init_alloc_early (); |
| 428 | 5345 |
| 442 | 5346 { |
| 5347 int i; | |
| 5348 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 5349 lrecord_implementations_table[i] = 0; | |
| 5350 } | |
| 5351 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
5352 dump_add_opaque (lrecord_uid_counter, sizeof (lrecord_uid_counter)); |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
5353 |
| 452 | 5354 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); |
| 5355 Dynarr_resize (staticpros, 1410); /* merely a small optimization */ | |
| 2367 | 5356 dump_add_root_block_ptr (&staticpros, &staticpros_description); |
| 771 | 5357 #ifdef DEBUG_XEMACS |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5358 staticpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *); |
| 771 | 5359 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5360 dump_add_root_block_ptr (&staticpro_names, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5361 &const_Ascbyte_ptr_dynarr_description); |
| 771 | 5362 #endif |
| 5363 | |
| 3263 | 5364 #ifdef NEW_GC |
| 2720 | 5365 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); |
| 5366 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
| 5367 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
| 5368 #ifdef DEBUG_XEMACS | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5369 mcpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *); |
| 2720 | 5370 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5371 dump_add_root_block_ptr (&mcpro_names, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5372 &const_Ascbyte_ptr_dynarr_description); |
| 2720 | 5373 #endif |
| 3263 | 5374 #else /* not NEW_GC */ |
| 771 | 5375 init_lcrecord_lists (); |
| 3263 | 5376 #endif /* not NEW_GC */ |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5377 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5378 INIT_LISP_OBJECT (cons); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5379 INIT_LISP_OBJECT (vector); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5380 INIT_LISP_OBJECT (string); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5381 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5382 #ifdef NEW_GC |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5383 INIT_LISP_OBJECT (string_indirect_data); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5384 INIT_LISP_OBJECT (string_direct_data); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5385 #endif /* NEW_GC */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5386 #ifndef NEW_GC |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5387 INIT_LISP_OBJECT (lcrecord_list); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5388 INIT_LISP_OBJECT (free); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5389 #endif /* not NEW_GC */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5390 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5391 reinit_alloc_objects_early (); |
| 428 | 5392 } |
| 5393 | |
| 5394 void | |
| 5395 syms_of_alloc (void) | |
| 5396 { | |
| 442 | 5397 DEFSYMBOL (Qgarbage_collecting); |
| 428 | 5398 |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5399 #ifdef MEMORY_USAGE_STATS |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5400 DEFSYMBOL (Qobject_actually_requested); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5401 DEFSYMBOL (Qobject_malloc_overhead); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5402 DEFSYMBOL (Qother_memory_actually_requested); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5403 DEFSYMBOL (Qother_memory_malloc_overhead); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5404 DEFSYMBOL (Qother_memory_dynarr_overhead); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5405 DEFSYMBOL (Qother_memory_gap_overhead); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5406 #endif /* MEMORY_USAGE_STATS */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5407 |
| 428 | 5408 DEFSUBR (Fcons); |
| 5409 DEFSUBR (Flist); | |
| 5410 DEFSUBR (Fvector); | |
| 5411 DEFSUBR (Fbit_vector); | |
| 5412 DEFSUBR (Fmake_byte_code); | |
| 5413 DEFSUBR (Fmake_list); | |
| 5414 DEFSUBR (Fmake_vector); | |
| 5415 DEFSUBR (Fmake_bit_vector); | |
| 5416 DEFSUBR (Fmake_string); | |
| 5417 DEFSUBR (Fstring); | |
| 5418 DEFSUBR (Fmake_symbol); | |
| 5419 DEFSUBR (Fmake_marker); | |
| 5420 DEFSUBR (Fpurecopy); | |
| 2994 | 5421 #ifdef ALLOC_TYPE_STATS |
| 5422 DEFSUBR (Fobject_memory_usage_stats); | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5423 DEFSUBR (Ftotal_object_memory_usage); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5424 #endif /* ALLOC_TYPE_STATS */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5425 #ifdef MEMORY_USAGE_STATS |
| 2994 | 5426 DEFSUBR (Fobject_memory_usage); |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5427 #endif /* MEMORY_USAGE_STATS */ |
| 428 | 5428 DEFSUBR (Fgarbage_collect); |
| 440 | 5429 #if 0 |
| 428 | 5430 DEFSUBR (Fmemory_limit); |
| 440 | 5431 #endif |
| 2994 | 5432 DEFSUBR (Ftotal_memory_usage); |
| 428 | 5433 DEFSUBR (Fconsing_since_gc); |
|
4803
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5434 #ifdef USE_VALGRIND |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5435 DEFSUBR (Fvalgrind_leak_check); |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5436 DEFSUBR (Fvalgrind_quick_leak_check); |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5437 #endif |
| 428 | 5438 } |
| 5439 | |
| 5440 void | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5441 reinit_vars_of_alloc (void) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5442 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5443 #ifdef MEMORY_USAGE_STATS |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5444 compute_memusage_stats_length (); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5445 #endif /* MEMORY_USAGE_STATS */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5446 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5447 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5448 void |
| 428 | 5449 vars_of_alloc (void) |
| 5450 { | |
| 5451 #ifdef DEBUG_XEMACS | |
| 5452 DEFVAR_INT ("debug-allocation", &debug_allocation /* | |
| 5453 If non-zero, print out information to stderr about all objects allocated. | |
| 5454 See also `debug-allocation-backtrace-length'. | |
| 5455 */ ); | |
| 5456 debug_allocation = 0; | |
| 5457 | |
| 5458 DEFVAR_INT ("debug-allocation-backtrace-length", | |
| 5459 &debug_allocation_backtrace_length /* | |
| 5460 Length (in stack frames) of short backtrace printed out by `debug-allocation'. | |
| 5461 */ ); | |
| 5462 debug_allocation_backtrace_length = 2; | |
| 5463 #endif | |
| 5464 | |
| 5465 DEFVAR_BOOL ("purify-flag", &purify_flag /* | |
| 5466 Non-nil means loading Lisp code in order to dump an executable. | |
| 5467 This means that certain objects should be allocated in readonly space. | |
| 5468 */ ); | |
| 5469 } |