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.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
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
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
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. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
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.
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
46 #include "backtrace.h"
57 #include "redisplay.h"
58 #include "specifier.h"
62 #include "console-stream.h"
64 #ifdef DOUG_LEA_MALLOC
72 EXFUN (Fgarbage_collect, 0);
74 #if 0 /* this is _way_ too slow to be part of the standard debug options */
75 #if defined(DEBUG_XEMACS) && defined(MULE)
76 #define VERIFY_STRING_CHARS_INTEGRITY
80 /* Define this to use malloc/free with no freelist for all datatypes,
81 the hope being that some debugging tools may help detect
82 freed memory references */
83 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
85 #define ALLOC_NO_POOLS
89 static int debug_allocation;
90 static int debug_allocation_backtrace_length;
93 /* Number of bytes of consing done since the last gc */
94 EMACS_INT consing_since_gc;
95 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
97 #define debug_allocation_backtrace() \
99 if (debug_allocation_backtrace_length > 0) \
100 debug_short_backtrace (debug_allocation_backtrace_length); \
104 #define INCREMENT_CONS_COUNTER(foosize, type) \
106 if (debug_allocation) \
108 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
109 debug_allocation_backtrace (); \
111 INCREMENT_CONS_COUNTER_1 (foosize); \
113 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
115 if (debug_allocation > 1) \
117 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
118 debug_allocation_backtrace (); \
120 INCREMENT_CONS_COUNTER_1 (foosize); \
123 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
124 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
125 INCREMENT_CONS_COUNTER_1 (size)
128 #define DECREMENT_CONS_COUNTER(size) do { \
129 consing_since_gc -= (size); \
130 if (consing_since_gc < 0) \
131 consing_since_gc = 0; \
134 /* Number of bytes of consing since gc before another gc should be done. */
135 EMACS_INT gc_cons_threshold;
137 /* Nonzero during gc */
140 /* Number of times GC has happened at this level or below.
141 * Level 0 is most volatile, contrary to usual convention.
142 * (Of course, there's only one level at present) */
143 EMACS_INT gc_generation_number[1];
145 /* This is just for use by the printer, to allow things to print uniquely */
146 static int lrecord_uid_counter;
148 /* Nonzero when calling certain hooks or doing other things where
150 int gc_currently_forbidden;
153 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
154 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
156 /* "Garbage collecting" */
157 Lisp_Object Vgc_message;
158 Lisp_Object Vgc_pointer_glyph;
159 static const char gc_default_message[] = "Garbage collecting";
160 Lisp_Object Qgarbage_collecting;
162 #ifndef VIRT_ADDR_VARIES
164 #endif /* VIRT_ADDR_VARIES */
165 EMACS_INT malloc_sbrk_used;
167 #ifndef VIRT_ADDR_VARIES
169 #endif /* VIRT_ADDR_VARIES */
170 EMACS_INT malloc_sbrk_unused;
172 /* Non-zero means we're in the process of doing the dump */
175 #ifdef ERROR_CHECK_TYPECHECK
177 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
182 c_readonly (Lisp_Object obj)
184 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
188 lisp_readonly (Lisp_Object obj)
190 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
194 /* Maximum amount of C stack to save when a GC happens. */
196 #ifndef MAX_SAVE_STACK
197 #define MAX_SAVE_STACK 0 /* 16000 */
200 /* Non-zero means ignore malloc warnings. Set during initialization. */
201 int ignore_malloc_warnings;
204 static void *breathing_space;
207 release_breathing_space (void)
211 void *tmp = breathing_space;
217 /* malloc calls this if it finds we are near exhausting storage */
219 malloc_warning (const char *str)
221 if (ignore_malloc_warnings)
227 "Killing some buffers may delay running out of memory.\n"
228 "However, certainly by the time you receive the 95%% warning,\n"
229 "you should clean up, kill this Emacs, and start a new one.",
233 /* Called if malloc returns zero */
237 /* Force a GC next time eval is called.
238 It's better to loop garbage-collecting (we might reclaim enough
239 to win) than to loop beeping and barfing "Memory exhausted"
241 consing_since_gc = gc_cons_threshold + 1;
242 release_breathing_space ();
244 /* Flush some histories which might conceivably contain garbalogical
246 if (!NILP (Fboundp (Qvalues)))
247 Fset (Qvalues, Qnil);
248 Vcommand_history = Qnil;
250 error ("Memory exhausted");
253 /* like malloc and realloc but check for no memory left, and block input. */
257 xmalloc (size_t size)
259 void *val = malloc (size);
261 if (!val && (size != 0)) memory_full ();
267 xcalloc (size_t nelem, size_t elsize)
269 void *val = calloc (nelem, elsize);
271 if (!val && (nelem != 0)) memory_full ();
276 xmalloc_and_zero (size_t size)
278 return xcalloc (size, sizeof (char));
283 xrealloc (void *block, size_t size)
285 /* We must call malloc explicitly when BLOCK is 0, since some
286 reallocs don't do this. */
287 void *val = block ? realloc (block, size) : malloc (size);
289 if (!val && (size != 0)) memory_full ();
294 #ifdef ERROR_CHECK_MALLOC
295 xfree_1 (void *block)
300 #ifdef ERROR_CHECK_MALLOC
301 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
302 error until much later on for many system mallocs, such as
303 the one that comes with Solaris 2.3. FMH!! */
304 assert (block != (void *) 0xDEADBEEF);
306 #endif /* ERROR_CHECK_MALLOC */
310 #ifdef ERROR_CHECK_GC
313 typedef unsigned int four_byte_t;
314 #elif SIZEOF_LONG == 4
315 typedef unsigned long four_byte_t;
316 #elif SIZEOF_SHORT == 4
317 typedef unsigned short four_byte_t;
319 What kind of strange-ass system are we running on?
323 deadbeef_memory (void *ptr, size_t size)
325 four_byte_t *ptr4 = (four_byte_t *) ptr;
326 size_t beefs = size >> 2;
328 /* In practice, size will always be a multiple of four. */
330 (*ptr4++) = 0xDEADBEEF;
333 #else /* !ERROR_CHECK_GC */
336 #define deadbeef_memory(ptr, size)
338 #endif /* !ERROR_CHECK_GC */
342 xstrdup (const char *str)
344 int len = strlen (str) + 1; /* for stupid terminating 0 */
346 void *val = xmalloc (len);
347 if (val == 0) return 0;
348 return (char *) memcpy (val, str, len);
353 strdup (const char *s)
357 #endif /* NEED_STRDUP */
361 allocate_lisp_storage (size_t size)
363 return xmalloc (size);
367 /* lcrecords are chained together through their "next" field.
368 After doing the mark phase, GC will walk this linked list
369 and free any lcrecord which hasn't been marked. */
370 static struct lcrecord_header *all_lcrecords;
373 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
375 struct lcrecord_header *lcheader;
378 ((implementation->static_size == 0 ?
379 implementation->size_in_bytes_method != NULL :
380 implementation->static_size == size)
382 (! implementation->basic_p)
384 (! (implementation->hash == NULL && implementation->equal != NULL)));
386 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
387 set_lheader_implementation (&lcheader->lheader, implementation);
388 lcheader->next = all_lcrecords;
389 #if 1 /* mly prefers to see small ID numbers */
390 lcheader->uid = lrecord_uid_counter++;
391 #else /* jwz prefers to see real addrs */
392 lcheader->uid = (int) &lcheader;
395 all_lcrecords = lcheader;
396 INCREMENT_CONS_COUNTER (size, implementation->name);
400 #if 0 /* Presently unused */
401 /* Very, very poor man's EGC?
402 * This may be slow and thrash pages all over the place.
403 * Only call it if you really feel you must (and if the
404 * lrecord was fairly recently allocated).
405 * Otherwise, just let the GC do its job -- that's what it's there for
408 free_lcrecord (struct lcrecord_header *lcrecord)
410 if (all_lcrecords == lcrecord)
412 all_lcrecords = lcrecord->next;
416 struct lrecord_header *header = all_lcrecords;
419 struct lrecord_header *next = header->next;
420 if (next == lcrecord)
422 header->next = lrecord->next;
431 if (lrecord->implementation->finalizer)
432 lrecord->implementation->finalizer (lrecord, 0);
440 disksave_object_finalization_1 (void)
442 struct lcrecord_header *header;
444 for (header = all_lcrecords; header; header = header->next)
446 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
448 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
453 /************************************************************************/
454 /* Debugger support */
455 /************************************************************************/
456 /* Give gdb/dbx enough information to decode Lisp Objects. We make
457 sure certain symbols are always defined, so gdb doesn't complain
458 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
459 to see how this is used. */
461 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
462 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
464 #ifdef USE_UNION_TYPE
465 unsigned char dbg_USE_UNION_TYPE = 1;
467 unsigned char dbg_USE_UNION_TYPE = 0;
470 unsigned char dbg_valbits = VALBITS;
471 unsigned char dbg_gctypebits = GCTYPEBITS;
473 /* Macros turned into functions for ease of debugging.
474 Debuggers don't know about macros! */
475 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
477 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
479 return EQ (obj1, obj2);
483 /************************************************************************/
484 /* Fixed-size type macros */
485 /************************************************************************/
487 /* For fixed-size types that are commonly used, we malloc() large blocks
488 of memory at a time and subdivide them into chunks of the correct
489 size for an object of that type. This is more efficient than
490 malloc()ing each object separately because we save on malloc() time
491 and overhead due to the fewer number of malloc()ed blocks, and
492 also because we don't need any extra pointers within each object
493 to keep them threaded together for GC purposes. For less common
494 (and frequently large-size) types, we use lcrecords, which are
495 malloc()ed individually and chained together through a pointer
496 in the lcrecord header. lcrecords do not need to be fixed-size
497 (i.e. two objects of the same type need not have the same size;
498 however, the size of a particular object cannot vary dynamically).
499 It is also much easier to create a new lcrecord type because no
500 additional code needs to be added to alloc.c. Finally, lcrecords
501 may be more efficient when there are only a small number of them.
503 The types that are stored in these large blocks (or "frob blocks")
504 are cons, float, compiled-function, symbol, marker, extent, event,
507 Note that strings are special in that they are actually stored in
508 two parts: a structure containing information about the string, and
509 the actual data associated with the string. The former structure
510 (a struct Lisp_String) is a fixed-size structure and is managed the
511 same way as all the other such types. This structure contains a
512 pointer to the actual string data, which is stored in structures of
513 type struct string_chars_block. Each string_chars_block consists
514 of a pointer to a struct Lisp_String, followed by the data for that
515 string, followed by another pointer to a Lisp_String, followed by
516 the data for that string, etc. At GC time, the data in these
517 blocks is compacted by searching sequentially through all the
518 blocks and compressing out any holes created by unmarked strings.
519 Strings that are more than a certain size (bigger than the size of
520 a string_chars_block, although something like half as big might
521 make more sense) are malloc()ed separately and not stored in
522 string_chars_blocks. Furthermore, no one string stretches across
523 two string_chars_blocks.
525 Vectors are each malloc()ed separately, similar to lcrecords.
527 In the following discussion, we use conses, but it applies equally
528 well to the other fixed-size types.
530 We store cons cells inside of cons_blocks, allocating a new
531 cons_block with malloc() whenever necessary. Cons cells reclaimed
532 by GC are put on a free list to be reallocated before allocating
533 any new cons cells from the latest cons_block. Each cons_block is
534 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
535 the versions in malloc.c and gmalloc.c) really allocates in units
536 of powers of two and uses 4 bytes for its own overhead.
538 What GC actually does is to search through all the cons_blocks,
539 from the most recently allocated to the oldest, and put all
540 cons cells that are not marked (whether or not they're already
541 free) on a cons_free_list. The cons_free_list is a stack, and
542 so the cons cells in the oldest-allocated cons_block end up
543 at the head of the stack and are the first to be reallocated.
544 If any cons_block is entirely free, it is freed with free()
545 and its cons cells removed from the cons_free_list. Because
546 the cons_free_list ends up basically in memory order, we have
547 a high locality of reference (assuming a reasonable turnover
548 of allocating and freeing) and have a reasonable probability
549 of entirely freeing up cons_blocks that have been more recently
550 allocated. This stage is called the "sweep stage" of GC, and
551 is executed after the "mark stage", which involves starting
552 from all places that are known to point to in-use Lisp objects
553 (e.g. the obarray, where are all symbols are stored; the
554 current catches and condition-cases; the backtrace list of
555 currently executing functions; the gcpro list; etc.) and
556 recursively marking all objects that are accessible.
558 At the beginning of the sweep stage, the conses in the cons
559 blocks are in one of three states: in use and marked, in use
560 but not marked, and not in use (already freed). Any conses
561 that are marked have been marked in the mark stage just
562 executed, because as part of the sweep stage we unmark any
563 marked objects. The way we tell whether or not a cons cell
564 is in use is through the FREE_STRUCT_P macro. This basically
565 looks at the first 4 bytes (or however many bytes a pointer
566 fits in) to see if all the bits in those bytes are 1. The
567 resulting value (0xFFFFFFFF) is not a valid pointer and is
568 not a valid Lisp_Object. All current fixed-size types have
569 a pointer or Lisp_Object as their first element with the
570 exception of strings; they have a size value, which can
571 never be less than zero, and so 0xFFFFFFFF is invalid for
572 strings as well. Now assuming that a cons cell is in use,
573 the way we tell whether or not it is marked is to look at
574 the mark bit of its car (each Lisp_Object has one bit
575 reserved as a mark bit, in case it's needed). Note that
576 different types of objects use different fields to indicate
577 whether the object is marked, but the principle is the same.
579 Conses on the free_cons_list are threaded through a pointer
580 stored in the bytes directly after the bytes that are set
581 to 0xFFFFFFFF (we cannot overwrite these because the cons
582 is still in a cons_block and needs to remain marked as
583 not in use for the next time that GC happens). This
584 implies that all fixed-size types must be at least big
585 enough to store two pointers, which is indeed the case
586 for all current fixed-size types.
588 Some types of objects need additional "finalization" done
589 when an object is converted from in use to not in use;
590 this is the purpose of the ADDITIONAL_FREE_type macro.
591 For example, markers need to be removed from the chain
592 of markers that is kept in each buffer. This is because
593 markers in a buffer automatically disappear if the marker
594 is no longer referenced anywhere (the same does not
595 apply to extents, however).
597 WARNING: Things are in an extremely bizarre state when
598 the ADDITIONAL_FREE_type macros are called, so beware!
600 When ERROR_CHECK_GC is defined, we do things differently
601 so as to maximize our chances of catching places where
602 there is insufficient GCPROing. The thing we want to
603 avoid is having an object that we're using but didn't
604 GCPRO get freed by GC and then reallocated while we're
605 in the process of using it -- this will result in something
606 seemingly unrelated getting trashed, and is extremely
607 difficult to track down. If the object gets freed but
608 not reallocated, we can usually catch this because we
609 set all bytes of a freed object to 0xDEADBEEF. (The
610 first four bytes, however, are 0xFFFFFFFF, and the next
611 four are a pointer used to chain freed objects together;
612 we play some tricks with this pointer to make it more
613 bogus, so crashes are more likely to occur right away.)
615 We want freed objects to stay free as long as possible,
616 so instead of doing what we do above, we maintain the
617 free objects in a first-in first-out queue. We also
618 don't recompute the free list each GC, unlike above;
619 this ensures that the queue ordering is preserved.
620 [This means that we are likely to have worse locality
621 of reference, and that we can never free a frob block
622 once it's allocated. (Even if we know that all cells
623 in it are free, there's no easy way to remove all those
624 cells from the free list because the objects on the
625 free list are unlikely to be in memory order.)]
626 Furthermore, we never take objects off the free list
627 unless there's a large number (usually 1000, but
628 varies depending on type) of them already on the list.
629 This way, we ensure that an object that gets freed will
630 remain free for the next 1000 (or whatever) times that
631 an object of that type is allocated. */
633 #ifndef MALLOC_OVERHEAD
635 #define MALLOC_OVERHEAD 0
636 #elif defined (rcheck)
637 #define MALLOC_OVERHEAD 20
639 #define MALLOC_OVERHEAD 8
641 #endif /* MALLOC_OVERHEAD */
643 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
644 /* If we released our reserve (due to running out of memory),
645 and we have a fair amount free once again,
646 try to set aside another reserve in case we run out once more.
648 This is called when a relocatable block is freed in ralloc.c. */
649 void refill_memory_reserve (void);
651 refill_memory_reserve (void)
653 if (breathing_space == 0)
654 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
658 #ifdef ALLOC_NO_POOLS
659 # define TYPE_ALLOC_SIZE(type, structtype) 1
661 # define TYPE_ALLOC_SIZE(type, structtype) \
662 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
663 / sizeof (structtype))
664 #endif /* ALLOC_NO_POOLS */
666 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
668 struct type##_block \
670 struct type##_block *prev; \
671 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
674 static struct type##_block *current_##type##_block; \
675 static int current_##type##_block_index; \
677 static structtype *type##_free_list; \
678 static structtype *type##_free_list_tail; \
681 init_##type##_alloc (void) \
683 current_##type##_block = 0; \
684 current_##type##_block_index = \
685 countof (current_##type##_block->block); \
686 type##_free_list = 0; \
687 type##_free_list_tail = 0; \
690 static int gc_count_num_##type##_in_use; \
691 static int gc_count_num_##type##_freelist
693 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
694 if (current_##type##_block_index \
695 == countof (current_##type##_block->block)) \
697 struct type##_block *AFTFB_new = (struct type##_block *) \
698 allocate_lisp_storage (sizeof (struct type##_block)); \
699 AFTFB_new->prev = current_##type##_block; \
700 current_##type##_block = AFTFB_new; \
701 current_##type##_block_index = 0; \
704 &(current_##type##_block->block[current_##type##_block_index++]); \
707 /* Allocate an instance of a type that is stored in blocks.
708 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
711 #ifdef ERROR_CHECK_GC
713 /* Note: if you get crashes in this function, suspect incorrect calls
714 to free_cons() and friends. This happened once because the cons
715 cell was not GC-protected and was getting collected before
716 free_cons() was called. */
718 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
721 if (gc_count_num_##type##_freelist > \
722 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
724 result = type##_free_list; \
725 /* Before actually using the chain pointer, we complement all its \
726 bits; see FREE_FIXED_TYPE(). */ \
728 (structtype *) ~(unsigned long) \
729 (* (structtype **) ((char *) result + sizeof (void *))); \
730 gc_count_num_##type##_freelist--; \
733 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
734 MARK_STRUCT_AS_NOT_FREE (result); \
737 #else /* !ERROR_CHECK_GC */
739 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
742 if (type##_free_list) \
744 result = type##_free_list; \
746 * (structtype **) ((char *) result + sizeof (void *)); \
749 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
750 MARK_STRUCT_AS_NOT_FREE (result); \
753 #endif /* !ERROR_CHECK_GC */
755 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
758 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
759 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
762 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
765 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
766 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
769 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
770 to a Lisp object and invalid as an actual Lisp_Object value. We have
771 to make sure that this value cannot be an integer in Lisp_Object form.
772 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
773 On a 32-bit system, the type bits will be non-zero, making the value
774 be a pointer, and the pointer will be misaligned.
776 Even if Emacs is run on some weirdo system that allows and allocates
777 byte-aligned pointers, this pointer is at the very top of the address
778 space and so it's almost inconceivable that it could ever be valid. */
781 # define INVALID_POINTER_VALUE 0xFFFFFFFF
783 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
785 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
787 You have some weird system and need to supply a reasonable value here.
790 /* The construct (* (void **) (ptr)) would cause aliasing problems
791 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
792 But `char *' can legally alias any pointer. Hence this union trick. */
793 typedef union { char c; void *p; } *aliasing_voidpp;
794 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
795 (((aliasing_voidpp) (ptr))->p)
796 #define FREE_STRUCT_P(ptr) \
797 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
798 #define MARK_STRUCT_AS_FREE(ptr) \
799 (ALIASING_VOIDPP_DEREFERENCE (ptr) = (void *) INVALID_POINTER_VALUE)
800 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
801 (ALIASING_VOIDPP_DEREFERENCE (ptr) = 0)
803 #ifdef ERROR_CHECK_GC
805 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
806 do { if (type##_free_list_tail) \
808 /* When we store the chain pointer, we complement all \
809 its bits; this should significantly increase its \
810 bogosity in case someone tries to use the value, and \
811 should make us dump faster if someone stores something \
812 over the pointer because when it gets un-complemented in \
813 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
814 extremely bogus. */ \
816 ((char *) type##_free_list_tail + sizeof (void *)) = \
817 (structtype *) ~(unsigned long) ptr; \
820 type##_free_list = ptr; \
821 type##_free_list_tail = ptr; \
824 #else /* !ERROR_CHECK_GC */
826 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
827 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
829 type##_free_list = (ptr); \
832 #endif /* !ERROR_CHECK_GC */
834 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
836 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
837 structtype *FFT_ptr = (ptr); \
838 ADDITIONAL_FREE_##type (FFT_ptr); \
839 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
840 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
841 MARK_STRUCT_AS_FREE (FFT_ptr); \
844 /* Like FREE_FIXED_TYPE() but used when we are explicitly
845 freeing a structure through free_cons(), free_marker(), etc.
846 rather than through the normal process of sweeping.
847 We attempt to undo the changes made to the allocation counters
848 as a result of this structure being allocated. This is not
849 completely necessary but helps keep things saner: e.g. this way,
850 repeatedly allocating and freeing a cons will not result in
851 the consing-since-gc counter advancing, which would cause a GC
852 and somewhat defeat the purpose of explicitly freeing. */
854 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
855 do { FREE_FIXED_TYPE (type, structtype, ptr); \
856 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
857 gc_count_num_##type##_freelist++; \
862 /************************************************************************/
863 /* Cons allocation */
864 /************************************************************************/
866 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
867 /* conses are used and freed so often that we set this really high */
868 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
869 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
872 mark_cons (Lisp_Object obj)
874 if (NILP (XCDR (obj)))
877 mark_object (XCAR (obj));
882 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
885 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
889 if (! CONSP (ob1) || ! CONSP (ob2))
890 return internal_equal (ob1, ob2, depth);
895 static const struct lrecord_description cons_description[] = {
896 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
897 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
901 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
902 mark_cons, print_cons, 0,
905 * No `hash' method needed.
906 * internal_hash knows how to
913 DEFUN ("cons", Fcons, 2, 2, 0, /*
914 Create a new cons, give it CAR and CDR as components, and return it.
918 /* This cannot GC. */
922 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
923 set_lheader_implementation (&c->lheader, &lrecord_cons);
930 /* This is identical to Fcons() but it used for conses that we're
931 going to free later, and is useful when trying to track down
934 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
939 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
940 set_lheader_implementation (&c->lheader, &lrecord_cons);
947 DEFUN ("list", Flist, 0, MANY, 0, /*
948 Return a newly created list with specified arguments as elements.
949 Any number of arguments, even zero arguments, are allowed.
951 (int nargs, Lisp_Object *args))
953 Lisp_Object val = Qnil;
954 Lisp_Object *argp = args + nargs;
957 val = Fcons (*--argp, val);
962 list1 (Lisp_Object obj0)
964 /* This cannot GC. */
965 return Fcons (obj0, Qnil);
969 list2 (Lisp_Object obj0, Lisp_Object obj1)
971 /* This cannot GC. */
972 return Fcons (obj0, Fcons (obj1, Qnil));
976 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
978 /* This cannot GC. */
979 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
983 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
985 /* This cannot GC. */
986 return Fcons (obj0, Fcons (obj1, obj2));
990 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
992 return Fcons (Fcons (key, value), alist);
996 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
998 /* This cannot GC. */
999 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1003 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1006 /* This cannot GC. */
1007 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1011 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1012 Lisp_Object obj4, Lisp_Object obj5)
1014 /* This cannot GC. */
1015 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1018 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1019 Return a new list of length LENGTH, with each element being INIT.
1023 CHECK_NATNUM (length);
1026 Lisp_Object val = Qnil;
1027 size_t size = XINT (length);
1030 val = Fcons (init, val);
1036 /************************************************************************/
1037 /* Float allocation */
1038 /************************************************************************/
1040 #ifdef LISP_FLOAT_TYPE
1042 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1043 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1046 make_float (double float_value)
1051 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1053 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1054 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1057 set_lheader_implementation (&f->lheader, &lrecord_float);
1058 float_data (f) = float_value;
1063 #endif /* LISP_FLOAT_TYPE */
1066 /************************************************************************/
1067 /* Vector allocation */
1068 /************************************************************************/
1071 mark_vector (Lisp_Object obj)
1073 Lisp_Vector *ptr = XVECTOR (obj);
1074 int len = vector_length (ptr);
1077 for (i = 0; i < len - 1; i++)
1078 mark_object (ptr->contents[i]);
1079 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1083 size_vector (const void *lheader)
1085 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents,
1086 ((Lisp_Vector *) lheader)->size);
1090 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1092 int len = XVECTOR_LENGTH (obj1);
1093 if (len != XVECTOR_LENGTH (obj2))
1097 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1098 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1100 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1107 vector_hash (Lisp_Object obj, int depth)
1109 return HASH2 (XVECTOR_LENGTH (obj),
1110 internal_array_hash (XVECTOR_DATA (obj),
1111 XVECTOR_LENGTH (obj),
1115 static const struct lrecord_description vector_description[] = {
1116 { XD_LONG, offsetof (Lisp_Vector, size) },
1117 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1121 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1122 mark_vector, print_vector, 0,
1126 size_vector, Lisp_Vector);
1128 /* #### should allocate `small' vectors from a frob-block */
1129 static Lisp_Vector *
1130 make_vector_internal (size_t sizei)
1132 /* no vector_next */
1133 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1134 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1141 make_vector (size_t length, Lisp_Object init)
1143 Lisp_Vector *vecp = make_vector_internal (length);
1144 Lisp_Object *p = vector_data (vecp);
1151 XSETVECTOR (vector, vecp);
1156 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1157 Return a new vector of length LENGTH, with each element being INIT.
1158 See also the function `vector'.
1162 CONCHECK_NATNUM (length);
1163 return make_vector (XINT (length), init);
1166 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1167 Return a newly created vector with specified arguments as elements.
1168 Any number of arguments, even zero arguments, are allowed.
1170 (int nargs, Lisp_Object *args))
1172 Lisp_Vector *vecp = make_vector_internal (nargs);
1173 Lisp_Object *p = vector_data (vecp);
1180 XSETVECTOR (vector, vecp);
1186 vector1 (Lisp_Object obj0)
1188 return Fvector (1, &obj0);
1192 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1194 Lisp_Object args[2];
1197 return Fvector (2, args);
1201 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1203 Lisp_Object args[3];
1207 return Fvector (3, args);
1210 #if 0 /* currently unused */
1213 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1216 Lisp_Object args[4];
1221 return Fvector (4, args);
1225 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1226 Lisp_Object obj3, Lisp_Object obj4)
1228 Lisp_Object args[5];
1234 return Fvector (5, args);
1238 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1239 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1241 Lisp_Object args[6];
1248 return Fvector (6, args);
1252 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1253 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1256 Lisp_Object args[7];
1264 return Fvector (7, args);
1268 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1269 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1270 Lisp_Object obj6, Lisp_Object obj7)
1272 Lisp_Object args[8];
1281 return Fvector (8, args);
1285 /************************************************************************/
1286 /* Bit Vector allocation */
1287 /************************************************************************/
1289 static Lisp_Object all_bit_vectors;
1291 /* #### should allocate `small' bit vectors from a frob-block */
1292 static Lisp_Bit_Vector *
1293 make_bit_vector_internal (size_t sizei)
1295 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1296 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1297 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1298 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1300 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1302 bit_vector_length (p) = sizei;
1303 bit_vector_next (p) = all_bit_vectors;
1304 /* make sure the extra bits in the last long are 0; the calling
1305 functions might not set them. */
1306 p->bits[num_longs - 1] = 0;
1307 XSETBIT_VECTOR (all_bit_vectors, p);
1312 make_bit_vector (size_t length, Lisp_Object init)
1314 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1315 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1320 memset (p->bits, 0, num_longs * sizeof (long));
1323 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1324 memset (p->bits, ~0, num_longs * sizeof (long));
1325 /* But we have to make sure that the unused bits in the
1326 last long are 0, so that equal/hash is easy. */
1328 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1332 Lisp_Object bit_vector;
1333 XSETBIT_VECTOR (bit_vector, p);
1339 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1342 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1344 for (i = 0; i < length; i++)
1345 set_bit_vector_bit (p, i, bytevec[i]);
1348 Lisp_Object bit_vector;
1349 XSETBIT_VECTOR (bit_vector, p);
1354 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1355 Return a new bit vector of length LENGTH. with each bit being INIT.
1356 Each element is set to INIT. See also the function `bit-vector'.
1360 CONCHECK_NATNUM (length);
1362 return make_bit_vector (XINT (length), init);
1365 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1366 Return a newly created bit vector with specified arguments as elements.
1367 Any number of arguments, even zero arguments, are allowed.
1369 (int nargs, Lisp_Object *args))
1372 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1374 for (i = 0; i < nargs; i++)
1376 CHECK_BIT (args[i]);
1377 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1381 Lisp_Object bit_vector;
1382 XSETBIT_VECTOR (bit_vector, p);
1388 /************************************************************************/
1389 /* Compiled-function allocation */
1390 /************************************************************************/
1392 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1393 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1396 make_compiled_function (void)
1398 Lisp_Compiled_Function *f;
1401 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1402 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1405 f->specpdl_depth = 0;
1406 f->flags.documentationp = 0;
1407 f->flags.interactivep = 0;
1408 f->flags.domainp = 0; /* I18N3 */
1409 f->instructions = Qzero;
1410 f->constants = Qzero;
1412 f->doc_and_interactive = Qnil;
1413 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1414 f->annotated = Qnil;
1416 XSETCOMPILED_FUNCTION (fun, f);
1420 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1421 Return a new compiled-function object.
1422 Usage: (arglist instructions constants stack-depth
1423 &optional doc-string interactive)
1424 Note that, unlike all other emacs-lisp functions, calling this with five
1425 arguments is NOT the same as calling it with six arguments, the last of
1426 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1427 that this function was defined with `(interactive)'. If the arg is not
1428 specified, then that means the function is not interactive.
1429 This is terrible behavior which is retained for compatibility with old
1430 `.elc' files which expect these semantics.
1432 (int nargs, Lisp_Object *args))
1434 /* In a non-insane world this function would have this arglist...
1435 (arglist instructions constants stack_depth &optional doc_string interactive)
1437 Lisp_Object fun = make_compiled_function ();
1438 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1440 Lisp_Object arglist = args[0];
1441 Lisp_Object instructions = args[1];
1442 Lisp_Object constants = args[2];
1443 Lisp_Object stack_depth = args[3];
1444 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1445 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1447 if (nargs < 4 || nargs > 6)
1448 return Fsignal (Qwrong_number_of_arguments,
1449 list2 (intern ("make-byte-code"), make_int (nargs)));
1451 /* Check for valid formal parameter list now, to allow us to use
1452 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1454 Lisp_Object symbol, tail;
1455 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1457 CHECK_SYMBOL (symbol);
1458 if (EQ (symbol, Qt) ||
1459 EQ (symbol, Qnil) ||
1460 SYMBOL_IS_KEYWORD (symbol))
1461 signal_simple_error_2
1462 ("Invalid constant symbol in formal parameter list",
1466 f->arglist = arglist;
1468 /* `instructions' is a string or a cons (string . int) for a
1469 lazy-loaded function. */
1470 if (CONSP (instructions))
1472 CHECK_STRING (XCAR (instructions));
1473 CHECK_INT (XCDR (instructions));
1477 CHECK_STRING (instructions);
1479 f->instructions = instructions;
1481 if (!NILP (constants))
1482 CHECK_VECTOR (constants);
1483 f->constants = constants;
1485 CHECK_NATNUM (stack_depth);
1486 f->stack_depth = (unsigned short) XINT (stack_depth);
1488 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1489 if (!NILP (Vcurrent_compiled_function_annotation))
1490 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1491 else if (!NILP (Vload_file_name_internal_the_purecopy))
1492 f->annotated = Vload_file_name_internal_the_purecopy;
1493 else if (!NILP (Vload_file_name_internal))
1495 struct gcpro gcpro1;
1496 GCPRO1 (fun); /* don't let fun get reaped */
1497 Vload_file_name_internal_the_purecopy =
1498 Ffile_name_nondirectory (Vload_file_name_internal);
1499 f->annotated = Vload_file_name_internal_the_purecopy;
1502 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1504 /* doc_string may be nil, string, int, or a cons (string . int).
1505 interactive may be list or string (or unbound). */
1506 f->doc_and_interactive = Qunbound;
1508 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1509 f->doc_and_interactive = Vfile_domain;
1511 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1513 f->doc_and_interactive
1514 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1515 Fcons (interactive, f->doc_and_interactive));
1517 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1519 f->doc_and_interactive
1520 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1521 Fcons (doc_string, f->doc_and_interactive));
1523 if (UNBOUNDP (f->doc_and_interactive))
1524 f->doc_and_interactive = Qnil;
1530 /************************************************************************/
1531 /* Symbol allocation */
1532 /************************************************************************/
1534 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1535 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1537 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1538 Return a newly allocated uninterned symbol whose name is NAME.
1539 Its value and function definition are void, and its property list is nil.
1546 CHECK_STRING (name);
1548 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1549 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1550 p->name = XSTRING (name);
1552 p->value = Qunbound;
1553 p->function = Qunbound;
1554 symbol_next (p) = 0;
1555 XSETSYMBOL (val, p);
1560 /************************************************************************/
1561 /* Extent allocation */
1562 /************************************************************************/
1564 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1565 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1568 allocate_extent (void)
1572 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1573 set_lheader_implementation (&e->lheader, &lrecord_extent);
1574 extent_object (e) = Qnil;
1575 set_extent_start (e, -1);
1576 set_extent_end (e, -1);
1581 extent_face (e) = Qnil;
1582 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1583 e->flags.detachable = 1;
1589 /************************************************************************/
1590 /* Event allocation */
1591 /************************************************************************/
1593 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1594 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1597 allocate_event (void)
1602 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1603 set_lheader_implementation (&e->lheader, &lrecord_event);
1610 /************************************************************************/
1611 /* Marker allocation */
1612 /************************************************************************/
1614 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1615 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1617 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1618 Return a new marker which does not point at any place.
1625 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1626 set_lheader_implementation (&p->lheader, &lrecord_marker);
1629 marker_next (p) = 0;
1630 marker_prev (p) = 0;
1631 p->insertion_type = 0;
1632 XSETMARKER (val, p);
1637 noseeum_make_marker (void)
1642 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1643 set_lheader_implementation (&p->lheader, &lrecord_marker);
1646 marker_next (p) = 0;
1647 marker_prev (p) = 0;
1648 p->insertion_type = 0;
1649 XSETMARKER (val, p);
1654 /************************************************************************/
1655 /* String allocation */
1656 /************************************************************************/
1658 /* The data for "short" strings generally resides inside of structs of type
1659 string_chars_block. The Lisp_String structure is allocated just like any
1660 other Lisp object (except for vectors), and these are freelisted when
1661 they get garbage collected. The data for short strings get compacted,
1662 but the data for large strings do not.
1664 Previously Lisp_String structures were relocated, but this caused a lot
1665 of bus-errors because the C code didn't include enough GCPRO's for
1666 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1667 that the reference would get relocated).
1669 This new method makes things somewhat bigger, but it is MUCH safer. */
1671 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1672 /* strings are used and freed quite often */
1673 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1674 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1677 mark_string (Lisp_Object obj)
1679 Lisp_String *ptr = XSTRING (obj);
1681 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1682 flush_cached_extent_info (XCAR (ptr->plist));
1687 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1690 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1691 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1694 static const struct lrecord_description string_description[] = {
1695 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1696 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1697 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1701 /* We store the string's extent info as the first element of the string's
1702 property list; and the string's MODIFF as the first or second element
1703 of the string's property list (depending on whether the extent info
1704 is present), but only if the string has been modified. This is ugly
1705 but it reduces the memory allocated for the string in the vast
1706 majority of cases, where the string is never modified and has no
1709 #### This means you can't use an int as a key in a string's plist. */
1711 static Lisp_Object *
1712 string_plist_ptr (Lisp_Object string)
1714 Lisp_Object *ptr = &XSTRING (string)->plist;
1716 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1718 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1724 string_getprop (Lisp_Object string, Lisp_Object property)
1726 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1730 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1732 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1737 string_remprop (Lisp_Object string, Lisp_Object property)
1739 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1743 string_plist (Lisp_Object string)
1745 return *string_plist_ptr (string);
1748 /* No `finalize', or `hash' methods.
1749 internal_hash() already knows how to hash strings and finalization
1750 is done with the ADDITIONAL_FREE_string macro, which is the
1751 standard way to do finalization when using
1752 SWEEP_FIXED_TYPE_BLOCK(). */
1753 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1754 mark_string, print_string,
1763 /* String blocks contain this many useful bytes. */
1764 #define STRING_CHARS_BLOCK_SIZE \
1765 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1766 ((2 * sizeof (struct string_chars_block *)) \
1767 + sizeof (EMACS_INT))))
1768 /* Block header for small strings. */
1769 struct string_chars_block
1772 struct string_chars_block *next;
1773 struct string_chars_block *prev;
1774 /* Contents of string_chars_block->string_chars are interleaved
1775 string_chars structures (see below) and the actual string data */
1776 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1779 static struct string_chars_block *first_string_chars_block;
1780 static struct string_chars_block *current_string_chars_block;
1782 /* If SIZE is the length of a string, this returns how many bytes
1783 * the string occupies in string_chars_block->string_chars
1784 * (including alignment padding).
1786 #define STRING_FULLSIZE(size) \
1787 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1788 ALIGNOF (Lisp_String *))
1790 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1791 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1795 Lisp_String *string;
1796 unsigned char chars[1];
1799 struct unused_string_chars
1801 Lisp_String *string;
1806 init_string_chars_alloc (void)
1808 first_string_chars_block = xnew (struct string_chars_block);
1809 first_string_chars_block->prev = 0;
1810 first_string_chars_block->next = 0;
1811 first_string_chars_block->pos = 0;
1812 current_string_chars_block = first_string_chars_block;
1815 static struct string_chars *
1816 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1819 struct string_chars *s_chars;
1822 (countof (current_string_chars_block->string_chars)
1823 - current_string_chars_block->pos))
1825 /* This string can fit in the current string chars block */
1826 s_chars = (struct string_chars *)
1827 (current_string_chars_block->string_chars
1828 + current_string_chars_block->pos);
1829 current_string_chars_block->pos += fullsize;
1833 /* Make a new current string chars block */
1834 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1836 current_string_chars_block->next = new_scb;
1837 new_scb->prev = current_string_chars_block;
1839 current_string_chars_block = new_scb;
1840 new_scb->pos = fullsize;
1841 s_chars = (struct string_chars *)
1842 current_string_chars_block->string_chars;
1845 s_chars->string = string_it_goes_with;
1847 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1853 make_uninit_string (Bytecount length)
1856 EMACS_INT fullsize = STRING_FULLSIZE (length);
1859 assert (length >= 0 && fullsize > 0);
1861 /* Allocate the string header */
1862 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1863 set_lheader_implementation (&s->lheader, &lrecord_string);
1865 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1866 ? xnew_array (Bufbyte, length + 1)
1867 : allocate_string_chars_struct (s, fullsize)->chars);
1869 set_string_length (s, length);
1872 set_string_byte (s, length, 0);
1874 XSETSTRING (val, s);
1878 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1879 static void verify_string_chars_integrity (void);
1882 /* Resize the string S so that DELTA bytes can be inserted starting
1883 at POS. If DELTA < 0, it means deletion starting at POS. If
1884 POS < 0, resize the string but don't copy any characters. Use
1885 this if you're planning on completely overwriting the string.
1889 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1891 Bytecount oldfullsize, newfullsize;
1892 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1893 verify_string_chars_integrity ();
1896 #ifdef ERROR_CHECK_BUFPOS
1899 assert (pos <= string_length (s));
1901 assert (pos + (-delta) <= string_length (s));
1906 assert ((-delta) <= string_length (s));
1908 #endif /* ERROR_CHECK_BUFPOS */
1911 /* simplest case: no size change. */
1914 if (pos >= 0 && delta < 0)
1915 /* If DELTA < 0, the functions below will delete the characters
1916 before POS. We want to delete characters *after* POS, however,
1917 so convert this to the appropriate form. */
1920 oldfullsize = STRING_FULLSIZE (string_length (s));
1921 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1923 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1925 if (BIG_STRING_FULLSIZE_P (newfullsize))
1927 /* Both strings are big. We can just realloc().
1928 But careful! If the string is shrinking, we have to
1929 memmove() _before_ realloc(), and if growing, we have to
1930 memmove() _after_ realloc() - otherwise the access is
1931 illegal, and we might crash. */
1932 Bytecount len = string_length (s) + 1 - pos;
1934 if (delta < 0 && pos >= 0)
1935 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1936 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1937 string_length (s) + delta + 1));
1938 if (delta > 0 && pos >= 0)
1939 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1941 else /* String has been demoted from BIG_STRING. */
1944 allocate_string_chars_struct (s, newfullsize)->chars;
1945 Bufbyte *old_data = string_data (s);
1949 memcpy (new_data, old_data, pos);
1950 memcpy (new_data + pos + delta, old_data + pos,
1951 string_length (s) + 1 - pos);
1953 set_string_data (s, new_data);
1957 else /* old string is small */
1959 if (oldfullsize == newfullsize)
1961 /* special case; size change but the necessary
1962 allocation size won't change (up or down; code
1963 somewhere depends on there not being any unused
1964 allocation space, modulo any alignment
1968 Bufbyte *addroff = pos + string_data (s);
1970 memmove (addroff + delta, addroff,
1971 /* +1 due to zero-termination. */
1972 string_length (s) + 1 - pos);
1977 Bufbyte *old_data = string_data (s);
1979 BIG_STRING_FULLSIZE_P (newfullsize)
1980 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1981 : allocate_string_chars_struct (s, newfullsize)->chars;
1985 memcpy (new_data, old_data, pos);
1986 memcpy (new_data + pos + delta, old_data + pos,
1987 string_length (s) + 1 - pos);
1989 set_string_data (s, new_data);
1992 /* We need to mark this chunk of the string_chars_block
1993 as unused so that compact_string_chars() doesn't
1995 struct string_chars *old_s_chars = (struct string_chars *)
1996 ((char *) old_data - offsetof (struct string_chars, chars));
1997 /* Sanity check to make sure we aren't hosed by strange
1998 alignment/padding. */
1999 assert (old_s_chars->string == s);
2000 MARK_STRUCT_AS_FREE (old_s_chars);
2001 ((struct unused_string_chars *) old_s_chars)->fullsize =
2007 set_string_length (s, string_length (s) + delta);
2008 /* If pos < 0, the string won't be zero-terminated.
2009 Terminate now just to make sure. */
2010 string_data (s)[string_length (s)] = '\0';
2016 XSETSTRING (string, s);
2017 /* We also have to adjust all of the extent indices after the
2018 place we did the change. We say "pos - 1" because
2019 adjust_extents() is exclusive of the starting position
2021 adjust_extents (string, pos - 1, string_length (s),
2025 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2026 verify_string_chars_integrity ();
2033 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2035 Bufbyte newstr[MAX_EMCHAR_LEN];
2036 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2037 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2038 Bytecount newlen = set_charptr_emchar (newstr, c);
2040 if (oldlen != newlen)
2041 resize_string (s, bytoff, newlen - oldlen);
2042 /* Remember, string_data (s) might have changed so we can't cache it. */
2043 memcpy (string_data (s) + bytoff, newstr, newlen);
2048 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2049 Return a new string of length LENGTH, with each character being INIT.
2050 LENGTH must be an integer and INIT must be a character.
2054 CHECK_NATNUM (length);
2055 CHECK_CHAR_COERCE_INT (init);
2057 Bufbyte init_str[MAX_EMCHAR_LEN];
2058 int len = set_charptr_emchar (init_str, XCHAR (init));
2059 Lisp_Object val = make_uninit_string (len * XINT (length));
2062 /* Optimize the single-byte case */
2063 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2067 Bufbyte *ptr = XSTRING_DATA (val);
2069 for (i = XINT (length); i; i--)
2071 Bufbyte *init_ptr = init_str;
2075 case 6: *ptr++ = *init_ptr++;
2076 case 5: *ptr++ = *init_ptr++;
2078 case 4: *ptr++ = *init_ptr++;
2079 case 3: *ptr++ = *init_ptr++;
2080 case 2: *ptr++ = *init_ptr++;
2081 case 1: *ptr++ = *init_ptr++;
2089 DEFUN ("string", Fstring, 0, MANY, 0, /*
2090 Concatenate all the argument characters and make the result a string.
2092 (int nargs, Lisp_Object *args))
2094 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2095 Bufbyte *p = storage;
2097 for (; nargs; nargs--, args++)
2099 Lisp_Object lisp_char = *args;
2100 CHECK_CHAR_COERCE_INT (lisp_char);
2101 p += set_charptr_emchar (p, XCHAR (lisp_char));
2103 return make_string (storage, p - storage);
2107 /* Take some raw memory, which MUST already be in internal format,
2108 and package it up into a Lisp string. */
2110 make_string (const Bufbyte *contents, Bytecount length)
2114 /* Make sure we find out about bad make_string's when they happen */
2115 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2116 bytecount_to_charcount (contents, length); /* Just for the assertions */
2119 val = make_uninit_string (length);
2120 memcpy (XSTRING_DATA (val), contents, length);
2124 /* Take some raw memory, encoded in some external data format,
2125 and convert it into a Lisp string. */
2127 make_ext_string (const Extbyte *contents, EMACS_INT length,
2128 Lisp_Object coding_system)
2131 TO_INTERNAL_FORMAT (DATA, (contents, length),
2132 LISP_STRING, string,
2138 build_string (const char *str)
2140 /* Some strlen's crash and burn if passed null. */
2141 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2145 build_ext_string (const char *str, Lisp_Object coding_system)
2147 /* Some strlen's crash and burn if passed null. */
2148 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2153 build_translated_string (const char *str)
2155 return build_string (GETTEXT (str));
2159 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2164 /* Make sure we find out about bad make_string_nocopy's when they happen */
2165 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2166 bytecount_to_charcount (contents, length); /* Just for the assertions */
2169 /* Allocate the string header */
2170 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2171 set_lheader_implementation (&s->lheader, &lrecord_string);
2172 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2174 set_string_data (s, (Bufbyte *)contents);
2175 set_string_length (s, length);
2177 XSETSTRING (val, s);
2182 /************************************************************************/
2183 /* lcrecord lists */
2184 /************************************************************************/
2186 /* Lcrecord lists are used to manage the allocation of particular
2187 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2188 malloc() and garbage-collection junk) as much as possible.
2189 It is similar to the Blocktype class.
2193 1) Create an lcrecord-list object using make_lcrecord_list().
2194 This is often done at initialization. Remember to staticpro_nodump
2195 this object! The arguments to make_lcrecord_list() are the
2196 same as would be passed to alloc_lcrecord().
2197 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2198 and pass the lcrecord-list earlier created.
2199 3) When done with the lcrecord, call free_managed_lcrecord().
2200 The standard freeing caveats apply: ** make sure there are no
2201 pointers to the object anywhere! **
2202 4) Calling free_managed_lcrecord() is just like kissing the
2203 lcrecord goodbye as if it were garbage-collected. This means:
2204 -- the contents of the freed lcrecord are undefined, and the
2205 contents of something produced by allocate_managed_lcrecord()
2206 are undefined, just like for alloc_lcrecord().
2207 -- the mark method for the lcrecord's type will *NEVER* be called
2209 -- the finalize method for the lcrecord's type will be called
2210 at the time that free_managed_lcrecord() is called.
2215 mark_lcrecord_list (Lisp_Object obj)
2217 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2218 Lisp_Object chain = list->free;
2220 while (!NILP (chain))
2222 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2223 struct free_lcrecord_header *free_header =
2224 (struct free_lcrecord_header *) lheader;
2227 (/* There should be no other pointers to the free list. */
2228 ! MARKED_RECORD_HEADER_P (lheader)
2230 /* Only lcrecords should be here. */
2231 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2233 /* Only free lcrecords should be here. */
2234 free_header->lcheader.free
2236 /* The type of the lcrecord must be right. */
2237 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2239 /* So must the size. */
2240 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2241 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2244 MARK_RECORD_HEADER (lheader);
2245 chain = free_header->chain;
2251 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2252 mark_lcrecord_list, internal_object_printer,
2253 0, 0, 0, 0, struct lcrecord_list);
2255 make_lcrecord_list (size_t size,
2256 const struct lrecord_implementation *implementation)
2258 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2259 &lrecord_lcrecord_list);
2262 p->implementation = implementation;
2265 XSETLCRECORD_LIST (val, p);
2270 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2272 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2273 if (!NILP (list->free))
2275 Lisp_Object val = list->free;
2276 struct free_lcrecord_header *free_header =
2277 (struct free_lcrecord_header *) XPNTR (val);
2279 #ifdef ERROR_CHECK_GC
2280 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2282 /* There should be no other pointers to the free list. */
2283 assert (! MARKED_RECORD_HEADER_P (lheader));
2284 /* Only lcrecords should be here. */
2285 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2286 /* Only free lcrecords should be here. */
2287 assert (free_header->lcheader.free);
2288 /* The type of the lcrecord must be right. */
2289 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2290 /* So must the size. */
2291 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2292 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2293 #endif /* ERROR_CHECK_GC */
2295 list->free = free_header->chain;
2296 free_header->lcheader.free = 0;
2303 XSETOBJ (val, Lisp_Type_Record,
2304 alloc_lcrecord (list->size, list->implementation));
2310 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2312 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2313 struct free_lcrecord_header *free_header =
2314 (struct free_lcrecord_header *) XPNTR (lcrecord);
2315 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2316 const struct lrecord_implementation *implementation
2317 = LHEADER_IMPLEMENTATION (lheader);
2319 /* Make sure the size is correct. This will catch, for example,
2320 putting a window configuration on the wrong free list. */
2321 gc_checking_assert ((implementation->size_in_bytes_method ?
2322 implementation->size_in_bytes_method (lheader) :
2323 implementation->static_size)
2326 if (implementation->finalizer)
2327 implementation->finalizer (lheader, 0);
2328 free_header->chain = list->free;
2329 free_header->lcheader.free = 1;
2330 list->free = lcrecord;
2336 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2337 Kept for compatibility, returns its argument.
2339 Make a copy of OBJECT in pure storage.
2340 Recursively copies contents of vectors and cons cells.
2341 Does not copy symbols.
2349 /************************************************************************/
2350 /* Garbage Collection */
2351 /************************************************************************/
2353 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2354 Additional ones may be defined by a module (none yet). We leave some
2355 room in `lrecord_implementations_table' for such new lisp object types. */
2356 #define MODULE_DEFINABLE_TYPE_COUNT 32
2357 const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT];
2359 /* Object marker functions are in the lrecord_implementation structure.
2360 But copying them to a parallel array is much more cache-friendly.
2361 This hack speeds up (garbage-collect) by about 5%. */
2362 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2364 struct gcpro *gcprolist;
2366 /* 415 used Mly 29-Jun-93 */
2367 /* 1327 used slb 28-Feb-98 */
2368 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2370 #define NSTATICS 4000
2372 #define NSTATICS 2000
2375 /* Not "static" because used by dumper.c */
2376 Lisp_Object *staticvec[NSTATICS];
2379 /* Put an entry in staticvec, pointing at the variable whose address is given
2382 staticpro (Lisp_Object *varaddress)
2384 /* #### This is now a dubious assert() since this routine may be called */
2385 /* by Lisp attempting to load a DLL. */
2386 assert (staticidx < countof (staticvec));
2387 staticvec[staticidx++] = varaddress;
2391 Lisp_Object *staticvec_nodump[200];
2392 int staticidx_nodump;
2394 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2397 staticpro_nodump (Lisp_Object *varaddress)
2399 /* #### This is now a dubious assert() since this routine may be called */
2400 /* by Lisp attempting to load a DLL. */
2401 assert (staticidx_nodump < countof (staticvec_nodump));
2402 staticvec_nodump[staticidx_nodump++] = varaddress;
2406 struct pdump_dumpstructinfo dumpstructvec[200];
2409 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2412 dumpstruct (void *varaddress, const struct struct_description *desc)
2414 assert (dumpstructidx < countof (dumpstructvec));
2415 dumpstructvec[dumpstructidx].data = varaddress;
2416 dumpstructvec[dumpstructidx].desc = desc;
2420 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2423 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2426 dumpopaque (void *varaddress, size_t size)
2428 assert (dumpopaqueidx < countof (dumpopaquevec));
2430 dumpopaquevec[dumpopaqueidx].data = varaddress;
2431 dumpopaquevec[dumpopaqueidx].size = size;
2435 Lisp_Object *pdump_wirevec[50];
2438 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2441 pdump_wire (Lisp_Object *varaddress)
2443 assert (pdump_wireidx < countof (pdump_wirevec));
2444 pdump_wirevec[pdump_wireidx++] = varaddress;
2448 Lisp_Object *pdump_wirevec_list[50];
2449 int pdump_wireidx_list;
2451 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2454 pdump_wire_list (Lisp_Object *varaddress)
2456 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2457 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2460 #ifdef ERROR_CHECK_GC
2461 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2462 struct lrecord_header * GCLI_lh = (lheader); \
2463 assert (GCLI_lh != 0); \
2464 assert (GCLI_lh->type < lrecord_type_count); \
2465 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2466 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2467 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2470 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2474 /* Mark reference to a Lisp_Object. If the object referred to has not been
2475 seen yet, recursively mark all the references contained in it. */
2478 mark_object (Lisp_Object obj)
2482 /* Checks we used to perform */
2483 /* if (EQ (obj, Qnull_pointer)) return; */
2484 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2485 /* if (PURIFIED (XPNTR (obj))) return; */
2487 if (XTYPE (obj) == Lisp_Type_Record)
2489 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2491 GC_CHECK_LHEADER_INVARIANTS (lheader);
2493 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2494 ! ((struct lcrecord_header *) lheader)->free);
2496 /* All c_readonly objects have their mark bit set,
2497 so that we only need to check the mark bit here. */
2498 if (! MARKED_RECORD_HEADER_P (lheader))
2500 MARK_RECORD_HEADER (lheader);
2502 if (RECORD_MARKER (lheader))
2504 obj = RECORD_MARKER (lheader) (obj);
2505 if (!NILP (obj)) goto tail_recurse;
2511 /* mark all of the conses in a list and mark the final cdr; but
2512 DO NOT mark the cars.
2514 Use only for internal lists! There should never be other pointers
2515 to the cons cells, because if so, the cars will remain unmarked
2516 even when they maybe should be marked. */
2518 mark_conses_in_list (Lisp_Object obj)
2522 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2524 if (CONS_MARKED_P (XCONS (rest)))
2526 MARK_CONS (XCONS (rest));
2533 /* Find all structures not marked, and free them. */
2535 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2536 static int gc_count_bit_vector_storage;
2537 static int gc_count_num_short_string_in_use;
2538 static int gc_count_string_total_size;
2539 static int gc_count_short_string_total_size;
2541 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2544 /* stats on lcrecords in use - kinda kludgy */
2548 int instances_in_use;
2550 int instances_freed;
2552 int instances_on_free_list;
2553 } lcrecord_stats [countof (lrecord_implementations_table)];
2556 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2558 unsigned int type_index = h->type;
2560 if (((struct lcrecord_header *) h)->free)
2562 gc_checking_assert (!free_p);
2563 lcrecord_stats[type_index].instances_on_free_list++;
2567 const struct lrecord_implementation *implementation =
2568 LHEADER_IMPLEMENTATION (h);
2570 size_t sz = (implementation->size_in_bytes_method ?
2571 implementation->size_in_bytes_method (h) :
2572 implementation->static_size);
2575 lcrecord_stats[type_index].instances_freed++;
2576 lcrecord_stats[type_index].bytes_freed += sz;
2580 lcrecord_stats[type_index].instances_in_use++;
2581 lcrecord_stats[type_index].bytes_in_use += sz;
2587 /* Free all unmarked records */
2589 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2591 struct lcrecord_header *header;
2593 /* int total_size = 0; */
2595 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2597 /* First go through and call all the finalize methods.
2598 Then go through and free the objects. There used to
2599 be only one loop here, with the call to the finalizer
2600 occurring directly before the xfree() below. That
2601 is marginally faster but much less safe -- if the
2602 finalize method for an object needs to reference any
2603 other objects contained within it (and many do),
2604 we could easily be screwed by having already freed that
2607 for (header = *prev; header; header = header->next)
2609 struct lrecord_header *h = &(header->lheader);
2611 GC_CHECK_LHEADER_INVARIANTS (h);
2613 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2615 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2616 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2620 for (header = *prev; header; )
2622 struct lrecord_header *h = &(header->lheader);
2623 if (MARKED_RECORD_HEADER_P (h))
2625 if (! C_READONLY_RECORD_HEADER_P (h))
2626 UNMARK_RECORD_HEADER (h);
2628 /* total_size += n->implementation->size_in_bytes (h);*/
2629 /* #### May modify header->next on a C_READONLY lcrecord */
2630 prev = &(header->next);
2632 tick_lcrecord_stats (h, 0);
2636 struct lcrecord_header *next = header->next;
2638 tick_lcrecord_stats (h, 1);
2639 /* used to call finalizer right here. */
2645 /* *total = total_size; */
2650 sweep_bit_vectors_1 (Lisp_Object *prev,
2651 int *used, int *total, int *storage)
2653 Lisp_Object bit_vector;
2656 int total_storage = 0;
2658 /* BIT_VECTORP fails because the objects are marked, which changes
2659 their implementation */
2660 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2662 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2664 if (MARKED_RECORD_P (bit_vector))
2666 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2667 UNMARK_RECORD_HEADER (&(v->lheader));
2671 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2672 BIT_VECTOR_LONG_STORAGE (len));
2674 /* #### May modify next on a C_READONLY bitvector */
2675 prev = &(bit_vector_next (v));
2680 Lisp_Object next = bit_vector_next (v);
2687 *total = total_size;
2688 *storage = total_storage;
2691 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2692 to make macros prettier. */
2694 #ifdef ERROR_CHECK_GC
2696 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2698 struct typename##_block *SFTB_current; \
2699 struct typename##_block **SFTB_prev; \
2701 int num_free = 0, num_used = 0; \
2703 for (SFTB_prev = ¤t_##typename##_block, \
2704 SFTB_current = current_##typename##_block, \
2705 SFTB_limit = current_##typename##_block_index; \
2711 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2713 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2715 if (FREE_STRUCT_P (SFTB_victim)) \
2719 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2723 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2726 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2731 UNMARK_##typename (SFTB_victim); \
2734 SFTB_prev = &(SFTB_current->prev); \
2735 SFTB_current = SFTB_current->prev; \
2736 SFTB_limit = countof (current_##typename##_block->block); \
2739 gc_count_num_##typename##_in_use = num_used; \
2740 gc_count_num_##typename##_freelist = num_free; \
2743 #else /* !ERROR_CHECK_GC */
2745 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2747 struct typename##_block *SFTB_current; \
2748 struct typename##_block **SFTB_prev; \
2750 int num_free = 0, num_used = 0; \
2752 typename##_free_list = 0; \
2754 for (SFTB_prev = ¤t_##typename##_block, \
2755 SFTB_current = current_##typename##_block, \
2756 SFTB_limit = current_##typename##_block_index; \
2761 int SFTB_empty = 1; \
2762 obj_type *SFTB_old_free_list = typename##_free_list; \
2764 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2766 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2768 if (FREE_STRUCT_P (SFTB_victim)) \
2771 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2773 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2778 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2781 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2787 UNMARK_##typename (SFTB_victim); \
2792 SFTB_prev = &(SFTB_current->prev); \
2793 SFTB_current = SFTB_current->prev; \
2795 else if (SFTB_current == current_##typename##_block \
2796 && !SFTB_current->prev) \
2798 /* No real point in freeing sole allocation block */ \
2803 struct typename##_block *SFTB_victim_block = SFTB_current; \
2804 if (SFTB_victim_block == current_##typename##_block) \
2805 current_##typename##_block_index \
2806 = countof (current_##typename##_block->block); \
2807 SFTB_current = SFTB_current->prev; \
2809 *SFTB_prev = SFTB_current; \
2810 xfree (SFTB_victim_block); \
2811 /* Restore free list to what it was before victim was swept */ \
2812 typename##_free_list = SFTB_old_free_list; \
2813 num_free -= SFTB_limit; \
2816 SFTB_limit = countof (current_##typename##_block->block); \
2819 gc_count_num_##typename##_in_use = num_used; \
2820 gc_count_num_##typename##_freelist = num_free; \
2823 #endif /* !ERROR_CHECK_GC */
2831 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2832 #define ADDITIONAL_FREE_cons(ptr)
2834 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2837 /* Explicitly free a cons cell. */
2839 free_cons (Lisp_Cons *ptr)
2841 #ifdef ERROR_CHECK_GC
2842 /* If the CAR is not an int, then it will be a pointer, which will
2843 always be four-byte aligned. If this cons cell has already been
2844 placed on the free list, however, its car will probably contain
2845 a chain pointer to the next cons on the list, which has cleverly
2846 had all its 0's and 1's inverted. This allows for a quick
2847 check to make sure we're not freeing something already freed. */
2848 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2849 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2850 #endif /* ERROR_CHECK_GC */
2852 #ifndef ALLOC_NO_POOLS
2853 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2854 #endif /* ALLOC_NO_POOLS */
2857 /* explicitly free a list. You **must make sure** that you have
2858 created all the cons cells that make up this list and that there
2859 are no pointers to any of these cons cells anywhere else. If there
2860 are, you will lose. */
2863 free_list (Lisp_Object list)
2865 Lisp_Object rest, next;
2867 for (rest = list; !NILP (rest); rest = next)
2870 free_cons (XCONS (rest));
2874 /* explicitly free an alist. You **must make sure** that you have
2875 created all the cons cells that make up this alist and that there
2876 are no pointers to any of these cons cells anywhere else. If there
2877 are, you will lose. */
2880 free_alist (Lisp_Object alist)
2882 Lisp_Object rest, next;
2884 for (rest = alist; !NILP (rest); rest = next)
2887 free_cons (XCONS (XCAR (rest)));
2888 free_cons (XCONS (rest));
2893 sweep_compiled_functions (void)
2895 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2896 #define ADDITIONAL_FREE_compiled_function(ptr)
2898 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2902 #ifdef LISP_FLOAT_TYPE
2906 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2907 #define ADDITIONAL_FREE_float(ptr)
2909 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2911 #endif /* LISP_FLOAT_TYPE */
2914 sweep_symbols (void)
2916 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2917 #define ADDITIONAL_FREE_symbol(ptr)
2919 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2923 sweep_extents (void)
2925 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2926 #define ADDITIONAL_FREE_extent(ptr)
2928 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2934 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2935 #define ADDITIONAL_FREE_event(ptr)
2937 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2941 sweep_markers (void)
2943 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2944 #define ADDITIONAL_FREE_marker(ptr) \
2945 do { Lisp_Object tem; \
2946 XSETMARKER (tem, ptr); \
2947 unchain_marker (tem); \
2950 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2953 /* Explicitly free a marker. */
2955 free_marker (Lisp_Marker *ptr)
2957 /* Perhaps this will catch freeing an already-freed marker. */
2958 gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
2960 #ifndef ALLOC_NO_POOLS
2961 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2962 #endif /* ALLOC_NO_POOLS */
2966 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2969 verify_string_chars_integrity (void)
2971 struct string_chars_block *sb;
2973 /* Scan each existing string block sequentially, string by string. */
2974 for (sb = first_string_chars_block; sb; sb = sb->next)
2977 /* POS is the index of the next string in the block. */
2978 while (pos < sb->pos)
2980 struct string_chars *s_chars =
2981 (struct string_chars *) &(sb->string_chars[pos]);
2982 Lisp_String *string;
2986 /* If the string_chars struct is marked as free (i.e. the STRING
2987 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2988 storage. (See below.) */
2990 if (FREE_STRUCT_P (s_chars))
2992 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2997 string = s_chars->string;
2998 /* Must be 32-bit aligned. */
2999 assert ((((int) string) & 3) == 0);
3001 size = string_length (string);
3002 fullsize = STRING_FULLSIZE (size);
3004 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3005 assert (string_data (string) == s_chars->chars);
3008 assert (pos == sb->pos);
3012 #endif /* MULE && ERROR_CHECK_GC */
3014 /* Compactify string chars, relocating the reference to each --
3015 free any empty string_chars_block we see. */
3017 compact_string_chars (void)
3019 struct string_chars_block *to_sb = first_string_chars_block;
3021 struct string_chars_block *from_sb;
3023 /* Scan each existing string block sequentially, string by string. */
3024 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3027 /* FROM_POS is the index of the next string in the block. */
3028 while (from_pos < from_sb->pos)
3030 struct string_chars *from_s_chars =
3031 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3032 struct string_chars *to_s_chars;
3033 Lisp_String *string;
3037 /* If the string_chars struct is marked as free (i.e. the STRING
3038 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3039 storage. This happens under Mule when a string's size changes
3040 in such a way that its fullsize changes. (Strings can change
3041 size because a different-length character can be substituted
3042 for another character.) In this case, after the bogus string
3043 pointer is the "fullsize" of this entry, i.e. how many bytes
3046 if (FREE_STRUCT_P (from_s_chars))
3048 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3049 from_pos += fullsize;
3053 string = from_s_chars->string;
3054 assert (!(FREE_STRUCT_P (string)));
3056 size = string_length (string);
3057 fullsize = STRING_FULLSIZE (size);
3059 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3061 /* Just skip it if it isn't marked. */
3062 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3064 from_pos += fullsize;
3068 /* If it won't fit in what's left of TO_SB, close TO_SB out
3069 and go on to the next string_chars_block. We know that TO_SB
3070 cannot advance past FROM_SB here since FROM_SB is large enough
3071 to currently contain this string. */
3072 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3074 to_sb->pos = to_pos;
3075 to_sb = to_sb->next;
3079 /* Compute new address of this string
3080 and update TO_POS for the space being used. */
3081 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3083 /* Copy the string_chars to the new place. */
3084 if (from_s_chars != to_s_chars)
3085 memmove (to_s_chars, from_s_chars, fullsize);
3087 /* Relocate FROM_S_CHARS's reference */
3088 set_string_data (string, &(to_s_chars->chars[0]));
3090 from_pos += fullsize;
3095 /* Set current to the last string chars block still used and
3096 free any that follow. */
3098 struct string_chars_block *victim;
3100 for (victim = to_sb->next; victim; )
3102 struct string_chars_block *next = victim->next;
3107 current_string_chars_block = to_sb;
3108 current_string_chars_block->pos = to_pos;
3109 current_string_chars_block->next = 0;
3113 #if 1 /* Hack to debug missing purecopy's */
3114 static int debug_string_purity;
3117 debug_string_purity_print (Lisp_String *p)
3120 Charcount s = string_char_length (p);
3122 for (i = 0; i < s; i++)
3124 Emchar ch = string_char (p, i);
3125 if (ch < 32 || ch >= 126)
3126 stderr_out ("\\%03o", ch);
3127 else if (ch == '\\' || ch == '\"')
3128 stderr_out ("\\%c", ch);
3130 stderr_out ("%c", ch);
3132 stderr_out ("\"\n");
3138 sweep_strings (void)
3140 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3141 int debug = debug_string_purity;
3143 #define UNMARK_string(ptr) do { \
3144 Lisp_String *p = (ptr); \
3145 size_t size = string_length (p); \
3146 UNMARK_RECORD_HEADER (&(p->lheader)); \
3147 num_bytes += size; \
3148 if (!BIG_STRING_SIZE_P (size)) \
3150 num_small_bytes += size; \
3154 debug_string_purity_print (p); \
3156 #define ADDITIONAL_FREE_string(ptr) do { \
3157 size_t size = string_length (ptr); \
3158 if (BIG_STRING_SIZE_P (size)) \
3159 xfree (ptr->data); \
3162 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3164 gc_count_num_short_string_in_use = num_small_used;
3165 gc_count_string_total_size = num_bytes;
3166 gc_count_short_string_total_size = num_small_bytes;
3170 /* I hate duplicating all this crap! */
3172 marked_p (Lisp_Object obj)
3174 /* Checks we used to perform. */
3175 /* if (EQ (obj, Qnull_pointer)) return 1; */
3176 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3177 /* if (PURIFIED (XPNTR (obj))) return 1; */
3179 if (XTYPE (obj) == Lisp_Type_Record)
3181 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3183 GC_CHECK_LHEADER_INVARIANTS (lheader);
3185 return MARKED_RECORD_HEADER_P (lheader);
3193 /* Free all unmarked records. Do this at the very beginning,
3194 before anything else, so that the finalize methods can safely
3195 examine items in the objects. sweep_lcrecords_1() makes
3196 sure to call all the finalize methods *before* freeing anything,
3197 to complete the safety. */
3200 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3203 compact_string_chars ();
3205 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3206 macros) must be *extremely* careful to make sure they're not
3207 referencing freed objects. The only two existing finalize
3208 methods (for strings and markers) pass muster -- the string
3209 finalizer doesn't look at anything but its own specially-
3210 created block, and the marker finalizer only looks at live
3211 buffers (which will never be freed) and at the markers before
3212 and after it in the chain (which, by induction, will never be
3213 freed because if so, they would have already removed themselves
3216 /* Put all unmarked strings on free list, free'ing the string chars
3217 of large unmarked strings */
3220 /* Put all unmarked conses on free list */
3223 /* Free all unmarked bit vectors */
3224 sweep_bit_vectors_1 (&all_bit_vectors,
3225 &gc_count_num_bit_vector_used,
3226 &gc_count_bit_vector_total_size,
3227 &gc_count_bit_vector_storage);
3229 /* Free all unmarked compiled-function objects */
3230 sweep_compiled_functions ();
3232 #ifdef LISP_FLOAT_TYPE
3233 /* Put all unmarked floats on free list */
3237 /* Put all unmarked symbols on free list */
3240 /* Put all unmarked extents on free list */
3243 /* Put all unmarked markers on free list.
3244 Dechain each one first from the buffer into which it points. */
3250 pdump_objects_unmark ();
3254 /* Clearing for disksave. */
3257 disksave_object_finalization (void)
3259 /* It's important that certain information from the environment not get
3260 dumped with the executable (pathnames, environment variables, etc.).
3261 To make it easier to tell when this has happened with strings(1) we
3262 clear some known-to-be-garbage blocks of memory, so that leftover
3263 results of old evaluation don't look like potential problems.
3264 But first we set some notable variables to nil and do one more GC,
3265 to turn those strings into garbage.
3268 /* Yeah, this list is pretty ad-hoc... */
3269 Vprocess_environment = Qnil;
3270 Vexec_directory = Qnil;
3271 Vdata_directory = Qnil;
3272 Vsite_directory = Qnil;
3273 Vdoc_directory = Qnil;
3274 Vconfigure_info_directory = Qnil;
3277 /* Vdump_load_path = Qnil; */
3278 /* Release hash tables for locate_file */
3279 Flocate_file_clear_hashing (Qt);
3280 uncache_home_directory();
3282 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3283 defined(LOADHIST_BUILTIN))
3284 Vload_history = Qnil;
3286 Vshell_file_name = Qnil;
3288 garbage_collect_1 ();
3290 /* Run the disksave finalization methods of all live objects. */
3291 disksave_object_finalization_1 ();
3293 /* Zero out the uninitialized (really, unused) part of the containers
3294 for the live strings. */
3296 struct string_chars_block *scb;
3297 for (scb = first_string_chars_block; scb; scb = scb->next)
3299 int count = sizeof (scb->string_chars) - scb->pos;
3301 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3304 /* from the block's fill ptr to the end */
3305 memset ((scb->string_chars + scb->pos), 0, count);
3310 /* There, that ought to be enough... */
3316 restore_gc_inhibit (Lisp_Object val)
3318 gc_currently_forbidden = XINT (val);
3322 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3323 static int gc_hooks_inhibited;
3327 garbage_collect_1 (void)
3329 #if MAX_SAVE_STACK > 0
3330 char stack_top_variable;
3331 extern char *stack_bottom;
3336 Lisp_Object pre_gc_cursor;
3337 struct gcpro gcpro1;
3340 || gc_currently_forbidden
3342 || preparing_for_armageddon)
3345 /* We used to call selected_frame() here.
3347 The following functions cannot be called inside GC
3348 so we move to after the above tests. */
3351 Lisp_Object device = Fselected_device (Qnil);
3352 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3354 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3356 signal_simple_error ("No frames exist on device", device);
3360 pre_gc_cursor = Qnil;
3363 GCPRO1 (pre_gc_cursor);
3365 /* Very important to prevent GC during any of the following
3366 stuff that might run Lisp code; otherwise, we'll likely
3367 have infinite GC recursion. */
3368 speccount = specpdl_depth ();
3369 record_unwind_protect (restore_gc_inhibit,
3370 make_int (gc_currently_forbidden));
3371 gc_currently_forbidden = 1;
3373 if (!gc_hooks_inhibited)
3374 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3376 /* Now show the GC cursor/message. */
3377 if (!noninteractive)
3379 if (FRAME_WIN_P (f))
3381 Lisp_Object frame = make_frame (f);
3382 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3383 FRAME_SELECTED_WINDOW (f),
3385 pre_gc_cursor = f->pointer;
3386 if (POINTER_IMAGE_INSTANCEP (cursor)
3387 /* don't change if we don't know how to change back. */
3388 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3391 Fset_frame_pointer (frame, cursor);
3395 /* Don't print messages to the stream device. */
3396 if (!cursor_changed && !FRAME_STREAM_P (f))
3398 char *msg = (STRINGP (Vgc_message)
3399 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3401 Lisp_Object args[2], whole_msg;
3402 args[0] = build_string (msg ? msg :
3403 GETTEXT ((const char *) gc_default_message));
3404 args[1] = build_string ("...");
3405 whole_msg = Fconcat (2, args);
3406 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3407 Qgarbage_collecting);
3411 /***** Now we actually start the garbage collection. */
3415 gc_generation_number[0]++;
3417 #if MAX_SAVE_STACK > 0
3419 /* Save a copy of the contents of the stack, for debugging. */
3422 /* Static buffer in which we save a copy of the C stack at each GC. */
3423 static char *stack_copy;
3424 static size_t stack_copy_size;
3426 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3427 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3428 if (stack_size < MAX_SAVE_STACK)
3430 if (stack_copy_size < stack_size)
3432 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3433 stack_copy_size = stack_size;
3437 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3441 #endif /* MAX_SAVE_STACK > 0 */
3443 /* Do some totally ad-hoc resource clearing. */
3444 /* #### generalize this? */
3445 clear_event_resource ();
3446 cleanup_specifiers ();
3448 /* Mark all the special slots that serve as the roots of accessibility. */
3452 for (i = 0; i < staticidx; i++)
3453 mark_object (*(staticvec[i]));
3454 for (i = 0; i < staticidx_nodump; i++)
3455 mark_object (*(staticvec_nodump[i]));
3461 for (tail = gcprolist; tail; tail = tail->next)
3462 for (i = 0; i < tail->nvars; i++)
3463 mark_object (tail->var[i]);
3467 struct specbinding *bind;
3468 for (bind = specpdl; bind != specpdl_ptr; bind++)
3470 mark_object (bind->symbol);
3471 mark_object (bind->old_value);
3476 struct catchtag *catch;
3477 for (catch = catchlist; catch; catch = catch->next)
3479 mark_object (catch->tag);
3480 mark_object (catch->val);
3485 struct backtrace *backlist;
3486 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3488 int nargs = backlist->nargs;
3491 mark_object (*backlist->function);
3492 if (nargs == UNEVALLED || nargs == MANY)
3493 mark_object (backlist->args[0]);
3495 for (i = 0; i < nargs; i++)
3496 mark_object (backlist->args[i]);
3501 mark_profiling_info ();
3503 /* OK, now do the after-mark stuff. This is for things that
3504 are only marked when something else is marked (e.g. weak hash tables).
3505 There may be complex dependencies between such objects -- e.g.
3506 a weak hash table might be unmarked, but after processing a later
3507 weak hash table, the former one might get marked. So we have to
3508 iterate until nothing more gets marked. */
3510 while (finish_marking_weak_hash_tables () > 0 ||
3511 finish_marking_weak_lists () > 0)
3514 /* And prune (this needs to be called after everything else has been
3515 marked and before we do any sweeping). */
3516 /* #### this is somewhat ad-hoc and should probably be an object
3518 prune_weak_hash_tables ();
3519 prune_weak_lists ();
3520 prune_specifiers ();
3521 prune_syntax_tables ();
3525 consing_since_gc = 0;
3526 #ifndef DEBUG_XEMACS
3527 /* Allow you to set it really fucking low if you really want ... */
3528 if (gc_cons_threshold < 10000)
3529 gc_cons_threshold = 10000;
3534 /******* End of garbage collection ********/
3536 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3538 /* Now remove the GC cursor/message */
3539 if (!noninteractive)
3542 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3543 else if (!FRAME_STREAM_P (f))
3545 char *msg = (STRINGP (Vgc_message)
3546 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3549 /* Show "...done" only if the echo area would otherwise be empty. */
3550 if (NILP (clear_echo_area (selected_frame (),
3551 Qgarbage_collecting, 0)))
3553 Lisp_Object args[2], whole_msg;
3554 args[0] = build_string (msg ? msg :
3555 GETTEXT ((const char *)
3556 gc_default_message));
3557 args[1] = build_string ("... done");
3558 whole_msg = Fconcat (2, args);
3559 echo_area_message (selected_frame (), (Bufbyte *) 0,
3561 Qgarbage_collecting);
3566 /* now stop inhibiting GC */
3567 unbind_to (speccount, Qnil);
3569 if (!breathing_space)
3571 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3578 /* Debugging aids. */
3581 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3583 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3584 or portable numeric datatypes, or bit-vectors, or characters, or
3585 arrays, or exceptions, or ...) */
3586 return cons3 (intern (name), make_int (value), tail);
3589 #define HACK_O_MATIC(type, name, pl) do { \
3591 struct type##_block *x = current_##type##_block; \
3592 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3593 (pl) = gc_plist_hack ((name), s, (pl)); \
3596 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3597 Reclaim storage for Lisp objects no longer needed.
3598 Return info on amount of space in use:
3599 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3600 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3602 where `PLIST' is a list of alternating keyword/value pairs providing
3603 more detailed information.
3604 Garbage collection happens automatically if you cons more than
3605 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3609 Lisp_Object pl = Qnil;
3611 int gc_count_vector_total_size = 0;
3613 garbage_collect_1 ();
3615 for (i = 0; i < lrecord_type_count; i++)
3617 if (lcrecord_stats[i].bytes_in_use != 0
3618 || lcrecord_stats[i].bytes_freed != 0
3619 || lcrecord_stats[i].instances_on_free_list != 0)
3622 const char *name = lrecord_implementations_table[i]->name;
3623 int len = strlen (name);
3624 /* save this for the FSFmacs-compatible part of the summary */
3625 if (i == lrecord_vector.lrecord_type_index)
3626 gc_count_vector_total_size =
3627 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3629 sprintf (buf, "%s-storage", name);
3630 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3631 /* Okay, simple pluralization check for `symbol-value-varalias' */
3632 if (name[len-1] == 's')
3633 sprintf (buf, "%ses-freed", name);
3635 sprintf (buf, "%ss-freed", name);
3636 if (lcrecord_stats[i].instances_freed != 0)
3637 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3638 if (name[len-1] == 's')
3639 sprintf (buf, "%ses-on-free-list", name);
3641 sprintf (buf, "%ss-on-free-list", name);
3642 if (lcrecord_stats[i].instances_on_free_list != 0)
3643 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3645 if (name[len-1] == 's')
3646 sprintf (buf, "%ses-used", name);
3648 sprintf (buf, "%ss-used", name);
3649 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3653 HACK_O_MATIC (extent, "extent-storage", pl);
3654 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3655 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3656 HACK_O_MATIC (event, "event-storage", pl);
3657 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3658 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3659 HACK_O_MATIC (marker, "marker-storage", pl);
3660 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3661 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3662 #ifdef LISP_FLOAT_TYPE
3663 HACK_O_MATIC (float, "float-storage", pl);
3664 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3665 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3666 #endif /* LISP_FLOAT_TYPE */
3667 HACK_O_MATIC (string, "string-header-storage", pl);
3668 pl = gc_plist_hack ("long-strings-total-length",
3669 gc_count_string_total_size
3670 - gc_count_short_string_total_size, pl);
3671 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3672 pl = gc_plist_hack ("short-strings-total-length",
3673 gc_count_short_string_total_size, pl);
3674 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3675 pl = gc_plist_hack ("long-strings-used",
3676 gc_count_num_string_in_use
3677 - gc_count_num_short_string_in_use, pl);
3678 pl = gc_plist_hack ("short-strings-used",
3679 gc_count_num_short_string_in_use, pl);
3681 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3682 pl = gc_plist_hack ("compiled-functions-free",
3683 gc_count_num_compiled_function_freelist, pl);
3684 pl = gc_plist_hack ("compiled-functions-used",
3685 gc_count_num_compiled_function_in_use, pl);
3687 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3688 pl = gc_plist_hack ("bit-vectors-total-length",
3689 gc_count_bit_vector_total_size, pl);
3690 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3692 HACK_O_MATIC (symbol, "symbol-storage", pl);
3693 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3694 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3696 HACK_O_MATIC (cons, "cons-storage", pl);
3697 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3698 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3700 /* The things we do for backwards-compatibility */
3702 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3703 make_int (gc_count_num_cons_freelist)),
3704 Fcons (make_int (gc_count_num_symbol_in_use),
3705 make_int (gc_count_num_symbol_freelist)),
3706 Fcons (make_int (gc_count_num_marker_in_use),
3707 make_int (gc_count_num_marker_freelist)),
3708 make_int (gc_count_string_total_size),
3709 make_int (gc_count_vector_total_size),
3714 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3715 Return the number of bytes consed since the last garbage collection.
3716 \"Consed\" is a misnomer in that this actually counts allocation
3717 of all different kinds of objects, not just conses.
3719 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3723 return make_int (consing_since_gc);
3727 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3728 Return the address of the last byte Emacs has allocated, divided by 1024.
3729 This may be helpful in debugging Emacs's memory usage.
3730 The value is divided by 1024 to make sure it will fit in a lisp integer.
3734 return make_int ((EMACS_INT) sbrk (0) / 1024);
3740 object_dead_p (Lisp_Object obj)
3742 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3743 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3744 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3745 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3746 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3747 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3748 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3751 #ifdef MEMORY_USAGE_STATS
3753 /* Attempt to determine the actual amount of space that is used for
3754 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3756 It seems that the following holds:
3758 1. When using the old allocator (malloc.c):
3760 -- blocks are always allocated in chunks of powers of two. For
3761 each block, there is an overhead of 8 bytes if rcheck is not
3762 defined, 20 bytes if it is defined. In other words, a
3763 one-byte allocation needs 8 bytes of overhead for a total of
3764 9 bytes, and needs to have 16 bytes of memory chunked out for
3767 2. When using the new allocator (gmalloc.c):
3769 -- blocks are always allocated in chunks of powers of two up
3770 to 4096 bytes. Larger blocks are allocated in chunks of
3771 an integral multiple of 4096 bytes. The minimum block
3772 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3773 is defined. There is no per-block overhead, but there
3774 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3777 3. When using the system malloc, anything goes, but they are
3778 generally slower and more space-efficient than the GNU
3779 allocators. One possibly reasonable assumption to make
3780 for want of better data is that sizeof (void *), or maybe
3781 2 * sizeof (void *), is required as overhead and that
3782 blocks are allocated in the minimum required size except
3783 that some minimum block size is imposed (e.g. 16 bytes). */
3786 malloced_storage_size (void *ptr, size_t claimed_size,
3787 struct overhead_stats *stats)
3789 size_t orig_claimed_size = claimed_size;
3793 if (claimed_size < 2 * sizeof (void *))
3794 claimed_size = 2 * sizeof (void *);
3795 # ifdef SUNOS_LOCALTIME_BUG
3796 if (claimed_size < 16)
3799 if (claimed_size < 4096)
3803 /* compute the log base two, more or less, then use it to compute
3804 the block size needed. */
3806 /* It's big, it's heavy, it's wood! */
3807 while ((claimed_size /= 2) != 0)
3810 /* It's better than bad, it's good! */
3816 /* We have to come up with some average about the amount of
3818 if ((size_t) (rand () & 4095) < claimed_size)
3819 claimed_size += 3 * sizeof (void *);
3823 claimed_size += 4095;
3824 claimed_size &= ~4095;
3825 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3828 #elif defined (SYSTEM_MALLOC)
3830 if (claimed_size < 16)
3832 claimed_size += 2 * sizeof (void *);
3834 #else /* old GNU allocator */
3836 # ifdef rcheck /* #### may not be defined here */
3844 /* compute the log base two, more or less, then use it to compute
3845 the block size needed. */
3847 /* It's big, it's heavy, it's wood! */
3848 while ((claimed_size /= 2) != 0)
3851 /* It's better than bad, it's good! */
3859 #endif /* old GNU allocator */
3863 stats->was_requested += orig_claimed_size;
3864 stats->malloc_overhead += claimed_size - orig_claimed_size;
3866 return claimed_size;
3870 fixed_type_block_overhead (size_t size)
3872 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3873 size_t overhead = 0;
3874 size_t storage_size = malloced_storage_size (0, per_block, 0);
3875 while (size >= per_block)
3878 overhead += sizeof (void *) + per_block - storage_size;
3880 if (rand () % per_block < size)
3881 overhead += sizeof (void *) + per_block - storage_size;
3885 #endif /* MEMORY_USAGE_STATS */
3888 /* Initialization */
3890 reinit_alloc_once_early (void)
3892 gc_generation_number[0] = 0;
3893 breathing_space = 0;
3894 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3895 XSETINT (Vgc_message, 0);
3897 ignore_malloc_warnings = 1;
3898 #ifdef DOUG_LEA_MALLOC
3899 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3900 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3901 #if 0 /* Moved to emacs.c */
3902 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3905 init_string_alloc ();
3906 init_string_chars_alloc ();
3908 init_symbol_alloc ();
3909 init_compiled_function_alloc ();
3910 #ifdef LISP_FLOAT_TYPE
3911 init_float_alloc ();
3912 #endif /* LISP_FLOAT_TYPE */
3913 init_marker_alloc ();
3914 init_extent_alloc ();
3915 init_event_alloc ();
3917 ignore_malloc_warnings = 0;
3919 staticidx_nodump = 0;
3923 consing_since_gc = 0;
3925 gc_cons_threshold = 500000; /* XEmacs change */
3927 gc_cons_threshold = 15000; /* debugging */
3929 #ifdef VIRT_ADDR_VARIES
3930 malloc_sbrk_unused = 1<<22; /* A large number */
3931 malloc_sbrk_used = 100000; /* as reasonable as any number */
3932 #endif /* VIRT_ADDR_VARIES */
3933 lrecord_uid_counter = 259;
3934 debug_string_purity = 0;
3937 gc_currently_forbidden = 0;
3938 gc_hooks_inhibited = 0;
3940 #ifdef ERROR_CHECK_TYPECHECK
3941 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3944 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3946 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3948 #endif /* ERROR_CHECK_TYPECHECK */
3952 init_alloc_once_early (void)
3954 reinit_alloc_once_early ();
3958 for (i = 0; i < countof (lrecord_implementations_table); i++)
3959 lrecord_implementations_table[i] = 0;
3962 INIT_LRECORD_IMPLEMENTATION (cons);
3963 INIT_LRECORD_IMPLEMENTATION (vector);
3964 INIT_LRECORD_IMPLEMENTATION (string);
3965 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3970 int pure_bytes_used = 0;
3979 syms_of_alloc (void)
3981 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
3982 defsymbol (&Qpost_gc_hook, "post-gc-hook");
3983 defsymbol (&Qgarbage_collecting, "garbage-collecting");
3988 DEFSUBR (Fbit_vector);
3989 DEFSUBR (Fmake_byte_code);
3990 DEFSUBR (Fmake_list);
3991 DEFSUBR (Fmake_vector);
3992 DEFSUBR (Fmake_bit_vector);
3993 DEFSUBR (Fmake_string);
3995 DEFSUBR (Fmake_symbol);
3996 DEFSUBR (Fmake_marker);
3997 DEFSUBR (Fpurecopy);
3998 DEFSUBR (Fgarbage_collect);
4000 DEFSUBR (Fmemory_limit);
4002 DEFSUBR (Fconsing_since_gc);
4006 vars_of_alloc (void)
4008 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4009 *Number of bytes of consing between garbage collections.
4010 \"Consing\" is a misnomer in that this actually counts allocation
4011 of all different kinds of objects, not just conses.
4012 Garbage collection can happen automatically once this many bytes have been
4013 allocated since the last garbage collection. All data types count.
4015 Garbage collection happens automatically when `eval' or `funcall' are
4016 called. (Note that `funcall' is called implicitly as part of evaluation.)
4017 By binding this temporarily to a large number, you can effectively
4018 prevent garbage collection during a part of the program.
4020 See also `consing-since-gc'.
4023 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4024 Number of bytes of sharable Lisp data allocated so far.
4028 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4029 Number of bytes of unshared memory allocated in this session.
4032 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4033 Number of bytes of unshared memory remaining available in this session.
4038 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4039 If non-zero, print out information to stderr about all objects allocated.
4040 See also `debug-allocation-backtrace-length'.
4042 debug_allocation = 0;
4044 DEFVAR_INT ("debug-allocation-backtrace-length",
4045 &debug_allocation_backtrace_length /*
4046 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4048 debug_allocation_backtrace_length = 2;
4051 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4052 Non-nil means loading Lisp code in order to dump an executable.
4053 This means that certain objects should be allocated in readonly space.
4056 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4057 Function or functions to be run just before each garbage collection.
4058 Interrupts, garbage collection, and errors are inhibited while this hook
4059 runs, so be extremely careful in what you add here. In particular, avoid
4060 consing, and do not interact with the user.
4062 Vpre_gc_hook = Qnil;
4064 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4065 Function or functions to be run just after each garbage collection.
4066 Interrupts, garbage collection, and errors are inhibited while this hook
4067 runs, so be extremely careful in what you add here. In particular, avoid
4068 consing, and do not interact with the user.
4070 Vpost_gc_hook = Qnil;
4072 DEFVAR_LISP ("gc-message", &Vgc_message /*
4073 String to print to indicate that a garbage collection is in progress.
4074 This is printed in the echo area. If the selected frame is on a
4075 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4076 image instance) in the domain of the selected frame, the mouse pointer
4077 will change instead of this message being printed.
4079 Vgc_message = build_string (gc_default_message);
4081 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4082 Pointer glyph used to indicate that a garbage collection is in progress.
4083 If the selected window is on a window system and this glyph specifies a
4084 value (i.e. a pointer image instance) in the domain of the selected
4085 window, the pointer will be changed as specified during garbage collection.
4086 Otherwise, a message will be printed in the echo area, as controlled
4092 complex_vars_of_alloc (void)
4094 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);