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