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