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