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