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