Mercurial > hg > xemacs-beta
annotate src/alloc.c @ 4843:715b15990d0a
add more foo_checking_assert macros
lisp.h: Add structure_checking_assert(), gc_checking_assert(), etc. for
all types of error-checking. Also FOO_checking_assert_with_message()
and inline_FOO_checking_assert() -- the latter for use in an inline
function where you want the calling function's line/file to be reported
(requires some conspiracy with the function itself).
Add disabled_assert(), disabled_assert_at_line(),
disabled_assert_with_message(), for what to do when an assert is
disabled. Formerly, we used to do ((void) 0), but now we do
((void) x), so the variable appears used and any side effects of the
expression do get done. In Unicode-internal, the standard assert()
uses this, but not yet in this workspace.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Wed, 13 Jan 2010 03:01:43 -0600 |
| parents | 5d120deb60ca |
| children | ae81a2c00f4f |
| rev | line source |
|---|---|
| 428 | 1 /* Storage allocation and gc for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1998 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 2994 | 4 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from | |
| 24 FSF. */ | |
| 25 | |
| 26 /* Authorship: | |
| 27 | |
| 28 FSF: Original version; a long time ago. | |
| 29 Mly: Significantly rewritten to use new 3-bit tags and | |
| 30 nicely abstracted object definitions, for 19.8. | |
| 31 JWZ: Improved code to keep track of purespace usage and | |
| 32 issue nice purespace and GC stats. | |
| 33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking | |
| 34 and various changes for Mule, for 19.12. | |
| 35 Added bit vectors for 19.13. | |
| 36 Added lcrecord lists for 19.14. | |
| 37 slb: Lots of work on the purification and dump time code. | |
| 38 Synched Doug Lea malloc support from Emacs 20.2. | |
| 442 | 39 og: Killed the purespace. Portable dumper (moved to dumper.c) |
| 428 | 40 */ |
| 41 | |
| 42 #include <config.h> | |
| 43 #include "lisp.h" | |
| 44 | |
| 45 #include "backtrace.h" | |
| 46 #include "buffer.h" | |
| 47 #include "bytecode.h" | |
| 48 #include "chartab.h" | |
| 49 #include "device.h" | |
| 50 #include "elhash.h" | |
| 51 #include "events.h" | |
| 872 | 52 #include "extents-impl.h" |
| 1204 | 53 #include "file-coding.h" |
| 872 | 54 #include "frame-impl.h" |
| 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 | |
| 771 | 3120 /* Finalizer methods may try to free objects within them, which typically |
| 3121 won't be marked and thus are scheduled for demolition. Putting them | |
| 3122 on the free list would be very bad, as we'd have xfree()d memory in | |
| 3123 the list. Even if for some reason the objects are still live | |
| 3124 (generally a logic error!), we still will have problems putting such | |
| 3125 an object on the free list right now (e.g. we'd have to avoid calling | |
| 3126 the finalizer twice, etc.). So basically, those finalizers should not | |
| 3127 be freeing any objects if during GC. Abort now to catch those | |
| 3128 problems. */ | |
| 3129 gc_checking_assert (!gc_in_progress); | |
| 3130 | |
| 428 | 3131 /* Make sure the size is correct. This will catch, for example, |
| 3132 putting a window configuration on the wrong free list. */ | |
| 1204 | 3133 gc_checking_assert (detagged_lisp_object_size (lheader) == list->size); |
| 771 | 3134 /* Make sure the object isn't already freed. */ |
| 3135 gc_checking_assert (!free_header->lcheader.free); | |
| 2367 | 3136 /* Freeing stuff in dumped memory is bad. If you trip this, you |
| 3137 may need to check for this before freeing. */ | |
| 3138 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord)); | |
| 771 | 3139 |
| 428 | 3140 if (implementation->finalizer) |
| 3141 implementation->finalizer (lheader, 0); | |
| 1204 | 3142 /* Yes, there are two ways to indicate freeness -- the type is |
| 3143 lrecord_type_free or the ->free flag is set. We used to do only the | |
| 3144 latter; now we do the former as well for KKCC purposes. Probably | |
| 3145 safer in any case, as we will lose quicker this way than keeping | |
| 3146 around an lrecord of apparently correct type but bogus junk in it. */ | |
| 3147 MARK_LRECORD_AS_FREE (lheader); | |
| 428 | 3148 free_header->chain = list->free; |
| 3149 free_header->lcheader.free = 1; | |
| 3150 list->free = lcrecord; | |
| 3151 } | |
| 3152 | |
| 771 | 3153 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)]; |
| 3154 | |
| 3155 void * | |
| 3156 alloc_automanaged_lcrecord (Bytecount size, | |
| 3157 const struct lrecord_implementation *imp) | |
| 3158 { | |
| 3159 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero)) | |
| 3160 all_lcrecord_lists[imp->lrecord_type_index] = | |
| 3161 make_lcrecord_list (size, imp); | |
| 3162 | |
| 1204 | 3163 return XPNTR (alloc_managed_lcrecord |
| 771 | 3164 (all_lcrecord_lists[imp->lrecord_type_index])); |
| 3165 } | |
| 3166 | |
| 3167 void | |
| 3024 | 3168 old_free_lcrecord (Lisp_Object rec) |
| 771 | 3169 { |
| 3170 int type = XRECORD_LHEADER (rec)->type; | |
| 3171 | |
| 3172 assert (!EQ (all_lcrecord_lists[type], Qzero)); | |
| 3173 | |
| 3174 free_managed_lcrecord (all_lcrecord_lists[type], rec); | |
| 3175 } | |
| 3263 | 3176 #endif /* not NEW_GC */ |
| 428 | 3177 |
| 3178 | |
| 3179 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /* | |
| 3180 Kept for compatibility, returns its argument. | |
| 3181 Old: | |
| 3182 Make a copy of OBJECT in pure storage. | |
| 3183 Recursively copies contents of vectors and cons cells. | |
| 3184 Does not copy symbols. | |
| 3185 */ | |
| 444 | 3186 (object)) |
| 428 | 3187 { |
| 444 | 3188 return object; |
| 428 | 3189 } |
| 3190 | |
| 3191 | |
| 3192 /************************************************************************/ | |
| 3193 /* Garbage Collection */ | |
| 3194 /************************************************************************/ | |
| 3195 | |
| 442 | 3196 /* All the built-in lisp object types are enumerated in `enum lrecord_type'. |
| 3197 Additional ones may be defined by a module (none yet). We leave some | |
| 3198 room in `lrecord_implementations_table' for such new lisp object types. */ | |
| 647 | 3199 const struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; |
| 3200 int lrecord_type_count = lrecord_type_last_built_in_type; | |
| 1676 | 3201 #ifndef USE_KKCC |
| 442 | 3202 /* Object marker functions are in the lrecord_implementation structure. |
| 3203 But copying them to a parallel array is much more cache-friendly. | |
| 3204 This hack speeds up (garbage-collect) by about 5%. */ | |
| 3205 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object); | |
| 1676 | 3206 #endif /* not USE_KKCC */ |
| 428 | 3207 |
| 3208 struct gcpro *gcprolist; | |
| 3209 | |
| 771 | 3210 /* We want the staticpro list relocated, but not the pointers found |
| 3211 therein, because they refer to locations in the global data segment, not | |
| 3212 in the heap; we only dump heap objects. Hence we use a trivial | |
| 3213 description, as for pointerless objects. (Note that the data segment | |
| 3214 objects, which are global variables like Qfoo or Vbar, themselves are | |
| 3215 pointers to heap objects. Each needs to be described to pdump as a | |
| 3216 "root pointer"; this happens in the call to staticpro(). */ | |
| 1204 | 3217 static const struct memory_description staticpro_description_1[] = { |
| 452 | 3218 { XD_END } |
| 3219 }; | |
| 3220 | |
| 1204 | 3221 static const struct sized_memory_description staticpro_description = { |
| 452 | 3222 sizeof (Lisp_Object *), |
| 3223 staticpro_description_1 | |
| 3224 }; | |
| 3225 | |
| 1204 | 3226 static const struct memory_description staticpros_description_1[] = { |
| 452 | 3227 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description), |
| 3228 { XD_END } | |
| 3229 }; | |
| 3230 | |
| 1204 | 3231 static const struct sized_memory_description staticpros_description = { |
| 452 | 3232 sizeof (Lisp_Object_ptr_dynarr), |
| 3233 staticpros_description_1 | |
| 3234 }; | |
| 3235 | |
| 771 | 3236 #ifdef DEBUG_XEMACS |
| 3237 | |
| 1204 | 3238 static const struct memory_description staticpro_one_name_description_1[] = { |
| 2367 | 3239 { XD_ASCII_STRING, 0 }, |
| 771 | 3240 { XD_END } |
| 3241 }; | |
| 3242 | |
| 1204 | 3243 static const struct sized_memory_description staticpro_one_name_description = { |
| 771 | 3244 sizeof (char *), |
| 3245 staticpro_one_name_description_1 | |
| 3246 }; | |
| 3247 | |
| 1204 | 3248 static const struct memory_description staticpro_names_description_1[] = { |
| 771 | 3249 XD_DYNARR_DESC (char_ptr_dynarr, &staticpro_one_name_description), |
| 3250 { XD_END } | |
| 3251 }; | |
| 3252 | |
| 1204 | 3253 |
| 3254 extern const struct sized_memory_description staticpro_names_description; | |
| 3255 | |
| 3256 const struct sized_memory_description staticpro_names_description = { | |
| 771 | 3257 sizeof (char_ptr_dynarr), |
| 3258 staticpro_names_description_1 | |
| 3259 }; | |
| 3260 | |
| 3261 /* Help debug crashes gc-marking a staticpro'ed object. */ | |
| 3262 | |
| 3263 Lisp_Object_ptr_dynarr *staticpros; | |
| 3264 char_ptr_dynarr *staticpro_names; | |
| 3265 | |
| 3266 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3267 garbage collection, and for dumping. */ | |
| 3268 void | |
| 3269 staticpro_1 (Lisp_Object *varaddress, char *varname) | |
| 3270 { | |
| 3271 Dynarr_add (staticpros, varaddress); | |
| 3272 Dynarr_add (staticpro_names, varname); | |
| 1204 | 3273 dump_add_root_lisp_object (varaddress); |
| 771 | 3274 } |
| 3275 | |
| 3276 | |
| 3277 Lisp_Object_ptr_dynarr *staticpros_nodump; | |
| 3278 char_ptr_dynarr *staticpro_nodump_names; | |
| 3279 | |
| 3280 /* Mark the Lisp_Object at heap VARADDRESS as a root object for | |
| 3281 garbage collection, but not for dumping. (See below.) */ | |
| 3282 void | |
| 3283 staticpro_nodump_1 (Lisp_Object *varaddress, char *varname) | |
| 3284 { | |
| 3285 Dynarr_add (staticpros_nodump, varaddress); | |
| 3286 Dynarr_add (staticpro_nodump_names, varname); | |
| 3287 } | |
| 3288 | |
| 996 | 3289 #ifdef HAVE_SHLIB |
| 3290 /* Stop treating the Lisp_Object at non-heap VARADDRESS as a root object | |
| 3291 for garbage collection, but not for dumping. */ | |
| 3292 void | |
| 3293 unstaticpro_nodump_1 (Lisp_Object *varaddress, char *varname) | |
| 3294 { | |
| 3295 Dynarr_delete_object (staticpros, varaddress); | |
| 3296 Dynarr_delete_object (staticpro_names, varname); | |
| 3297 } | |
| 3298 #endif | |
| 3299 | |
| 771 | 3300 #else /* not DEBUG_XEMACS */ |
| 3301 | |
| 452 | 3302 Lisp_Object_ptr_dynarr *staticpros; |
| 3303 | |
| 3304 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3305 garbage collection, and for dumping. */ | |
| 428 | 3306 void |
| 3307 staticpro (Lisp_Object *varaddress) | |
| 3308 { | |
| 452 | 3309 Dynarr_add (staticpros, varaddress); |
| 1204 | 3310 dump_add_root_lisp_object (varaddress); |
| 428 | 3311 } |
| 3312 | |
| 442 | 3313 |
| 452 | 3314 Lisp_Object_ptr_dynarr *staticpros_nodump; |
| 3315 | |
| 771 | 3316 /* Mark the Lisp_Object at heap VARADDRESS as a root object for garbage |
| 3317 collection, but not for dumping. This is used for objects where the | |
| 3318 only sure pointer is in the heap (rather than in the global data | |
| 3319 segment, as must be the case for pdump root pointers), but not inside of | |
| 3320 another Lisp object (where it will be marked as a result of that Lisp | |
| 3321 object's mark method). The call to staticpro_nodump() must occur *BOTH* | |
| 3322 at initialization time and at "reinitialization" time (startup, after | |
| 3323 pdump load.) (For example, this is the case with the predicate symbols | |
| 3324 for specifier and coding system types. The pointer to this symbol is | |
| 3325 inside of a methods structure, which is allocated on the heap. The | |
| 3326 methods structure will be written out to the pdump data file, and may be | |
| 3327 reloaded at a different address.) | |
| 3328 | |
| 3329 #### The necessity for reinitialization is a bug in pdump. Pdump should | |
| 3330 automatically regenerate the staticpro()s for these symbols when it | |
| 3331 loads the data in. */ | |
| 3332 | |
| 428 | 3333 void |
| 3334 staticpro_nodump (Lisp_Object *varaddress) | |
| 3335 { | |
| 452 | 3336 Dynarr_add (staticpros_nodump, varaddress); |
| 428 | 3337 } |
| 3338 | |
| 996 | 3339 #ifdef HAVE_SHLIB |
| 3340 /* Unmark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3341 garbage collection, but not for dumping. */ | |
| 3342 void | |
| 3343 unstaticpro_nodump (Lisp_Object *varaddress) | |
| 3344 { | |
| 3345 Dynarr_delete_object (staticpros, varaddress); | |
| 3346 } | |
| 3347 #endif | |
| 3348 | |
| 771 | 3349 #endif /* not DEBUG_XEMACS */ |
| 3350 | |
| 2720 | 3351 |
| 3352 | |
| 3353 | |
| 3354 | |
| 3263 | 3355 #ifdef NEW_GC |
| 2720 | 3356 static const struct memory_description mcpro_description_1[] = { |
| 3357 { XD_END } | |
| 3358 }; | |
| 3359 | |
| 3360 static const struct sized_memory_description mcpro_description = { | |
| 3361 sizeof (Lisp_Object *), | |
| 3362 mcpro_description_1 | |
| 3363 }; | |
| 3364 | |
| 3365 static const struct memory_description mcpros_description_1[] = { | |
| 3366 XD_DYNARR_DESC (Lisp_Object_dynarr, &mcpro_description), | |
| 3367 { XD_END } | |
| 3368 }; | |
| 3369 | |
| 3370 static const struct sized_memory_description mcpros_description = { | |
| 3371 sizeof (Lisp_Object_dynarr), | |
| 3372 mcpros_description_1 | |
| 3373 }; | |
| 3374 | |
| 3375 #ifdef DEBUG_XEMACS | |
| 3376 | |
| 3377 static const struct memory_description mcpro_one_name_description_1[] = { | |
| 3378 { XD_ASCII_STRING, 0 }, | |
| 3379 { XD_END } | |
| 3380 }; | |
| 3381 | |
| 3382 static const struct sized_memory_description mcpro_one_name_description = { | |
| 3383 sizeof (char *), | |
| 3384 mcpro_one_name_description_1 | |
| 3385 }; | |
| 3386 | |
| 3387 static const struct memory_description mcpro_names_description_1[] = { | |
| 3388 XD_DYNARR_DESC (char_ptr_dynarr, &mcpro_one_name_description), | |
| 3389 { XD_END } | |
| 3390 }; | |
| 3391 | |
| 3392 extern const struct sized_memory_description mcpro_names_description; | |
| 3393 | |
| 3394 const struct sized_memory_description mcpro_names_description = { | |
| 3395 sizeof (char_ptr_dynarr), | |
| 3396 mcpro_names_description_1 | |
| 3397 }; | |
| 3398 | |
| 3399 /* Help debug crashes gc-marking a mcpro'ed object. */ | |
| 3400 | |
| 3401 Lisp_Object_dynarr *mcpros; | |
| 3402 char_ptr_dynarr *mcpro_names; | |
| 3403 | |
| 3404 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3405 garbage collection, and for dumping. */ | |
| 3406 void | |
| 3407 mcpro_1 (Lisp_Object varaddress, char *varname) | |
| 3408 { | |
| 3409 Dynarr_add (mcpros, varaddress); | |
| 3410 Dynarr_add (mcpro_names, varname); | |
| 3411 } | |
| 3412 | |
| 3413 #else /* not DEBUG_XEMACS */ | |
| 3414 | |
| 3415 Lisp_Object_dynarr *mcpros; | |
| 3416 | |
| 3417 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3418 garbage collection, and for dumping. */ | |
| 3419 void | |
| 3420 mcpro (Lisp_Object varaddress) | |
| 3421 { | |
| 3422 Dynarr_add (mcpros, varaddress); | |
| 3423 } | |
| 3424 | |
| 3425 #endif /* not DEBUG_XEMACS */ | |
| 3263 | 3426 #endif /* NEW_GC */ |
| 3427 | |
| 3428 | |
| 3429 #ifndef NEW_GC | |
| 428 | 3430 static int gc_count_num_short_string_in_use; |
| 647 | 3431 static Bytecount gc_count_string_total_size; |
| 3432 static Bytecount gc_count_short_string_total_size; | |
| 428 | 3433 |
| 3434 /* static int gc_count_total_records_used, gc_count_records_total_size; */ | |
| 3435 | |
| 3436 | |
| 3437 /* stats on lcrecords in use - kinda kludgy */ | |
| 3438 | |
| 3439 static struct | |
| 3440 { | |
| 3441 int instances_in_use; | |
| 3442 int bytes_in_use; | |
| 3443 int instances_freed; | |
| 3444 int bytes_freed; | |
| 3445 int instances_on_free_list; | |
| 3461 | 3446 } lcrecord_stats [countof (lrecord_implementations_table)]; |
| 428 | 3447 |
| 3448 static void | |
| 442 | 3449 tick_lcrecord_stats (const struct lrecord_header *h, int free_p) |
| 428 | 3450 { |
| 647 | 3451 int type_index = h->type; |
| 428 | 3452 |
| 3024 | 3453 if (((struct old_lcrecord_header *) h)->free) |
| 428 | 3454 { |
| 442 | 3455 gc_checking_assert (!free_p); |
| 428 | 3456 lcrecord_stats[type_index].instances_on_free_list++; |
| 3457 } | |
| 3458 else | |
| 3459 { | |
| 1204 | 3460 Bytecount sz = detagged_lisp_object_size (h); |
| 3461 | |
| 428 | 3462 if (free_p) |
| 3463 { | |
| 3464 lcrecord_stats[type_index].instances_freed++; | |
| 3465 lcrecord_stats[type_index].bytes_freed += sz; | |
| 3466 } | |
| 3467 else | |
| 3468 { | |
| 3469 lcrecord_stats[type_index].instances_in_use++; | |
| 3470 lcrecord_stats[type_index].bytes_in_use += sz; | |
| 3471 } | |
| 3472 } | |
| 3473 } | |
| 3263 | 3474 #endif /* not NEW_GC */ |
| 428 | 3475 |
| 3476 | |
| 3263 | 3477 #ifndef NEW_GC |
| 428 | 3478 /* Free all unmarked records */ |
| 3479 static void | |
| 3024 | 3480 sweep_lcrecords_1 (struct old_lcrecord_header **prev, int *used) |
| 3481 { | |
| 3482 struct old_lcrecord_header *header; | |
| 428 | 3483 int num_used = 0; |
| 3484 /* int total_size = 0; */ | |
| 3485 | |
| 3486 xzero (lcrecord_stats); /* Reset all statistics to 0. */ | |
| 3487 | |
| 3488 /* First go through and call all the finalize methods. | |
| 3489 Then go through and free the objects. There used to | |
| 3490 be only one loop here, with the call to the finalizer | |
| 3491 occurring directly before the xfree() below. That | |
| 3492 is marginally faster but much less safe -- if the | |
| 3493 finalize method for an object needs to reference any | |
| 3494 other objects contained within it (and many do), | |
| 3495 we could easily be screwed by having already freed that | |
| 3496 other object. */ | |
| 3497 | |
| 3498 for (header = *prev; header; header = header->next) | |
| 3499 { | |
| 3500 struct lrecord_header *h = &(header->lheader); | |
| 442 | 3501 |
| 3502 GC_CHECK_LHEADER_INVARIANTS (h); | |
| 3503 | |
| 3504 if (! MARKED_RECORD_HEADER_P (h) && ! header->free) | |
| 428 | 3505 { |
| 3506 if (LHEADER_IMPLEMENTATION (h)->finalizer) | |
| 3507 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); | |
| 3508 } | |
| 3509 } | |
| 3510 | |
| 3511 for (header = *prev; header; ) | |
| 3512 { | |
| 3513 struct lrecord_header *h = &(header->lheader); | |
| 442 | 3514 if (MARKED_RECORD_HEADER_P (h)) |
| 428 | 3515 { |
| 442 | 3516 if (! C_READONLY_RECORD_HEADER_P (h)) |
| 428 | 3517 UNMARK_RECORD_HEADER (h); |
| 3518 num_used++; | |
| 3519 /* total_size += n->implementation->size_in_bytes (h);*/ | |
| 440 | 3520 /* #### May modify header->next on a C_READONLY lcrecord */ |
| 428 | 3521 prev = &(header->next); |
| 3522 header = *prev; | |
| 3523 tick_lcrecord_stats (h, 0); | |
| 3524 } | |
| 3525 else | |
| 3526 { | |
| 3024 | 3527 struct old_lcrecord_header *next = header->next; |
| 428 | 3528 *prev = next; |
| 3529 tick_lcrecord_stats (h, 1); | |
| 3530 /* used to call finalizer right here. */ | |
| 3024 | 3531 xfree (header, struct old_lcrecord_header *); |
| 428 | 3532 header = next; |
| 3533 } | |
| 3534 } | |
| 3535 *used = num_used; | |
| 3536 /* *total = total_size; */ | |
| 3537 } | |
| 3538 | |
| 3539 /* And the Lord said: Thou shalt use the `c-backslash-region' command | |
| 3540 to make macros prettier. */ | |
| 3541 | |
| 3542 #ifdef ERROR_CHECK_GC | |
| 3543 | |
| 771 | 3544 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
| 428 | 3545 do { \ |
| 3546 struct typename##_block *SFTB_current; \ | |
| 3547 int SFTB_limit; \ | |
| 3548 int num_free = 0, num_used = 0; \ | |
| 3549 \ | |
| 444 | 3550 for (SFTB_current = current_##typename##_block, \ |
| 428 | 3551 SFTB_limit = current_##typename##_block_index; \ |
| 3552 SFTB_current; \ | |
| 3553 ) \ | |
| 3554 { \ | |
| 3555 int SFTB_iii; \ | |
| 3556 \ | |
| 3557 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
| 3558 { \ | |
| 3559 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
| 3560 \ | |
| 454 | 3561 if (LRECORD_FREE_P (SFTB_victim)) \ |
| 428 | 3562 { \ |
| 3563 num_free++; \ | |
| 3564 } \ | |
| 3565 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 3566 { \ | |
| 3567 num_used++; \ | |
| 3568 } \ | |
| 442 | 3569 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
| 428 | 3570 { \ |
| 3571 num_free++; \ | |
| 3572 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
| 3573 } \ | |
| 3574 else \ | |
| 3575 { \ | |
| 3576 num_used++; \ | |
| 3577 UNMARK_##typename (SFTB_victim); \ | |
| 3578 } \ | |
| 3579 } \ | |
| 3580 SFTB_current = SFTB_current->prev; \ | |
| 3581 SFTB_limit = countof (current_##typename##_block->block); \ | |
| 3582 } \ | |
| 3583 \ | |
| 3584 gc_count_num_##typename##_in_use = num_used; \ | |
| 3585 gc_count_num_##typename##_freelist = num_free; \ | |
| 3586 } while (0) | |
| 3587 | |
| 3588 #else /* !ERROR_CHECK_GC */ | |
| 3589 | |
| 771 | 3590 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
| 3591 do { \ | |
| 3592 struct typename##_block *SFTB_current; \ | |
| 3593 struct typename##_block **SFTB_prev; \ | |
| 3594 int SFTB_limit; \ | |
| 3595 int num_free = 0, num_used = 0; \ | |
| 3596 \ | |
| 3597 typename##_free_list = 0; \ | |
| 3598 \ | |
| 3599 for (SFTB_prev = ¤t_##typename##_block, \ | |
| 3600 SFTB_current = current_##typename##_block, \ | |
| 3601 SFTB_limit = current_##typename##_block_index; \ | |
| 3602 SFTB_current; \ | |
| 3603 ) \ | |
| 3604 { \ | |
| 3605 int SFTB_iii; \ | |
| 3606 int SFTB_empty = 1; \ | |
| 3607 Lisp_Free *SFTB_old_free_list = typename##_free_list; \ | |
| 3608 \ | |
| 3609 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
| 3610 { \ | |
| 3611 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
| 3612 \ | |
| 3613 if (LRECORD_FREE_P (SFTB_victim)) \ | |
| 3614 { \ | |
| 3615 num_free++; \ | |
| 3616 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ | |
| 3617 } \ | |
| 3618 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 3619 { \ | |
| 3620 SFTB_empty = 0; \ | |
| 3621 num_used++; \ | |
| 3622 } \ | |
| 3623 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 3624 { \ | |
| 3625 num_free++; \ | |
| 3626 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
| 3627 } \ | |
| 3628 else \ | |
| 3629 { \ | |
| 3630 SFTB_empty = 0; \ | |
| 3631 num_used++; \ | |
| 3632 UNMARK_##typename (SFTB_victim); \ | |
| 3633 } \ | |
| 3634 } \ | |
| 3635 if (!SFTB_empty) \ | |
| 3636 { \ | |
| 3637 SFTB_prev = &(SFTB_current->prev); \ | |
| 3638 SFTB_current = SFTB_current->prev; \ | |
| 3639 } \ | |
| 3640 else if (SFTB_current == current_##typename##_block \ | |
| 3641 && !SFTB_current->prev) \ | |
| 3642 { \ | |
| 3643 /* No real point in freeing sole allocation block */ \ | |
| 3644 break; \ | |
| 3645 } \ | |
| 3646 else \ | |
| 3647 { \ | |
| 3648 struct typename##_block *SFTB_victim_block = SFTB_current; \ | |
| 3649 if (SFTB_victim_block == current_##typename##_block) \ | |
| 3650 current_##typename##_block_index \ | |
| 3651 = countof (current_##typename##_block->block); \ | |
| 3652 SFTB_current = SFTB_current->prev; \ | |
| 3653 { \ | |
| 3654 *SFTB_prev = SFTB_current; \ | |
| 1726 | 3655 xfree (SFTB_victim_block, struct typename##_block *); \ |
| 771 | 3656 /* Restore free list to what it was before victim was swept */ \ |
| 3657 typename##_free_list = SFTB_old_free_list; \ | |
| 3658 num_free -= SFTB_limit; \ | |
| 3659 } \ | |
| 3660 } \ | |
| 3661 SFTB_limit = countof (current_##typename##_block->block); \ | |
| 3662 } \ | |
| 3663 \ | |
| 3664 gc_count_num_##typename##_in_use = num_used; \ | |
| 3665 gc_count_num_##typename##_freelist = num_free; \ | |
| 428 | 3666 } while (0) |
| 3667 | |
| 3668 #endif /* !ERROR_CHECK_GC */ | |
| 3669 | |
| 771 | 3670 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ |
| 3671 SWEEP_FIXED_TYPE_BLOCK_1 (typename, obj_type, lheader) | |
| 3672 | |
| 3263 | 3673 #endif /* not NEW_GC */ |
| 2720 | 3674 |
| 428 | 3675 |
| 3263 | 3676 #ifndef NEW_GC |
| 428 | 3677 static void |
| 3678 sweep_conses (void) | |
| 3679 { | |
| 3680 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3681 #define ADDITIONAL_FREE_cons(ptr) | |
| 3682 | |
| 440 | 3683 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons); |
| 428 | 3684 } |
| 3263 | 3685 #endif /* not NEW_GC */ |
| 428 | 3686 |
| 3687 /* Explicitly free a cons cell. */ | |
| 3688 void | |
| 853 | 3689 free_cons (Lisp_Object cons) |
| 428 | 3690 { |
| 3263 | 3691 #ifndef NEW_GC /* to avoid compiler warning */ |
| 853 | 3692 Lisp_Cons *ptr = XCONS (cons); |
| 3263 | 3693 #endif /* not NEW_GC */ |
| 853 | 3694 |
| 428 | 3695 #ifdef ERROR_CHECK_GC |
| 3263 | 3696 #ifdef NEW_GC |
| 2720 | 3697 Lisp_Cons *ptr = XCONS (cons); |
| 3263 | 3698 #endif /* NEW_GC */ |
| 428 | 3699 /* If the CAR is not an int, then it will be a pointer, which will |
| 3700 always be four-byte aligned. If this cons cell has already been | |
| 3701 placed on the free list, however, its car will probably contain | |
| 3702 a chain pointer to the next cons on the list, which has cleverly | |
| 3703 had all its 0's and 1's inverted. This allows for a quick | |
| 1204 | 3704 check to make sure we're not freeing something already freed. |
| 3705 | |
| 3706 NOTE: This check may not be necessary. Freeing an object sets its | |
| 3707 type to lrecord_type_free, which will trip up the XCONS() above -- as | |
| 3708 well as a check in FREE_FIXED_TYPE(). */ | |
| 853 | 3709 if (POINTER_TYPE_P (XTYPE (cons_car (ptr)))) |
| 3710 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr))); | |
| 428 | 3711 #endif /* ERROR_CHECK_GC */ |
| 3712 | |
| 3263 | 3713 #ifdef NEW_GC |
| 2720 | 3714 free_lrecord (cons); |
| 3263 | 3715 #else /* not NEW_GC */ |
| 440 | 3716 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr); |
| 3263 | 3717 #endif /* not NEW_GC */ |
| 428 | 3718 } |
| 3719 | |
| 3720 /* explicitly free a list. You **must make sure** that you have | |
| 3721 created all the cons cells that make up this list and that there | |
| 3722 are no pointers to any of these cons cells anywhere else. If there | |
| 3723 are, you will lose. */ | |
| 3724 | |
| 3725 void | |
| 3726 free_list (Lisp_Object list) | |
| 3727 { | |
| 3728 Lisp_Object rest, next; | |
| 3729 | |
| 3730 for (rest = list; !NILP (rest); rest = next) | |
| 3731 { | |
| 3732 next = XCDR (rest); | |
| 853 | 3733 free_cons (rest); |
| 428 | 3734 } |
| 3735 } | |
| 3736 | |
| 3737 /* explicitly free an alist. You **must make sure** that you have | |
| 3738 created all the cons cells that make up this alist and that there | |
| 3739 are no pointers to any of these cons cells anywhere else. If there | |
| 3740 are, you will lose. */ | |
| 3741 | |
| 3742 void | |
| 3743 free_alist (Lisp_Object alist) | |
| 3744 { | |
| 3745 Lisp_Object rest, next; | |
| 3746 | |
| 3747 for (rest = alist; !NILP (rest); rest = next) | |
| 3748 { | |
| 3749 next = XCDR (rest); | |
| 853 | 3750 free_cons (XCAR (rest)); |
| 3751 free_cons (rest); | |
| 428 | 3752 } |
| 3753 } | |
| 3754 | |
| 3263 | 3755 #ifndef NEW_GC |
| 428 | 3756 static void |
| 3757 sweep_compiled_functions (void) | |
| 3758 { | |
| 3759 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 945 | 3760 #define ADDITIONAL_FREE_compiled_function(ptr) \ |
| 1726 | 3761 if (ptr->args_in_array) xfree (ptr->args, Lisp_Object *) |
| 428 | 3762 |
| 3763 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function); | |
| 3764 } | |
| 3765 | |
| 3766 static void | |
| 3767 sweep_floats (void) | |
| 3768 { | |
| 3769 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3770 #define ADDITIONAL_FREE_float(ptr) | |
| 3771 | |
| 440 | 3772 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float); |
| 428 | 3773 } |
| 3774 | |
| 1983 | 3775 #ifdef HAVE_BIGNUM |
| 3776 static void | |
| 3777 sweep_bignums (void) | |
| 3778 { | |
| 3779 #define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3780 #define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data) | |
| 3781 | |
| 3782 SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum); | |
| 3783 } | |
| 3784 #endif /* HAVE_BIGNUM */ | |
| 3785 | |
| 3786 #ifdef HAVE_RATIO | |
| 3787 static void | |
| 3788 sweep_ratios (void) | |
| 3789 { | |
| 3790 #define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3791 #define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data) | |
| 3792 | |
| 3793 SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio); | |
| 3794 } | |
| 3795 #endif /* HAVE_RATIO */ | |
| 3796 | |
| 3797 #ifdef HAVE_BIGFLOAT | |
| 3798 static void | |
| 3799 sweep_bigfloats (void) | |
| 3800 { | |
| 3801 #define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3802 #define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf) | |
| 3803 | |
| 3804 SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat); | |
| 3805 } | |
| 3806 #endif | |
| 3807 | |
| 428 | 3808 static void |
| 3809 sweep_symbols (void) | |
| 3810 { | |
| 3811 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3812 #define ADDITIONAL_FREE_symbol(ptr) | |
| 3813 | |
| 440 | 3814 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol); |
| 428 | 3815 } |
| 3816 | |
| 3817 static void | |
| 3818 sweep_extents (void) | |
| 3819 { | |
| 3820 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3821 #define ADDITIONAL_FREE_extent(ptr) | |
| 3822 | |
| 3823 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent); | |
| 3824 } | |
| 3825 | |
| 3826 static void | |
| 3827 sweep_events (void) | |
| 3828 { | |
| 3829 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3830 #define ADDITIONAL_FREE_event(ptr) | |
| 3831 | |
| 440 | 3832 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event); |
| 428 | 3833 } |
| 3263 | 3834 #endif /* not NEW_GC */ |
| 428 | 3835 |
| 1204 | 3836 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 3837 |
| 3263 | 3838 #ifndef NEW_GC |
| 934 | 3839 static void |
| 3840 sweep_key_data (void) | |
| 3841 { | |
| 3842 #define UNMARK_key_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3843 #define ADDITIONAL_FREE_key_data(ptr) | |
| 3844 | |
| 3845 SWEEP_FIXED_TYPE_BLOCK (key_data, Lisp_Key_Data); | |
| 3846 } | |
| 3263 | 3847 #endif /* not NEW_GC */ |
| 934 | 3848 |
| 1204 | 3849 void |
| 3850 free_key_data (Lisp_Object ptr) | |
| 3851 { | |
| 3263 | 3852 #ifdef NEW_GC |
| 2720 | 3853 free_lrecord (ptr); |
| 3263 | 3854 #else /* not NEW_GC */ |
| 1204 | 3855 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (key_data, Lisp_Key_Data, XKEY_DATA (ptr)); |
| 3263 | 3856 #endif /* not NEW_GC */ |
| 2720 | 3857 } |
| 3858 | |
| 3263 | 3859 #ifndef NEW_GC |
| 934 | 3860 static void |
| 3861 sweep_button_data (void) | |
| 3862 { | |
| 3863 #define UNMARK_button_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3864 #define ADDITIONAL_FREE_button_data(ptr) | |
| 3865 | |
| 3866 SWEEP_FIXED_TYPE_BLOCK (button_data, Lisp_Button_Data); | |
| 3867 } | |
| 3263 | 3868 #endif /* not NEW_GC */ |
| 934 | 3869 |
| 1204 | 3870 void |
| 3871 free_button_data (Lisp_Object ptr) | |
| 3872 { | |
| 3263 | 3873 #ifdef NEW_GC |
| 2720 | 3874 free_lrecord (ptr); |
| 3263 | 3875 #else /* not NEW_GC */ |
| 1204 | 3876 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (button_data, Lisp_Button_Data, XBUTTON_DATA (ptr)); |
| 3263 | 3877 #endif /* not NEW_GC */ |
| 2720 | 3878 } |
| 3879 | |
| 3263 | 3880 #ifndef NEW_GC |
| 934 | 3881 static void |
| 3882 sweep_motion_data (void) | |
| 3883 { | |
| 3884 #define UNMARK_motion_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3885 #define ADDITIONAL_FREE_motion_data(ptr) | |
| 3886 | |
| 3887 SWEEP_FIXED_TYPE_BLOCK (motion_data, Lisp_Motion_Data); | |
| 3888 } | |
| 3263 | 3889 #endif /* not NEW_GC */ |
| 934 | 3890 |
| 1204 | 3891 void |
| 3892 free_motion_data (Lisp_Object ptr) | |
| 3893 { | |
| 3263 | 3894 #ifdef NEW_GC |
| 2720 | 3895 free_lrecord (ptr); |
| 3263 | 3896 #else /* not NEW_GC */ |
| 1204 | 3897 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (motion_data, Lisp_Motion_Data, XMOTION_DATA (ptr)); |
| 3263 | 3898 #endif /* not NEW_GC */ |
| 2720 | 3899 } |
| 3900 | |
| 3263 | 3901 #ifndef NEW_GC |
| 934 | 3902 static void |
| 3903 sweep_process_data (void) | |
| 3904 { | |
| 3905 #define UNMARK_process_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3906 #define ADDITIONAL_FREE_process_data(ptr) | |
| 3907 | |
| 3908 SWEEP_FIXED_TYPE_BLOCK (process_data, Lisp_Process_Data); | |
| 3909 } | |
| 3263 | 3910 #endif /* not NEW_GC */ |
| 934 | 3911 |
| 1204 | 3912 void |
| 3913 free_process_data (Lisp_Object ptr) | |
| 3914 { | |
| 3263 | 3915 #ifdef NEW_GC |
| 2720 | 3916 free_lrecord (ptr); |
| 3263 | 3917 #else /* not NEW_GC */ |
| 1204 | 3918 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (process_data, Lisp_Process_Data, XPROCESS_DATA (ptr)); |
| 3263 | 3919 #endif /* not NEW_GC */ |
| 2720 | 3920 } |
| 3921 | |
| 3263 | 3922 #ifndef NEW_GC |
| 934 | 3923 static void |
| 3924 sweep_timeout_data (void) | |
| 3925 { | |
| 3926 #define UNMARK_timeout_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3927 #define ADDITIONAL_FREE_timeout_data(ptr) | |
| 3928 | |
| 3929 SWEEP_FIXED_TYPE_BLOCK (timeout_data, Lisp_Timeout_Data); | |
| 3930 } | |
| 3263 | 3931 #endif /* not NEW_GC */ |
| 934 | 3932 |
| 1204 | 3933 void |
| 3934 free_timeout_data (Lisp_Object ptr) | |
| 3935 { | |
| 3263 | 3936 #ifdef NEW_GC |
| 2720 | 3937 free_lrecord (ptr); |
| 3263 | 3938 #else /* not NEW_GC */ |
| 1204 | 3939 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (timeout_data, Lisp_Timeout_Data, XTIMEOUT_DATA (ptr)); |
| 3263 | 3940 #endif /* not NEW_GC */ |
| 2720 | 3941 } |
| 3942 | |
| 3263 | 3943 #ifndef NEW_GC |
| 934 | 3944 static void |
| 3945 sweep_magic_data (void) | |
| 3946 { | |
| 3947 #define UNMARK_magic_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3948 #define ADDITIONAL_FREE_magic_data(ptr) | |
| 3949 | |
| 3950 SWEEP_FIXED_TYPE_BLOCK (magic_data, Lisp_Magic_Data); | |
| 3951 } | |
| 3263 | 3952 #endif /* not NEW_GC */ |
| 934 | 3953 |
| 1204 | 3954 void |
| 3955 free_magic_data (Lisp_Object ptr) | |
| 3956 { | |
| 3263 | 3957 #ifdef NEW_GC |
| 2720 | 3958 free_lrecord (ptr); |
| 3263 | 3959 #else /* not NEW_GC */ |
| 1204 | 3960 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_data, Lisp_Magic_Data, XMAGIC_DATA (ptr)); |
| 3263 | 3961 #endif /* not NEW_GC */ |
| 2720 | 3962 } |
| 3963 | |
| 3263 | 3964 #ifndef NEW_GC |
| 934 | 3965 static void |
| 3966 sweep_magic_eval_data (void) | |
| 3967 { | |
| 3968 #define UNMARK_magic_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3969 #define ADDITIONAL_FREE_magic_eval_data(ptr) | |
| 3970 | |
| 3971 SWEEP_FIXED_TYPE_BLOCK (magic_eval_data, Lisp_Magic_Eval_Data); | |
| 3972 } | |
| 3263 | 3973 #endif /* not NEW_GC */ |
| 934 | 3974 |
| 1204 | 3975 void |
| 3976 free_magic_eval_data (Lisp_Object ptr) | |
| 3977 { | |
| 3263 | 3978 #ifdef NEW_GC |
| 2720 | 3979 free_lrecord (ptr); |
| 3263 | 3980 #else /* not NEW_GC */ |
| 1204 | 3981 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_eval_data, Lisp_Magic_Eval_Data, XMAGIC_EVAL_DATA (ptr)); |
| 3263 | 3982 #endif /* not NEW_GC */ |
| 2720 | 3983 } |
| 3984 | |
| 3263 | 3985 #ifndef NEW_GC |
| 934 | 3986 static void |
| 3987 sweep_eval_data (void) | |
| 3988 { | |
| 3989 #define UNMARK_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3990 #define ADDITIONAL_FREE_eval_data(ptr) | |
| 3991 | |
| 3992 SWEEP_FIXED_TYPE_BLOCK (eval_data, Lisp_Eval_Data); | |
| 3993 } | |
| 3263 | 3994 #endif /* not NEW_GC */ |
| 934 | 3995 |
| 1204 | 3996 void |
| 3997 free_eval_data (Lisp_Object ptr) | |
| 3998 { | |
| 3263 | 3999 #ifdef NEW_GC |
| 2720 | 4000 free_lrecord (ptr); |
| 3263 | 4001 #else /* not NEW_GC */ |
| 1204 | 4002 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (eval_data, Lisp_Eval_Data, XEVAL_DATA (ptr)); |
| 3263 | 4003 #endif /* not NEW_GC */ |
| 2720 | 4004 } |
| 4005 | |
| 3263 | 4006 #ifndef NEW_GC |
| 934 | 4007 static void |
| 4008 sweep_misc_user_data (void) | |
| 4009 { | |
| 4010 #define UNMARK_misc_user_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4011 #define ADDITIONAL_FREE_misc_user_data(ptr) | |
| 4012 | |
| 4013 SWEEP_FIXED_TYPE_BLOCK (misc_user_data, Lisp_Misc_User_Data); | |
| 4014 } | |
| 3263 | 4015 #endif /* not NEW_GC */ |
| 934 | 4016 |
| 1204 | 4017 void |
| 4018 free_misc_user_data (Lisp_Object ptr) | |
| 4019 { | |
| 3263 | 4020 #ifdef NEW_GC |
| 2720 | 4021 free_lrecord (ptr); |
| 3263 | 4022 #else /* not NEW_GC */ |
| 1204 | 4023 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (misc_user_data, Lisp_Misc_User_Data, XMISC_USER_DATA (ptr)); |
| 3263 | 4024 #endif /* not NEW_GC */ |
| 1204 | 4025 } |
| 4026 | |
| 4027 #endif /* EVENT_DATA_AS_OBJECTS */ | |
| 934 | 4028 |
| 3263 | 4029 #ifndef NEW_GC |
| 428 | 4030 static void |
| 4031 sweep_markers (void) | |
| 4032 { | |
| 4033 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4034 #define ADDITIONAL_FREE_marker(ptr) \ | |
| 4035 do { Lisp_Object tem; \ | |
| 793 | 4036 tem = wrap_marker (ptr); \ |
| 428 | 4037 unchain_marker (tem); \ |
| 4038 } while (0) | |
| 4039 | |
| 440 | 4040 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker); |
| 428 | 4041 } |
| 3263 | 4042 #endif /* not NEW_GC */ |
| 428 | 4043 |
| 4044 /* Explicitly free a marker. */ | |
| 4045 void | |
| 1204 | 4046 free_marker (Lisp_Object ptr) |
| 428 | 4047 { |
| 3263 | 4048 #ifdef NEW_GC |
| 2720 | 4049 free_lrecord (ptr); |
| 3263 | 4050 #else /* not NEW_GC */ |
| 1204 | 4051 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, XMARKER (ptr)); |
| 3263 | 4052 #endif /* not NEW_GC */ |
| 428 | 4053 } |
| 4054 | |
| 4055 | |
| 4056 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) | |
| 4057 | |
| 4058 static void | |
| 4059 verify_string_chars_integrity (void) | |
| 4060 { | |
| 4061 struct string_chars_block *sb; | |
| 4062 | |
| 4063 /* Scan each existing string block sequentially, string by string. */ | |
| 4064 for (sb = first_string_chars_block; sb; sb = sb->next) | |
| 4065 { | |
| 4066 int pos = 0; | |
| 4067 /* POS is the index of the next string in the block. */ | |
| 4068 while (pos < sb->pos) | |
| 4069 { | |
| 4070 struct string_chars *s_chars = | |
| 4071 (struct string_chars *) &(sb->string_chars[pos]); | |
| 438 | 4072 Lisp_String *string; |
| 428 | 4073 int size; |
| 4074 int fullsize; | |
| 4075 | |
| 454 | 4076 /* If the string_chars struct is marked as free (i.e. the |
| 4077 STRING pointer is NULL) then this is an unused chunk of | |
| 4078 string storage. (See below.) */ | |
| 4079 | |
| 4080 if (STRING_CHARS_FREE_P (s_chars)) | |
| 428 | 4081 { |
| 4082 fullsize = ((struct unused_string_chars *) s_chars)->fullsize; | |
| 4083 pos += fullsize; | |
| 4084 continue; | |
| 4085 } | |
| 4086 | |
| 4087 string = s_chars->string; | |
| 4088 /* Must be 32-bit aligned. */ | |
| 4089 assert ((((int) string) & 3) == 0); | |
| 4090 | |
| 793 | 4091 size = string->size_; |
| 428 | 4092 fullsize = STRING_FULLSIZE (size); |
| 4093 | |
| 4094 assert (!BIG_STRING_FULLSIZE_P (fullsize)); | |
| 2720 | 4095 assert (XSTRING_DATA (string) == s_chars->chars); |
| 428 | 4096 pos += fullsize; |
| 4097 } | |
| 4098 assert (pos == sb->pos); | |
| 4099 } | |
| 4100 } | |
| 4101 | |
| 1204 | 4102 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */ |
| 428 | 4103 |
| 3092 | 4104 #ifndef NEW_GC |
| 428 | 4105 /* Compactify string chars, relocating the reference to each -- |
| 4106 free any empty string_chars_block we see. */ | |
| 3092 | 4107 void |
| 428 | 4108 compact_string_chars (void) |
| 4109 { | |
| 4110 struct string_chars_block *to_sb = first_string_chars_block; | |
| 4111 int to_pos = 0; | |
| 4112 struct string_chars_block *from_sb; | |
| 4113 | |
| 4114 /* Scan each existing string block sequentially, string by string. */ | |
| 4115 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next) | |
| 4116 { | |
| 4117 int from_pos = 0; | |
| 4118 /* FROM_POS is the index of the next string in the block. */ | |
| 4119 while (from_pos < from_sb->pos) | |
| 4120 { | |
| 4121 struct string_chars *from_s_chars = | |
| 4122 (struct string_chars *) &(from_sb->string_chars[from_pos]); | |
| 4123 struct string_chars *to_s_chars; | |
| 438 | 4124 Lisp_String *string; |
| 428 | 4125 int size; |
| 4126 int fullsize; | |
| 4127 | |
| 454 | 4128 /* If the string_chars struct is marked as free (i.e. the |
| 4129 STRING pointer is NULL) then this is an unused chunk of | |
| 4130 string storage. This happens under Mule when a string's | |
| 4131 size changes in such a way that its fullsize changes. | |
| 4132 (Strings can change size because a different-length | |
| 4133 character can be substituted for another character.) | |
| 4134 In this case, after the bogus string pointer is the | |
| 4135 "fullsize" of this entry, i.e. how many bytes to skip. */ | |
| 4136 | |
| 4137 if (STRING_CHARS_FREE_P (from_s_chars)) | |
| 428 | 4138 { |
| 4139 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize; | |
| 4140 from_pos += fullsize; | |
| 4141 continue; | |
| 4142 } | |
| 4143 | |
| 4144 string = from_s_chars->string; | |
| 1204 | 4145 gc_checking_assert (!(LRECORD_FREE_P (string))); |
| 428 | 4146 |
| 793 | 4147 size = string->size_; |
| 428 | 4148 fullsize = STRING_FULLSIZE (size); |
| 4149 | |
| 442 | 4150 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize)); |
| 428 | 4151 |
| 4152 /* Just skip it if it isn't marked. */ | |
| 771 | 4153 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader))) |
| 428 | 4154 { |
| 4155 from_pos += fullsize; | |
| 4156 continue; | |
| 4157 } | |
| 4158 | |
| 4159 /* If it won't fit in what's left of TO_SB, close TO_SB out | |
| 4160 and go on to the next string_chars_block. We know that TO_SB | |
| 4161 cannot advance past FROM_SB here since FROM_SB is large enough | |
| 4162 to currently contain this string. */ | |
| 4163 if ((to_pos + fullsize) > countof (to_sb->string_chars)) | |
| 4164 { | |
| 4165 to_sb->pos = to_pos; | |
| 4166 to_sb = to_sb->next; | |
| 4167 to_pos = 0; | |
| 4168 } | |
| 4169 | |
| 4170 /* Compute new address of this string | |
| 4171 and update TO_POS for the space being used. */ | |
| 4172 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]); | |
| 4173 | |
| 4174 /* Copy the string_chars to the new place. */ | |
| 4175 if (from_s_chars != to_s_chars) | |
| 4176 memmove (to_s_chars, from_s_chars, fullsize); | |
| 4177 | |
| 4178 /* Relocate FROM_S_CHARS's reference */ | |
| 826 | 4179 set_lispstringp_data (string, &(to_s_chars->chars[0])); |
| 428 | 4180 |
| 4181 from_pos += fullsize; | |
| 4182 to_pos += fullsize; | |
| 4183 } | |
| 4184 } | |
| 4185 | |
| 4186 /* Set current to the last string chars block still used and | |
| 4187 free any that follow. */ | |
| 4188 { | |
| 4189 struct string_chars_block *victim; | |
| 4190 | |
| 4191 for (victim = to_sb->next; victim; ) | |
| 4192 { | |
| 4193 struct string_chars_block *next = victim->next; | |
| 1726 | 4194 xfree (victim, struct string_chars_block *); |
| 428 | 4195 victim = next; |
| 4196 } | |
| 4197 | |
| 4198 current_string_chars_block = to_sb; | |
| 4199 current_string_chars_block->pos = to_pos; | |
| 4200 current_string_chars_block->next = 0; | |
| 4201 } | |
| 4202 } | |
| 3092 | 4203 #endif /* not NEW_GC */ |
| 428 | 4204 |
| 3263 | 4205 #ifndef NEW_GC |
| 428 | 4206 #if 1 /* Hack to debug missing purecopy's */ |
| 4207 static int debug_string_purity; | |
| 4208 | |
| 4209 static void | |
| 793 | 4210 debug_string_purity_print (Lisp_Object p) |
| 428 | 4211 { |
| 4212 Charcount i; | |
| 826 | 4213 Charcount s = string_char_length (p); |
| 442 | 4214 stderr_out ("\""); |
| 428 | 4215 for (i = 0; i < s; i++) |
| 4216 { | |
| 867 | 4217 Ichar ch = string_ichar (p, i); |
| 428 | 4218 if (ch < 32 || ch >= 126) |
| 4219 stderr_out ("\\%03o", ch); | |
| 4220 else if (ch == '\\' || ch == '\"') | |
| 4221 stderr_out ("\\%c", ch); | |
| 4222 else | |
| 4223 stderr_out ("%c", ch); | |
| 4224 } | |
| 4225 stderr_out ("\"\n"); | |
| 4226 } | |
| 4227 #endif /* 1 */ | |
| 3263 | 4228 #endif /* not NEW_GC */ |
| 4229 | |
| 4230 #ifndef NEW_GC | |
| 428 | 4231 static void |
| 4232 sweep_strings (void) | |
| 4233 { | |
| 647 | 4234 int num_small_used = 0; |
| 4235 Bytecount num_small_bytes = 0, num_bytes = 0; | |
| 428 | 4236 int debug = debug_string_purity; |
| 4237 | |
| 793 | 4238 #define UNMARK_string(ptr) do { \ |
| 4239 Lisp_String *p = (ptr); \ | |
| 4240 Bytecount size = p->size_; \ | |
| 4241 UNMARK_RECORD_HEADER (&(p->u.lheader)); \ | |
| 4242 num_bytes += size; \ | |
| 4243 if (!BIG_STRING_SIZE_P (size)) \ | |
| 4244 { \ | |
| 4245 num_small_bytes += size; \ | |
| 4246 num_small_used++; \ | |
| 4247 } \ | |
| 4248 if (debug) \ | |
| 4249 debug_string_purity_print (wrap_string (p)); \ | |
| 438 | 4250 } while (0) |
| 4251 #define ADDITIONAL_FREE_string(ptr) do { \ | |
| 793 | 4252 Bytecount size = ptr->size_; \ |
| 438 | 4253 if (BIG_STRING_SIZE_P (size)) \ |
| 1726 | 4254 xfree (ptr->data_, Ibyte *); \ |
| 438 | 4255 } while (0) |
| 4256 | |
| 771 | 4257 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader); |
| 428 | 4258 |
| 4259 gc_count_num_short_string_in_use = num_small_used; | |
| 4260 gc_count_string_total_size = num_bytes; | |
| 4261 gc_count_short_string_total_size = num_small_bytes; | |
| 4262 } | |
| 3263 | 4263 #endif /* not NEW_GC */ |
| 428 | 4264 |
| 3092 | 4265 #ifndef NEW_GC |
| 4266 void | |
| 4267 gc_sweep_1 (void) | |
| 428 | 4268 { |
| 4269 /* Free all unmarked records. Do this at the very beginning, | |
| 4270 before anything else, so that the finalize methods can safely | |
| 4271 examine items in the objects. sweep_lcrecords_1() makes | |
| 4272 sure to call all the finalize methods *before* freeing anything, | |
| 4273 to complete the safety. */ | |
| 4274 { | |
| 4275 int ignored; | |
| 4276 sweep_lcrecords_1 (&all_lcrecords, &ignored); | |
| 4277 } | |
| 4278 | |
| 4279 compact_string_chars (); | |
| 4280 | |
| 4281 /* Finalize methods below (called through the ADDITIONAL_FREE_foo | |
| 4282 macros) must be *extremely* careful to make sure they're not | |
| 4283 referencing freed objects. The only two existing finalize | |
| 4284 methods (for strings and markers) pass muster -- the string | |
| 4285 finalizer doesn't look at anything but its own specially- | |
| 4286 created block, and the marker finalizer only looks at live | |
| 4287 buffers (which will never be freed) and at the markers before | |
| 4288 and after it in the chain (which, by induction, will never be | |
| 4289 freed because if so, they would have already removed themselves | |
| 4290 from the chain). */ | |
| 4291 | |
| 4292 /* Put all unmarked strings on free list, free'ing the string chars | |
| 4293 of large unmarked strings */ | |
| 4294 sweep_strings (); | |
| 4295 | |
| 4296 /* Put all unmarked conses on free list */ | |
| 4297 sweep_conses (); | |
| 4298 | |
| 4299 /* Free all unmarked compiled-function objects */ | |
| 4300 sweep_compiled_functions (); | |
| 4301 | |
| 4302 /* Put all unmarked floats on free list */ | |
| 4303 sweep_floats (); | |
| 4304 | |
| 1983 | 4305 #ifdef HAVE_BIGNUM |
| 4306 /* Put all unmarked bignums on free list */ | |
| 4307 sweep_bignums (); | |
| 4308 #endif | |
| 4309 | |
| 4310 #ifdef HAVE_RATIO | |
| 4311 /* Put all unmarked ratios on free list */ | |
| 4312 sweep_ratios (); | |
| 4313 #endif | |
| 4314 | |
| 4315 #ifdef HAVE_BIGFLOAT | |
| 4316 /* Put all unmarked bigfloats on free list */ | |
| 4317 sweep_bigfloats (); | |
| 4318 #endif | |
| 4319 | |
| 428 | 4320 /* Put all unmarked symbols on free list */ |
| 4321 sweep_symbols (); | |
| 4322 | |
| 4323 /* Put all unmarked extents on free list */ | |
| 4324 sweep_extents (); | |
| 4325 | |
| 4326 /* Put all unmarked markers on free list. | |
| 4327 Dechain each one first from the buffer into which it points. */ | |
| 4328 sweep_markers (); | |
| 4329 | |
| 4330 sweep_events (); | |
| 4331 | |
| 1204 | 4332 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 4333 sweep_key_data (); |
| 4334 sweep_button_data (); | |
| 4335 sweep_motion_data (); | |
| 4336 sweep_process_data (); | |
| 4337 sweep_timeout_data (); | |
| 4338 sweep_magic_data (); | |
| 4339 sweep_magic_eval_data (); | |
| 4340 sweep_eval_data (); | |
| 4341 sweep_misc_user_data (); | |
| 1204 | 4342 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 3263 | 4343 #endif /* not NEW_GC */ |
| 4344 | |
| 4345 #ifndef NEW_GC | |
| 428 | 4346 #ifdef PDUMP |
| 442 | 4347 pdump_objects_unmark (); |
| 428 | 4348 #endif |
| 4349 } | |
| 3092 | 4350 #endif /* not NEW_GC */ |
| 428 | 4351 |
| 4352 /* Clearing for disksave. */ | |
| 4353 | |
| 4354 void | |
| 4355 disksave_object_finalization (void) | |
| 4356 { | |
| 4357 /* It's important that certain information from the environment not get | |
| 4358 dumped with the executable (pathnames, environment variables, etc.). | |
| 4359 To make it easier to tell when this has happened with strings(1) we | |
| 4360 clear some known-to-be-garbage blocks of memory, so that leftover | |
| 4361 results of old evaluation don't look like potential problems. | |
| 4362 But first we set some notable variables to nil and do one more GC, | |
| 4363 to turn those strings into garbage. | |
| 440 | 4364 */ |
| 428 | 4365 |
| 4366 /* Yeah, this list is pretty ad-hoc... */ | |
| 4367 Vprocess_environment = Qnil; | |
| 771 | 4368 env_initted = 0; |
| 428 | 4369 Vexec_directory = Qnil; |
| 4370 Vdata_directory = Qnil; | |
| 4371 Vsite_directory = Qnil; | |
| 4372 Vdoc_directory = Qnil; | |
| 4373 Vexec_path = Qnil; | |
| 4374 Vload_path = Qnil; | |
| 4375 /* Vdump_load_path = Qnil; */ | |
| 4376 /* Release hash tables for locate_file */ | |
| 4377 Flocate_file_clear_hashing (Qt); | |
| 771 | 4378 uncache_home_directory (); |
| 776 | 4379 zero_out_command_line_status_vars (); |
| 872 | 4380 clear_default_devices (); |
| 428 | 4381 |
| 4382 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \ | |
| 4383 defined(LOADHIST_BUILTIN)) | |
| 4384 Vload_history = Qnil; | |
| 4385 #endif | |
| 4386 Vshell_file_name = Qnil; | |
| 4387 | |
| 3092 | 4388 #ifdef NEW_GC |
| 4389 gc_full (); | |
| 4390 #else /* not NEW_GC */ | |
| 428 | 4391 garbage_collect_1 (); |
| 3092 | 4392 #endif /* not NEW_GC */ |
| 428 | 4393 |
| 4394 /* Run the disksave finalization methods of all live objects. */ | |
| 4395 disksave_object_finalization_1 (); | |
| 4396 | |
| 3092 | 4397 #ifndef NEW_GC |
| 428 | 4398 /* Zero out the uninitialized (really, unused) part of the containers |
| 4399 for the live strings. */ | |
| 4400 { | |
| 4401 struct string_chars_block *scb; | |
| 4402 for (scb = first_string_chars_block; scb; scb = scb->next) | |
| 4403 { | |
| 4404 int count = sizeof (scb->string_chars) - scb->pos; | |
| 4405 | |
| 4406 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE); | |
| 440 | 4407 if (count != 0) |
| 4408 { | |
| 4409 /* from the block's fill ptr to the end */ | |
| 4410 memset ((scb->string_chars + scb->pos), 0, count); | |
| 4411 } | |
| 428 | 4412 } |
| 4413 } | |
| 3092 | 4414 #endif /* not NEW_GC */ |
| 428 | 4415 |
| 4416 /* There, that ought to be enough... */ | |
| 4417 | |
| 4418 } | |
| 4419 | |
| 2994 | 4420 #ifdef ALLOC_TYPE_STATS |
| 4421 | |
| 2720 | 4422 static Lisp_Object |
| 2994 | 4423 gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail) |
| 2720 | 4424 { |
| 4425 /* C doesn't have local functions (or closures, or GC, or readable syntax, | |
| 4426 or portable numeric datatypes, or bit-vectors, or characters, or | |
| 4427 arrays, or exceptions, or ...) */ | |
| 4428 return cons3 (intern (name), make_int (value), tail); | |
| 4429 } | |
| 2775 | 4430 |
| 2994 | 4431 static Lisp_Object |
| 4432 object_memory_usage_stats (int set_total_gc_usage) | |
| 2720 | 4433 { |
| 4434 Lisp_Object pl = Qnil; | |
| 4435 int i; | |
| 2994 | 4436 EMACS_INT tgu_val = 0; |
| 4437 | |
| 3263 | 4438 #ifdef NEW_GC |
| 2775 | 4439 |
| 3461 | 4440 for (i = 0; i < countof (lrecord_implementations_table); i++) |
| 2720 | 4441 { |
| 4442 if (lrecord_stats[i].instances_in_use != 0) | |
| 4443 { | |
| 4444 char buf [255]; | |
| 4445 const char *name = lrecord_implementations_table[i]->name; | |
| 4446 int len = strlen (name); | |
| 4447 | |
| 4448 if (lrecord_stats[i].bytes_in_use_including_overhead != | |
| 4449 lrecord_stats[i].bytes_in_use) | |
| 4450 { | |
| 4451 sprintf (buf, "%s-storage-including-overhead", name); | |
| 4452 pl = gc_plist_hack (buf, | |
| 4453 lrecord_stats[i] | |
| 4454 .bytes_in_use_including_overhead, | |
| 4455 pl); | |
| 4456 } | |
| 4457 | |
| 4458 sprintf (buf, "%s-storage", name); | |
| 4459 pl = gc_plist_hack (buf, | |
| 4460 lrecord_stats[i].bytes_in_use, | |
| 4461 pl); | |
| 2994 | 4462 tgu_val += lrecord_stats[i].bytes_in_use_including_overhead; |
| 2720 | 4463 |
| 4464 if (name[len-1] == 's') | |
| 4465 sprintf (buf, "%ses-used", name); | |
| 4466 else | |
| 4467 sprintf (buf, "%ss-used", name); | |
| 4468 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); | |
| 4469 } | |
| 4470 } | |
| 2994 | 4471 |
| 3263 | 4472 #else /* not NEW_GC */ |
| 428 | 4473 |
| 4474 #define HACK_O_MATIC(type, name, pl) do { \ | |
| 2994 | 4475 EMACS_INT s = 0; \ |
| 428 | 4476 struct type##_block *x = current_##type##_block; \ |
| 4477 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ | |
| 2994 | 4478 tgu_val += s; \ |
| 428 | 4479 (pl) = gc_plist_hack ((name), s, (pl)); \ |
| 4480 } while (0) | |
| 4481 | |
| 442 | 4482 for (i = 0; i < lrecord_type_count; i++) |
| 428 | 4483 { |
| 4484 if (lcrecord_stats[i].bytes_in_use != 0 | |
| 4485 || lcrecord_stats[i].bytes_freed != 0 | |
| 4486 || lcrecord_stats[i].instances_on_free_list != 0) | |
| 4487 { | |
| 4488 char buf [255]; | |
| 442 | 4489 const char *name = lrecord_implementations_table[i]->name; |
| 428 | 4490 int len = strlen (name); |
| 4491 | |
| 4492 sprintf (buf, "%s-storage", name); | |
| 4493 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl); | |
| 2994 | 4494 tgu_val += lcrecord_stats[i].bytes_in_use; |
| 428 | 4495 /* Okay, simple pluralization check for `symbol-value-varalias' */ |
| 4496 if (name[len-1] == 's') | |
| 4497 sprintf (buf, "%ses-freed", name); | |
| 4498 else | |
| 4499 sprintf (buf, "%ss-freed", name); | |
| 4500 if (lcrecord_stats[i].instances_freed != 0) | |
| 4501 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl); | |
| 4502 if (name[len-1] == 's') | |
| 4503 sprintf (buf, "%ses-on-free-list", name); | |
| 4504 else | |
| 4505 sprintf (buf, "%ss-on-free-list", name); | |
| 4506 if (lcrecord_stats[i].instances_on_free_list != 0) | |
| 4507 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list, | |
| 4508 pl); | |
| 4509 if (name[len-1] == 's') | |
| 4510 sprintf (buf, "%ses-used", name); | |
| 4511 else | |
| 4512 sprintf (buf, "%ss-used", name); | |
| 4513 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl); | |
| 4514 } | |
| 4515 } | |
| 4516 | |
| 4517 HACK_O_MATIC (extent, "extent-storage", pl); | |
| 4518 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl); | |
| 4519 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl); | |
| 4520 HACK_O_MATIC (event, "event-storage", pl); | |
| 4521 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl); | |
| 4522 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl); | |
| 4523 HACK_O_MATIC (marker, "marker-storage", pl); | |
| 4524 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl); | |
| 4525 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl); | |
| 4526 HACK_O_MATIC (float, "float-storage", pl); | |
| 4527 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl); | |
| 4528 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl); | |
| 1983 | 4529 #ifdef HAVE_BIGNUM |
| 4530 HACK_O_MATIC (bignum, "bignum-storage", pl); | |
| 4531 pl = gc_plist_hack ("bignums-free", gc_count_num_bignum_freelist, pl); | |
| 4532 pl = gc_plist_hack ("bignums-used", gc_count_num_bignum_in_use, pl); | |
| 4533 #endif /* HAVE_BIGNUM */ | |
| 4534 #ifdef HAVE_RATIO | |
| 4535 HACK_O_MATIC (ratio, "ratio-storage", pl); | |
| 4536 pl = gc_plist_hack ("ratios-free", gc_count_num_ratio_freelist, pl); | |
| 4537 pl = gc_plist_hack ("ratios-used", gc_count_num_ratio_in_use, pl); | |
| 4538 #endif /* HAVE_RATIO */ | |
| 4539 #ifdef HAVE_BIGFLOAT | |
| 4540 HACK_O_MATIC (bigfloat, "bigfloat-storage", pl); | |
| 4541 pl = gc_plist_hack ("bigfloats-free", gc_count_num_bigfloat_freelist, pl); | |
| 4542 pl = gc_plist_hack ("bigfloats-used", gc_count_num_bigfloat_in_use, pl); | |
| 4543 #endif /* HAVE_BIGFLOAT */ | |
| 428 | 4544 HACK_O_MATIC (string, "string-header-storage", pl); |
| 4545 pl = gc_plist_hack ("long-strings-total-length", | |
| 4546 gc_count_string_total_size | |
| 4547 - gc_count_short_string_total_size, pl); | |
| 4548 HACK_O_MATIC (string_chars, "short-string-storage", pl); | |
| 4549 pl = gc_plist_hack ("short-strings-total-length", | |
| 4550 gc_count_short_string_total_size, pl); | |
| 4551 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl); | |
| 4552 pl = gc_plist_hack ("long-strings-used", | |
| 4553 gc_count_num_string_in_use | |
| 4554 - gc_count_num_short_string_in_use, pl); | |
| 4555 pl = gc_plist_hack ("short-strings-used", | |
| 4556 gc_count_num_short_string_in_use, pl); | |
| 4557 | |
| 4558 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl); | |
| 4559 pl = gc_plist_hack ("compiled-functions-free", | |
| 4560 gc_count_num_compiled_function_freelist, pl); | |
| 4561 pl = gc_plist_hack ("compiled-functions-used", | |
| 4562 gc_count_num_compiled_function_in_use, pl); | |
| 4563 | |
| 4564 HACK_O_MATIC (symbol, "symbol-storage", pl); | |
| 4565 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl); | |
| 4566 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl); | |
| 4567 | |
| 4568 HACK_O_MATIC (cons, "cons-storage", pl); | |
| 4569 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl); | |
| 4570 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl); | |
| 4571 | |
| 2994 | 4572 #undef HACK_O_MATIC |
| 4573 | |
| 3263 | 4574 #endif /* NEW_GC */ |
| 2994 | 4575 |
| 4576 if (set_total_gc_usage) | |
| 4577 { | |
| 4578 total_gc_usage = tgu_val; | |
| 4579 total_gc_usage_set = 1; | |
| 4580 } | |
| 4581 | |
| 4582 return pl; | |
| 4583 } | |
| 4584 | |
| 4585 DEFUN("object-memory-usage-stats", Fobject_memory_usage_stats, 0, 0 ,"", /* | |
| 4586 Return statistics about memory usage of Lisp objects. | |
| 4587 */ | |
| 4588 ()) | |
| 4589 { | |
| 4590 return object_memory_usage_stats (0); | |
| 4591 } | |
| 4592 | |
| 4593 #endif /* ALLOC_TYPE_STATS */ | |
| 4594 | |
| 4595 /* Debugging aids. */ | |
| 4596 | |
| 4597 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* | |
| 4598 Reclaim storage for Lisp objects no longer needed. | |
| 4599 Return info on amount of space in use: | |
| 4600 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) | |
| 4601 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS | |
| 4602 PLIST) | |
| 4603 where `PLIST' is a list of alternating keyword/value pairs providing | |
| 4604 more detailed information. | |
| 4605 Garbage collection happens automatically if you cons more than | |
| 4606 `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
| 4607 */ | |
| 4608 ()) | |
| 4609 { | |
| 4610 /* Record total usage for purposes of determining next GC */ | |
| 3092 | 4611 #ifdef NEW_GC |
| 4612 gc_full (); | |
| 4613 #else /* not NEW_GC */ | |
| 2994 | 4614 garbage_collect_1 (); |
| 3092 | 4615 #endif /* not NEW_GC */ |
| 2994 | 4616 |
| 4617 /* This will get set to 1, and total_gc_usage computed, as part of the | |
| 4618 call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */ | |
| 4619 total_gc_usage_set = 0; | |
| 4620 #ifdef ALLOC_TYPE_STATS | |
| 428 | 4621 /* The things we do for backwards-compatibility */ |
| 3263 | 4622 #ifdef NEW_GC |
| 2994 | 4623 return |
| 4624 list6 | |
| 4625 (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use), | |
| 4626 make_int (lrecord_stats[lrecord_type_cons] | |
| 4627 .bytes_in_use_including_overhead)), | |
| 4628 Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use), | |
| 4629 make_int (lrecord_stats[lrecord_type_symbol] | |
| 4630 .bytes_in_use_including_overhead)), | |
| 4631 Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use), | |
| 4632 make_int (lrecord_stats[lrecord_type_marker] | |
| 4633 .bytes_in_use_including_overhead)), | |
| 4634 make_int (lrecord_stats[lrecord_type_string] | |
| 4635 .bytes_in_use_including_overhead), | |
| 4636 make_int (lrecord_stats[lrecord_type_vector] | |
| 4637 .bytes_in_use_including_overhead), | |
| 4638 object_memory_usage_stats (1)); | |
| 3263 | 4639 #else /* not NEW_GC */ |
| 428 | 4640 return |
| 4641 list6 (Fcons (make_int (gc_count_num_cons_in_use), | |
| 4642 make_int (gc_count_num_cons_freelist)), | |
| 4643 Fcons (make_int (gc_count_num_symbol_in_use), | |
| 4644 make_int (gc_count_num_symbol_freelist)), | |
| 4645 Fcons (make_int (gc_count_num_marker_in_use), | |
| 4646 make_int (gc_count_num_marker_freelist)), | |
| 4647 make_int (gc_count_string_total_size), | |
| 2994 | 4648 make_int (lcrecord_stats[lrecord_type_vector].bytes_in_use + |
| 4649 lcrecord_stats[lrecord_type_vector].bytes_freed), | |
| 4650 object_memory_usage_stats (1)); | |
| 3263 | 4651 #endif /* not NEW_GC */ |
| 2994 | 4652 #else /* not ALLOC_TYPE_STATS */ |
| 4653 return Qnil; | |
| 4654 #endif /* ALLOC_TYPE_STATS */ | |
| 4655 } | |
| 428 | 4656 |
| 4657 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /* | |
| 4658 Return the number of bytes consed since the last garbage collection. | |
| 4659 \"Consed\" is a misnomer in that this actually counts allocation | |
| 4660 of all different kinds of objects, not just conses. | |
| 4661 | |
| 4662 If this value exceeds `gc-cons-threshold', a garbage collection happens. | |
| 4663 */ | |
| 4664 ()) | |
| 4665 { | |
| 4666 return make_int (consing_since_gc); | |
| 4667 } | |
| 4668 | |
| 440 | 4669 #if 0 |
| 444 | 4670 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /* |
| 801 | 4671 Return the address of the last byte XEmacs has allocated, divided by 1024. |
| 4672 This may be helpful in debugging XEmacs's memory usage. | |
| 428 | 4673 The value is divided by 1024 to make sure it will fit in a lisp integer. |
| 4674 */ | |
| 4675 ()) | |
| 4676 { | |
| 4677 return make_int ((EMACS_INT) sbrk (0) / 1024); | |
| 4678 } | |
| 440 | 4679 #endif |
| 428 | 4680 |
| 2994 | 4681 DEFUN ("total-memory-usage", Ftotal_memory_usage, 0, 0, 0, /* |
| 801 | 4682 Return the total number of bytes used by the data segment in XEmacs. |
| 4683 This may be helpful in debugging XEmacs's memory usage. | |
| 2994 | 4684 NOTE: This may or may not be accurate! It is hard to determine this |
| 4685 value in a system-independent fashion. On Windows, for example, the | |
| 4686 returned number tends to be much greater than reality. | |
| 801 | 4687 */ |
| 4688 ()) | |
| 4689 { | |
| 4690 return make_int (total_data_usage ()); | |
| 4691 } | |
| 4692 | |
| 2994 | 4693 #ifdef ALLOC_TYPE_STATS |
| 4694 DEFUN ("object-memory-usage", Fobject_memory_usage, 0, 0, 0, /* | |
| 4695 Return total number of bytes used for object storage in XEmacs. | |
| 4696 This may be helpful in debugging XEmacs's memory usage. | |
| 4697 See also `consing-since-gc' and `object-memory-usage-stats'. | |
| 4698 */ | |
| 4699 ()) | |
| 4700 { | |
| 4701 return make_int (total_gc_usage + consing_since_gc); | |
| 4702 } | |
| 4703 #endif /* ALLOC_TYPE_STATS */ | |
| 4704 | |
|
4803
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4705 #ifdef USE_VALGRIND |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4706 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
|
4707 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
|
4708 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
|
4709 */ |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4710 ()) |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4711 { |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4712 VALGRIND_DO_LEAK_CHECK; |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4713 return Qnil; |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4714 } |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4715 |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4716 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
|
4717 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
|
4718 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
|
4719 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
|
4720 */ |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4721 ()) |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4722 { |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4723 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
|
4724 return Qnil; |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4725 } |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4726 #endif /* USE_VALGRIND */ |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
4727 |
| 851 | 4728 void |
| 4729 recompute_funcall_allocation_flag (void) | |
| 4730 { | |
| 887 | 4731 funcall_allocation_flag = |
| 4732 need_to_garbage_collect || | |
| 4733 need_to_check_c_alloca || | |
| 4734 need_to_signal_post_gc; | |
| 851 | 4735 } |
| 4736 | |
| 428 | 4737 |
| 4738 int | |
| 4739 object_dead_p (Lisp_Object obj) | |
| 4740 { | |
| 4741 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) || | |
| 4742 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) || | |
| 4743 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) || | |
| 4744 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) || | |
| 4745 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) || | |
| 4746 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) || | |
| 4747 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj)))); | |
| 4748 } | |
| 4749 | |
| 4750 #ifdef MEMORY_USAGE_STATS | |
| 4751 | |
| 4752 /* Attempt to determine the actual amount of space that is used for | |
| 4753 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE". | |
| 4754 | |
| 4755 It seems that the following holds: | |
| 4756 | |
| 4757 1. When using the old allocator (malloc.c): | |
| 4758 | |
| 4759 -- blocks are always allocated in chunks of powers of two. For | |
| 4760 each block, there is an overhead of 8 bytes if rcheck is not | |
| 4761 defined, 20 bytes if it is defined. In other words, a | |
| 4762 one-byte allocation needs 8 bytes of overhead for a total of | |
| 4763 9 bytes, and needs to have 16 bytes of memory chunked out for | |
| 4764 it. | |
| 4765 | |
| 4766 2. When using the new allocator (gmalloc.c): | |
| 4767 | |
| 4768 -- blocks are always allocated in chunks of powers of two up | |
| 4769 to 4096 bytes. Larger blocks are allocated in chunks of | |
| 4770 an integral multiple of 4096 bytes. The minimum block | |
| 4771 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG | |
| 4772 is defined. There is no per-block overhead, but there | |
| 4773 is an overhead of 3*sizeof (size_t) for each 4096 bytes | |
| 4774 allocated. | |
| 4775 | |
| 4776 3. When using the system malloc, anything goes, but they are | |
| 4777 generally slower and more space-efficient than the GNU | |
| 4778 allocators. One possibly reasonable assumption to make | |
| 4779 for want of better data is that sizeof (void *), or maybe | |
| 4780 2 * sizeof (void *), is required as overhead and that | |
| 4781 blocks are allocated in the minimum required size except | |
| 4782 that some minimum block size is imposed (e.g. 16 bytes). */ | |
| 4783 | |
| 665 | 4784 Bytecount |
| 2286 | 4785 malloced_storage_size (void *UNUSED (ptr), Bytecount claimed_size, |
| 428 | 4786 struct overhead_stats *stats) |
| 4787 { | |
| 665 | 4788 Bytecount orig_claimed_size = claimed_size; |
| 428 | 4789 |
|
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
|
4790 #ifndef SYSTEM_MALLOC |
| 665 | 4791 if (claimed_size < (Bytecount) (2 * sizeof (void *))) |
| 428 | 4792 claimed_size = 2 * sizeof (void *); |
| 4793 # ifdef SUNOS_LOCALTIME_BUG | |
| 4794 if (claimed_size < 16) | |
| 4795 claimed_size = 16; | |
| 4796 # endif | |
| 4797 if (claimed_size < 4096) | |
| 4798 { | |
| 2260 | 4799 /* fxg: rename log->log2 to supress gcc3 shadow warning */ |
| 4800 int log2 = 1; | |
| 428 | 4801 |
| 4802 /* compute the log base two, more or less, then use it to compute | |
| 4803 the block size needed. */ | |
| 4804 claimed_size--; | |
| 4805 /* It's big, it's heavy, it's wood! */ | |
| 4806 while ((claimed_size /= 2) != 0) | |
| 2260 | 4807 ++log2; |
| 428 | 4808 claimed_size = 1; |
| 4809 /* It's better than bad, it's good! */ | |
| 2260 | 4810 while (log2 > 0) |
| 428 | 4811 { |
| 4812 claimed_size *= 2; | |
| 2260 | 4813 log2--; |
| 428 | 4814 } |
| 4815 /* We have to come up with some average about the amount of | |
| 4816 blocks used. */ | |
| 665 | 4817 if ((Bytecount) (rand () & 4095) < claimed_size) |
| 428 | 4818 claimed_size += 3 * sizeof (void *); |
| 4819 } | |
| 4820 else | |
| 4821 { | |
| 4822 claimed_size += 4095; | |
| 4823 claimed_size &= ~4095; | |
| 4824 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t); | |
| 4825 } | |
| 4826 | |
|
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
|
4827 #else |
| 428 | 4828 |
| 4829 if (claimed_size < 16) | |
| 4830 claimed_size = 16; | |
| 4831 claimed_size += 2 * sizeof (void *); | |
| 4832 | |
|
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
|
4833 #endif /* system allocator */ |
| 428 | 4834 |
| 4835 if (stats) | |
| 4836 { | |
| 4837 stats->was_requested += orig_claimed_size; | |
| 4838 stats->malloc_overhead += claimed_size - orig_claimed_size; | |
| 4839 } | |
| 4840 return claimed_size; | |
| 4841 } | |
| 4842 | |
| 3263 | 4843 #ifndef NEW_GC |
| 665 | 4844 Bytecount |
| 4845 fixed_type_block_overhead (Bytecount size) | |
| 428 | 4846 { |
| 665 | 4847 Bytecount per_block = TYPE_ALLOC_SIZE (cons, unsigned char); |
| 4848 Bytecount overhead = 0; | |
| 4849 Bytecount storage_size = malloced_storage_size (0, per_block, 0); | |
| 428 | 4850 while (size >= per_block) |
| 4851 { | |
| 4852 size -= per_block; | |
| 4853 overhead += sizeof (void *) + per_block - storage_size; | |
| 4854 } | |
| 4855 if (rand () % per_block < size) | |
| 4856 overhead += sizeof (void *) + per_block - storage_size; | |
| 4857 return overhead; | |
| 4858 } | |
| 3263 | 4859 #endif /* not NEW_GC */ |
| 428 | 4860 #endif /* MEMORY_USAGE_STATS */ |
| 4861 | |
| 4862 | |
| 4863 /* Initialization */ | |
| 771 | 4864 static void |
| 1204 | 4865 common_init_alloc_early (void) |
| 428 | 4866 { |
| 771 | 4867 #ifndef Qzero |
| 4868 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ | |
| 4869 #endif | |
| 4870 | |
| 4871 #ifndef Qnull_pointer | |
| 4872 /* C guarantees that Qnull_pointer will be initialized to all 0 bits, | |
| 4873 so the following is actually a no-op. */ | |
| 793 | 4874 Qnull_pointer = wrap_pointer_1 (0); |
| 771 | 4875 #endif |
| 4876 | |
| 3263 | 4877 #ifndef NEW_GC |
| 428 | 4878 breathing_space = 0; |
| 4879 all_lcrecords = 0; | |
| 3263 | 4880 #endif /* not NEW_GC */ |
| 428 | 4881 ignore_malloc_warnings = 1; |
| 4882 #ifdef DOUG_LEA_MALLOC | |
| 4883 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ | |
| 4884 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ | |
| 4885 #if 0 /* Moved to emacs.c */ | |
| 4886 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */ | |
| 4887 #endif | |
| 4888 #endif | |
| 3092 | 4889 #ifndef NEW_GC |
| 2720 | 4890 init_string_chars_alloc (); |
| 428 | 4891 init_string_alloc (); |
| 4892 init_string_chars_alloc (); | |
| 4893 init_cons_alloc (); | |
| 4894 init_symbol_alloc (); | |
| 4895 init_compiled_function_alloc (); | |
| 4896 init_float_alloc (); | |
| 1983 | 4897 #ifdef HAVE_BIGNUM |
| 4898 init_bignum_alloc (); | |
| 4899 #endif | |
| 4900 #ifdef HAVE_RATIO | |
| 4901 init_ratio_alloc (); | |
| 4902 #endif | |
| 4903 #ifdef HAVE_BIGFLOAT | |
| 4904 init_bigfloat_alloc (); | |
| 4905 #endif | |
| 428 | 4906 init_marker_alloc (); |
| 4907 init_extent_alloc (); | |
| 4908 init_event_alloc (); | |
| 1204 | 4909 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 4910 init_key_data_alloc (); |
| 4911 init_button_data_alloc (); | |
| 4912 init_motion_data_alloc (); | |
| 4913 init_process_data_alloc (); | |
| 4914 init_timeout_data_alloc (); | |
| 4915 init_magic_data_alloc (); | |
| 4916 init_magic_eval_data_alloc (); | |
| 4917 init_eval_data_alloc (); | |
| 4918 init_misc_user_data_alloc (); | |
| 1204 | 4919 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 3263 | 4920 #endif /* not NEW_GC */ |
| 428 | 4921 |
| 4922 ignore_malloc_warnings = 0; | |
| 4923 | |
| 452 | 4924 if (staticpros_nodump) |
| 4925 Dynarr_free (staticpros_nodump); | |
| 4926 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); | |
| 4927 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */ | |
| 771 | 4928 #ifdef DEBUG_XEMACS |
| 4929 if (staticpro_nodump_names) | |
| 4930 Dynarr_free (staticpro_nodump_names); | |
| 4931 staticpro_nodump_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 4932 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */ | |
| 4933 #endif | |
| 428 | 4934 |
| 3263 | 4935 #ifdef NEW_GC |
| 2720 | 4936 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); |
| 4937 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
| 4938 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
| 4939 #ifdef DEBUG_XEMACS | |
| 4940 mcpro_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 4941 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ | |
| 4942 dump_add_root_block_ptr (&mcpro_names, &mcpro_names_description); | |
| 4943 #endif | |
| 3263 | 4944 #endif /* NEW_GC */ |
| 2720 | 4945 |
| 428 | 4946 consing_since_gc = 0; |
| 851 | 4947 need_to_check_c_alloca = 0; |
| 4948 funcall_allocation_flag = 0; | |
| 4949 funcall_alloca_count = 0; | |
| 814 | 4950 |
| 428 | 4951 lrecord_uid_counter = 259; |
| 3263 | 4952 #ifndef NEW_GC |
| 428 | 4953 debug_string_purity = 0; |
| 3263 | 4954 #endif /* not NEW_GC */ |
| 428 | 4955 |
| 800 | 4956 #ifdef ERROR_CHECK_TYPES |
| 428 | 4957 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = |
| 4958 666; | |
| 4959 ERROR_ME_NOT. | |
| 4960 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42; | |
| 4961 ERROR_ME_WARN. | |
| 4962 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 4963 3333632; | |
| 793 | 4964 ERROR_ME_DEBUG_WARN. |
| 4965 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 4966 8675309; | |
| 800 | 4967 #endif /* ERROR_CHECK_TYPES */ |
| 428 | 4968 } |
| 4969 | |
| 3263 | 4970 #ifndef NEW_GC |
| 771 | 4971 static void |
| 4972 init_lcrecord_lists (void) | |
| 4973 { | |
| 4974 int i; | |
| 4975 | |
| 4976 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 4977 { | |
| 4978 all_lcrecord_lists[i] = Qzero; /* Qnil not yet set */ | |
| 4979 staticpro_nodump (&all_lcrecord_lists[i]); | |
| 4980 } | |
| 4981 } | |
| 3263 | 4982 #endif /* not NEW_GC */ |
| 771 | 4983 |
| 4984 void | |
| 1204 | 4985 init_alloc_early (void) |
| 771 | 4986 { |
| 1204 | 4987 #if defined (__cplusplus) && defined (ERROR_CHECK_GC) |
| 4988 static struct gcpro initial_gcpro; | |
| 4989 | |
| 4990 initial_gcpro.next = 0; | |
| 4991 initial_gcpro.var = &Qnil; | |
| 4992 initial_gcpro.nvars = 1; | |
| 4993 gcprolist = &initial_gcpro; | |
| 4994 #else | |
| 4995 gcprolist = 0; | |
| 4996 #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */ | |
| 4997 } | |
| 4998 | |
| 4999 void | |
| 5000 reinit_alloc_early (void) | |
| 5001 { | |
| 5002 common_init_alloc_early (); | |
| 3263 | 5003 #ifndef NEW_GC |
| 771 | 5004 init_lcrecord_lists (); |
| 3263 | 5005 #endif /* not NEW_GC */ |
| 771 | 5006 } |
| 5007 | |
| 428 | 5008 void |
| 5009 init_alloc_once_early (void) | |
| 5010 { | |
| 1204 | 5011 common_init_alloc_early (); |
| 428 | 5012 |
| 442 | 5013 { |
| 5014 int i; | |
| 5015 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 5016 lrecord_implementations_table[i] = 0; | |
| 5017 } | |
| 5018 | |
| 5019 INIT_LRECORD_IMPLEMENTATION (cons); | |
| 5020 INIT_LRECORD_IMPLEMENTATION (vector); | |
| 5021 INIT_LRECORD_IMPLEMENTATION (string); | |
| 3092 | 5022 #ifdef NEW_GC |
| 5023 INIT_LRECORD_IMPLEMENTATION (string_indirect_data); | |
| 5024 INIT_LRECORD_IMPLEMENTATION (string_direct_data); | |
| 5025 #endif /* NEW_GC */ | |
| 3263 | 5026 #ifndef NEW_GC |
| 442 | 5027 INIT_LRECORD_IMPLEMENTATION (lcrecord_list); |
| 1204 | 5028 INIT_LRECORD_IMPLEMENTATION (free); |
| 3263 | 5029 #endif /* not NEW_GC */ |
| 428 | 5030 |
| 452 | 5031 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); |
| 5032 Dynarr_resize (staticpros, 1410); /* merely a small optimization */ | |
| 2367 | 5033 dump_add_root_block_ptr (&staticpros, &staticpros_description); |
| 771 | 5034 #ifdef DEBUG_XEMACS |
| 5035 staticpro_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 5036 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */ | |
| 2367 | 5037 dump_add_root_block_ptr (&staticpro_names, &staticpro_names_description); |
| 771 | 5038 #endif |
| 5039 | |
| 3263 | 5040 #ifdef NEW_GC |
| 2720 | 5041 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); |
| 5042 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
| 5043 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
| 5044 #ifdef DEBUG_XEMACS | |
| 5045 mcpro_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 5046 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ | |
| 5047 dump_add_root_block_ptr (&mcpro_names, &mcpro_names_description); | |
| 5048 #endif | |
| 3263 | 5049 #else /* not NEW_GC */ |
| 771 | 5050 init_lcrecord_lists (); |
| 3263 | 5051 #endif /* not NEW_GC */ |
| 428 | 5052 } |
| 5053 | |
| 5054 void | |
| 5055 syms_of_alloc (void) | |
| 5056 { | |
| 442 | 5057 DEFSYMBOL (Qgarbage_collecting); |
| 428 | 5058 |
| 5059 DEFSUBR (Fcons); | |
| 5060 DEFSUBR (Flist); | |
| 5061 DEFSUBR (Fvector); | |
| 5062 DEFSUBR (Fbit_vector); | |
| 5063 DEFSUBR (Fmake_byte_code); | |
| 5064 DEFSUBR (Fmake_list); | |
| 5065 DEFSUBR (Fmake_vector); | |
| 5066 DEFSUBR (Fmake_bit_vector); | |
| 5067 DEFSUBR (Fmake_string); | |
| 5068 DEFSUBR (Fstring); | |
| 5069 DEFSUBR (Fmake_symbol); | |
| 5070 DEFSUBR (Fmake_marker); | |
| 5071 DEFSUBR (Fpurecopy); | |
| 2994 | 5072 #ifdef ALLOC_TYPE_STATS |
| 5073 DEFSUBR (Fobject_memory_usage_stats); | |
| 5074 DEFSUBR (Fobject_memory_usage); | |
| 5075 #endif /* ALLOC_TYPE_STATS */ | |
| 428 | 5076 DEFSUBR (Fgarbage_collect); |
| 440 | 5077 #if 0 |
| 428 | 5078 DEFSUBR (Fmemory_limit); |
| 440 | 5079 #endif |
| 2994 | 5080 DEFSUBR (Ftotal_memory_usage); |
| 428 | 5081 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
|
5082 #ifdef USE_VALGRIND |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5083 DEFSUBR (Fvalgrind_leak_check); |
|
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5084 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
|
5085 #endif |
| 428 | 5086 } |
| 5087 | |
| 5088 void | |
| 5089 vars_of_alloc (void) | |
| 5090 { | |
| 5091 #ifdef DEBUG_XEMACS | |
| 5092 DEFVAR_INT ("debug-allocation", &debug_allocation /* | |
| 5093 If non-zero, print out information to stderr about all objects allocated. | |
| 5094 See also `debug-allocation-backtrace-length'. | |
| 5095 */ ); | |
| 5096 debug_allocation = 0; | |
| 5097 | |
| 5098 DEFVAR_INT ("debug-allocation-backtrace-length", | |
| 5099 &debug_allocation_backtrace_length /* | |
| 5100 Length (in stack frames) of short backtrace printed out by `debug-allocation'. | |
| 5101 */ ); | |
| 5102 debug_allocation_backtrace_length = 2; | |
| 5103 #endif | |
| 5104 | |
| 5105 DEFVAR_BOOL ("purify-flag", &purify_flag /* | |
| 5106 Non-nil means loading Lisp code in order to dump an executable. | |
| 5107 This means that certain objects should be allocated in readonly space. | |
| 5108 */ ); | |
| 5109 } |