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