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)
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
61 #include "console-stream.h"
63 #ifdef DOUG_LEA_MALLOC
71 EXFUN (Fgarbage_collect, 0);
73 #if 0 /* this is _way_ too slow to be part of the standard debug options */
74 #if defined(DEBUG_XEMACS) && defined(MULE)
75 #define VERIFY_STRING_CHARS_INTEGRITY
79 /* Define this to use malloc/free with no freelist for all datatypes,
80 the hope being that some debugging tools may help detect
81 freed memory references */
82 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
84 #define ALLOC_NO_POOLS
88 static int debug_allocation;
89 static int debug_allocation_backtrace_length;
92 /* Number of bytes of consing done since the last gc */
93 EMACS_INT consing_since_gc;
94 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
96 #define debug_allocation_backtrace() \
98 if (debug_allocation_backtrace_length > 0) \
99 debug_short_backtrace (debug_allocation_backtrace_length); \
103 #define INCREMENT_CONS_COUNTER(foosize, type) \
105 if (debug_allocation) \
107 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
108 debug_allocation_backtrace (); \
110 INCREMENT_CONS_COUNTER_1 (foosize); \
112 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
114 if (debug_allocation > 1) \
116 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
117 debug_allocation_backtrace (); \
119 INCREMENT_CONS_COUNTER_1 (foosize); \
122 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
123 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
124 INCREMENT_CONS_COUNTER_1 (size)
127 #define DECREMENT_CONS_COUNTER(size) do { \
128 consing_since_gc -= (size); \
129 if (consing_since_gc < 0) \
130 consing_since_gc = 0; \
133 /* Number of bytes of consing since gc before another gc should be done. */
134 EMACS_INT gc_cons_threshold;
136 /* Nonzero during gc */
139 /* Number of times GC has happened at this level or below.
140 * Level 0 is most volatile, contrary to usual convention.
141 * (Of course, there's only one level at present) */
142 EMACS_INT gc_generation_number[1];
144 /* This is just for use by the printer, to allow things to print uniquely */
145 static int lrecord_uid_counter;
147 /* Nonzero when calling certain hooks or doing other things where
149 int gc_currently_forbidden;
152 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
153 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
155 /* "Garbage collecting" */
156 Lisp_Object Vgc_message;
157 Lisp_Object Vgc_pointer_glyph;
158 static const char gc_default_message[] = "Garbage collecting";
159 Lisp_Object Qgarbage_collecting;
161 /* Non-zero means we're in the process of doing the dump */
164 #ifdef ERROR_CHECK_TYPECHECK
166 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
171 c_readonly (Lisp_Object obj)
173 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
177 lisp_readonly (Lisp_Object obj)
179 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
183 /* Maximum amount of C stack to save when a GC happens. */
185 #ifndef MAX_SAVE_STACK
186 #define MAX_SAVE_STACK 0 /* 16000 */
189 /* Non-zero means ignore malloc warnings. Set during initialization. */
190 int ignore_malloc_warnings;
193 static void *breathing_space;
196 release_breathing_space (void)
200 void *tmp = breathing_space;
206 /* malloc calls this if it finds we are near exhausting storage */
208 malloc_warning (const char *str)
210 if (ignore_malloc_warnings)
216 "Killing some buffers may delay running out of memory.\n"
217 "However, certainly by the time you receive the 95%% warning,\n"
218 "you should clean up, kill this Emacs, and start a new one.",
222 /* Called if malloc returns zero */
226 /* Force a GC next time eval is called.
227 It's better to loop garbage-collecting (we might reclaim enough
228 to win) than to loop beeping and barfing "Memory exhausted"
230 consing_since_gc = gc_cons_threshold + 1;
231 release_breathing_space ();
233 /* Flush some histories which might conceivably contain garbalogical
235 if (!NILP (Fboundp (Qvalues)))
236 Fset (Qvalues, Qnil);
237 Vcommand_history = Qnil;
239 error ("Memory exhausted");
242 /* like malloc and realloc but check for no memory left, and block input. */
246 xmalloc (size_t size)
248 void *val = malloc (size);
250 if (!val && (size != 0)) memory_full ();
256 xcalloc (size_t nelem, size_t elsize)
258 void *val = calloc (nelem, elsize);
260 if (!val && (nelem != 0)) memory_full ();
265 xmalloc_and_zero (size_t size)
267 return xcalloc (size, sizeof (char));
272 xrealloc (void *block, size_t size)
274 /* We must call malloc explicitly when BLOCK is 0, since some
275 reallocs don't do this. */
276 void *val = block ? realloc (block, size) : malloc (size);
278 if (!val && (size != 0)) memory_full ();
283 #ifdef ERROR_CHECK_MALLOC
284 xfree_1 (void *block)
289 #ifdef ERROR_CHECK_MALLOC
290 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
291 error until much later on for many system mallocs, such as
292 the one that comes with Solaris 2.3. FMH!! */
293 assert (block != (void *) 0xDEADBEEF);
295 #endif /* ERROR_CHECK_MALLOC */
299 #ifdef ERROR_CHECK_GC
302 typedef unsigned int four_byte_t;
303 #elif SIZEOF_LONG == 4
304 typedef unsigned long four_byte_t;
305 #elif SIZEOF_SHORT == 4
306 typedef unsigned short four_byte_t;
308 What kind of strange-ass system are we running on?
312 deadbeef_memory (void *ptr, size_t size)
314 four_byte_t *ptr4 = (four_byte_t *) ptr;
315 size_t beefs = size >> 2;
317 /* In practice, size will always be a multiple of four. */
319 (*ptr4++) = 0xDEADBEEF;
322 #else /* !ERROR_CHECK_GC */
325 #define deadbeef_memory(ptr, size)
327 #endif /* !ERROR_CHECK_GC */
331 xstrdup (const char *str)
333 int len = strlen (str) + 1; /* for stupid terminating 0 */
335 void *val = xmalloc (len);
336 if (val == 0) return 0;
337 return (char *) memcpy (val, str, len);
342 strdup (const char *s)
346 #endif /* NEED_STRDUP */
350 allocate_lisp_storage (size_t size)
352 return xmalloc (size);
356 /* lcrecords are chained together through their "next" field.
357 After doing the mark phase, GC will walk this linked list
358 and free any lcrecord which hasn't been marked. */
359 static struct lcrecord_header *all_lcrecords;
361 static struct lcrecord_header *all_older_lcrecords;
365 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
367 struct lcrecord_header *lcheader;
370 ((implementation->static_size == 0 ?
371 implementation->size_in_bytes_method != NULL :
372 implementation->static_size == size)
374 (! implementation->basic_p)
376 (! (implementation->hash == NULL && implementation->equal != NULL)));
378 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
379 set_lheader_implementation (&lcheader->lheader, implementation);
380 lcheader->next = all_lcrecords;
381 #if 1 /* mly prefers to see small ID numbers */
382 lcheader->uid = lrecord_uid_counter++;
383 #else /* jwz prefers to see real addrs */
384 lcheader->uid = (int) &lcheader;
387 all_lcrecords = lcheader;
388 INCREMENT_CONS_COUNTER (size, implementation->name);
394 alloc_older_lcrecord (size_t size,
395 const struct lrecord_implementation *implementation)
397 struct lcrecord_header *lcheader;
400 ((implementation->static_size == 0 ?
401 implementation->size_in_bytes_method != NULL :
402 implementation->static_size == size)
404 (! implementation->basic_p)
406 (! (implementation->hash == NULL && implementation->equal != NULL)));
408 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
409 set_lheader_older_implementation (&lcheader->lheader, implementation);
410 lcheader->next = all_older_lcrecords;
411 #if 1 /* mly prefers to see small ID numbers */
412 lcheader->uid = lrecord_uid_counter++;
413 #else /* jwz prefers to see real addrs */
414 lcheader->uid = (int) &lcheader;
417 all_older_lcrecords = lcheader;
418 INCREMENT_CONS_COUNTER (size, implementation->name);
423 #if 0 /* Presently unused */
424 /* Very, very poor man's EGC?
425 * This may be slow and thrash pages all over the place.
426 * Only call it if you really feel you must (and if the
427 * lrecord was fairly recently allocated).
428 * Otherwise, just let the GC do its job -- that's what it's there for
431 free_lcrecord (struct lcrecord_header *lcrecord)
433 if (all_lcrecords == lcrecord)
435 all_lcrecords = lcrecord->next;
439 struct lrecord_header *header = all_lcrecords;
442 struct lrecord_header *next = header->next;
443 if (next == lcrecord)
445 header->next = lrecord->next;
454 if (lrecord->implementation->finalizer)
455 lrecord->implementation->finalizer (lrecord, 0);
463 disksave_object_finalization_1 (void)
465 struct lcrecord_header *header;
467 for (header = all_lcrecords; header; header = header->next)
469 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
471 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
474 for (header = all_older_lcrecords; header; header = header->next)
476 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
478 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
484 /************************************************************************/
485 /* Debugger support */
486 /************************************************************************/
487 /* Give gdb/dbx enough information to decode Lisp Objects. We make
488 sure certain symbols are always defined, so gdb doesn't complain
489 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
490 to see how this is used. */
492 const EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
493 const EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
495 #ifdef USE_UNION_TYPE
496 const unsigned char dbg_USE_UNION_TYPE = 1;
498 const unsigned char dbg_USE_UNION_TYPE = 0;
501 const unsigned char dbg_valbits = VALBITS;
502 const unsigned char dbg_gctypebits = GCTYPEBITS;
504 /* Macros turned into functions for ease of debugging.
505 Debuggers don't know about macros! */
506 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
508 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
510 return EQ (obj1, obj2);
514 /************************************************************************/
515 /* Fixed-size type macros */
516 /************************************************************************/
518 /* For fixed-size types that are commonly used, we malloc() large blocks
519 of memory at a time and subdivide them into chunks of the correct
520 size for an object of that type. This is more efficient than
521 malloc()ing each object separately because we save on malloc() time
522 and overhead due to the fewer number of malloc()ed blocks, and
523 also because we don't need any extra pointers within each object
524 to keep them threaded together for GC purposes. For less common
525 (and frequently large-size) types, we use lcrecords, which are
526 malloc()ed individually and chained together through a pointer
527 in the lcrecord header. lcrecords do not need to be fixed-size
528 (i.e. two objects of the same type need not have the same size;
529 however, the size of a particular object cannot vary dynamically).
530 It is also much easier to create a new lcrecord type because no
531 additional code needs to be added to alloc.c. Finally, lcrecords
532 may be more efficient when there are only a small number of them.
534 The types that are stored in these large blocks (or "frob blocks")
535 are cons, float, compiled-function, symbol, marker, extent, event,
538 Note that strings are special in that they are actually stored in
539 two parts: a structure containing information about the string, and
540 the actual data associated with the string. The former structure
541 (a struct Lisp_String) is a fixed-size structure and is managed the
542 same way as all the other such types. This structure contains a
543 pointer to the actual string data, which is stored in structures of
544 type struct string_chars_block. Each string_chars_block consists
545 of a pointer to a struct Lisp_String, followed by the data for that
546 string, followed by another pointer to a Lisp_String, followed by
547 the data for that string, etc. At GC time, the data in these
548 blocks is compacted by searching sequentially through all the
549 blocks and compressing out any holes created by unmarked strings.
550 Strings that are more than a certain size (bigger than the size of
551 a string_chars_block, although something like half as big might
552 make more sense) are malloc()ed separately and not stored in
553 string_chars_blocks. Furthermore, no one string stretches across
554 two string_chars_blocks.
556 Vectors are each malloc()ed separately, similar to lcrecords.
558 In the following discussion, we use conses, but it applies equally
559 well to the other fixed-size types.
561 We store cons cells inside of cons_blocks, allocating a new
562 cons_block with malloc() whenever necessary. Cons cells reclaimed
563 by GC are put on a free list to be reallocated before allocating
564 any new cons cells from the latest cons_block. Each cons_block is
565 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
566 the versions in malloc.c and gmalloc.c) really allocates in units
567 of powers of two and uses 4 bytes for its own overhead.
569 What GC actually does is to search through all the cons_blocks,
570 from the most recently allocated to the oldest, and put all
571 cons cells that are not marked (whether or not they're already
572 free) on a cons_free_list. The cons_free_list is a stack, and
573 so the cons cells in the oldest-allocated cons_block end up
574 at the head of the stack and are the first to be reallocated.
575 If any cons_block is entirely free, it is freed with free()
576 and its cons cells removed from the cons_free_list. Because
577 the cons_free_list ends up basically in memory order, we have
578 a high locality of reference (assuming a reasonable turnover
579 of allocating and freeing) and have a reasonable probability
580 of entirely freeing up cons_blocks that have been more recently
581 allocated. This stage is called the "sweep stage" of GC, and
582 is executed after the "mark stage", which involves starting
583 from all places that are known to point to in-use Lisp objects
584 (e.g. the obarray, where are all symbols are stored; the
585 current catches and condition-cases; the backtrace list of
586 currently executing functions; the gcpro list; etc.) and
587 recursively marking all objects that are accessible.
589 At the beginning of the sweep stage, the conses in the cons blocks
590 are in one of three states: in use and marked, in use but not
591 marked, and not in use (already freed). Any conses that are marked
592 have been marked in the mark stage just executed, because as part
593 of the sweep stage we unmark any marked objects. The way we tell
594 whether or not a cons cell is in use is through the LRECORD_FREE_P
595 macro. This uses a special lrecord type `lrecord_type_free',
596 which is never associated with any valid object.
598 Conses on the free_cons_list are threaded through a pointer stored
599 in the conses themselves. Because the cons is still in a
600 cons_block and needs to remain marked as not in use for the next
601 time that GC happens, we need room to store both the "free"
602 indicator and the chaining pointer. So this pointer is stored
603 after the lrecord header (actually where C places a pointer after
604 the lrecord header; they are not necessarily contiguous). This
605 implies that all fixed-size types must be big enough to contain at
606 least one pointer. This is true for all current fixed-size types,
607 with the possible exception of Lisp_Floats, for which we define the
608 meat of the struct using a union of a pointer and a double to
609 ensure adequate space for the free list chain pointer.
611 Some types of objects need additional "finalization" done
612 when an object is converted from in use to not in use;
613 this is the purpose of the ADDITIONAL_FREE_type macro.
614 For example, markers need to be removed from the chain
615 of markers that is kept in each buffer. This is because
616 markers in a buffer automatically disappear if the marker
617 is no longer referenced anywhere (the same does not
618 apply to extents, however).
620 WARNING: Things are in an extremely bizarre state when
621 the ADDITIONAL_FREE_type macros are called, so beware!
623 When ERROR_CHECK_GC is defined, we do things differently so as to
624 maximize our chances of catching places where there is insufficient
625 GCPROing. The thing we want to avoid is having an object that
626 we're using but didn't GCPRO get freed by GC and then reallocated
627 while we're in the process of using it -- this will result in
628 something seemingly unrelated getting trashed, and is extremely
629 difficult to track down. If the object gets freed but not
630 reallocated, we can usually catch this because we set most of the
631 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
632 to the invalid type `lrecord_type_free', however, and a pointer
633 used to chain freed objects together is stored after the lrecord
634 header; we play some tricks with this pointer to make it more
635 bogus, so crashes are more likely to occur right away.)
637 We want freed objects to stay free as long as possible,
638 so instead of doing what we do above, we maintain the
639 free objects in a first-in first-out queue. We also
640 don't recompute the free list each GC, unlike above;
641 this ensures that the queue ordering is preserved.
642 [This means that we are likely to have worse locality
643 of reference, and that we can never free a frob block
644 once it's allocated. (Even if we know that all cells
645 in it are free, there's no easy way to remove all those
646 cells from the free list because the objects on the
647 free list are unlikely to be in memory order.)]
648 Furthermore, we never take objects off the free list
649 unless there's a large number (usually 1000, but
650 varies depending on type) of them already on the list.
651 This way, we ensure that an object that gets freed will
652 remain free for the next 1000 (or whatever) times that
653 an object of that type is allocated. */
655 #ifndef MALLOC_OVERHEAD
657 #define MALLOC_OVERHEAD 0
658 #elif defined (rcheck)
659 #define MALLOC_OVERHEAD 20
661 #define MALLOC_OVERHEAD 8
663 #endif /* MALLOC_OVERHEAD */
665 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
666 /* If we released our reserve (due to running out of memory),
667 and we have a fair amount free once again,
668 try to set aside another reserve in case we run out once more.
670 This is called when a relocatable block is freed in ralloc.c. */
671 void refill_memory_reserve (void);
673 refill_memory_reserve (void)
675 if (breathing_space == 0)
676 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
680 #ifdef ALLOC_NO_POOLS
681 # define TYPE_ALLOC_SIZE(type, structtype) 1
683 # define TYPE_ALLOC_SIZE(type, structtype) \
684 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
685 / sizeof (structtype))
686 #endif /* ALLOC_NO_POOLS */
688 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
690 struct type##_block \
692 struct type##_block *prev; \
693 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
696 static struct type##_block *current_##type##_block; \
697 static int current_##type##_block_index; \
699 static Lisp_Free *type##_free_list; \
700 static Lisp_Free *type##_free_list_tail; \
703 init_##type##_alloc (void) \
705 current_##type##_block = 0; \
706 current_##type##_block_index = \
707 countof (current_##type##_block->block); \
708 type##_free_list = 0; \
709 type##_free_list_tail = 0; \
712 static int gc_count_num_##type##_in_use; \
713 static int gc_count_num_##type##_freelist
715 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
716 if (current_##type##_block_index \
717 == countof (current_##type##_block->block)) \
719 struct type##_block *AFTFB_new = (struct type##_block *) \
720 allocate_lisp_storage (sizeof (struct type##_block)); \
721 AFTFB_new->prev = current_##type##_block; \
722 current_##type##_block = AFTFB_new; \
723 current_##type##_block_index = 0; \
726 &(current_##type##_block->block[current_##type##_block_index++]); \
729 /* Allocate an instance of a type that is stored in blocks.
730 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
733 #ifdef ERROR_CHECK_GC
735 /* Note: if you get crashes in this function, suspect incorrect calls
736 to free_cons() and friends. This happened once because the cons
737 cell was not GC-protected and was getting collected before
738 free_cons() was called. */
740 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
741 if (gc_count_num_##type##_freelist > \
742 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
744 result = (structtype *) type##_free_list; \
745 /* Before actually using the chain pointer, \
746 we complement all its bits; see FREE_FIXED_TYPE(). */ \
747 type##_free_list = (Lisp_Free *) \
748 (~ (EMACS_UINT) (type##_free_list->chain)); \
749 gc_count_num_##type##_freelist--; \
752 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
753 MARK_LRECORD_AS_NOT_FREE (result); \
756 #else /* !ERROR_CHECK_GC */
758 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
759 if (type##_free_list) \
761 result = (structtype *) type##_free_list; \
762 type##_free_list = type##_free_list->chain; \
765 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
766 MARK_LRECORD_AS_NOT_FREE (result); \
769 #endif /* !ERROR_CHECK_GC */
772 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
775 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
776 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
779 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
782 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
783 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
787 /* Lisp_Free is the type to represent a free list member inside a frob
788 block of any lisp object type. */
789 typedef struct Lisp_Free
791 struct lrecord_header lheader;
792 struct Lisp_Free *chain;
795 #define LRECORD_FREE_P(ptr) \
796 ((ptr)->lheader.type == lrecord_type_free)
798 #define MARK_LRECORD_AS_FREE(ptr) \
799 ((void) ((ptr)->lheader.type = lrecord_type_free))
801 #ifdef ERROR_CHECK_GC
802 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
803 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
805 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
808 #ifdef ERROR_CHECK_GC
810 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
811 if (type##_free_list_tail) \
813 /* When we store the chain pointer, we complement all \
814 its bits; this should significantly increase its \
815 bogosity in case someone tries to use the value, and \
816 should make us crash faster if someone overwrites the \
817 pointer because when it gets un-complemented in \
818 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
819 extremely bogus. */ \
820 type##_free_list_tail->chain = \
821 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
824 type##_free_list = (Lisp_Free *) (ptr); \
825 type##_free_list_tail = (Lisp_Free *) (ptr); \
828 #else /* !ERROR_CHECK_GC */
830 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
831 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
832 type##_free_list = (Lisp_Free *) (ptr); \
835 #endif /* !ERROR_CHECK_GC */
837 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
839 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
840 structtype *FFT_ptr = (ptr); \
841 ADDITIONAL_FREE_##type (FFT_ptr); \
842 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
843 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
844 MARK_LRECORD_AS_FREE (FFT_ptr); \
847 /* Like FREE_FIXED_TYPE() but used when we are explicitly
848 freeing a structure through free_cons(), free_marker(), etc.
849 rather than through the normal process of sweeping.
850 We attempt to undo the changes made to the allocation counters
851 as a result of this structure being allocated. This is not
852 completely necessary but helps keep things saner: e.g. this way,
853 repeatedly allocating and freeing a cons will not result in
854 the consing-since-gc counter advancing, which would cause a GC
855 and somewhat defeat the purpose of explicitly freeing. */
857 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
858 do { FREE_FIXED_TYPE (type, structtype, ptr); \
859 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
860 gc_count_num_##type##_freelist++; \
865 /************************************************************************/
866 /* Cons allocation */
867 /************************************************************************/
869 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
870 /* conses are used and freed so often that we set this really high */
871 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
872 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
875 mark_cons (Lisp_Object obj)
877 if (NILP (XCDR (obj)))
880 mark_object (XCAR (obj));
885 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
888 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
892 if (! CONSP (ob1) || ! CONSP (ob2))
893 return internal_equal (ob1, ob2, depth);
898 static const struct lrecord_description cons_description[] = {
899 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
900 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
904 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
905 mark_cons, print_cons, 0,
908 * No `hash' method needed.
909 * internal_hash knows how to
916 DEFUN ("cons", Fcons, 2, 2, 0, /*
917 Create a new cons, give it CAR and CDR as components, and return it.
921 /* This cannot GC. */
925 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
926 set_lheader_implementation (&c->lheader, &lrecord_cons);
933 /* This is identical to Fcons() but it used for conses that we're
934 going to free later, and is useful when trying to track down
937 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
942 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
943 set_lheader_implementation (&c->lheader, &lrecord_cons);
950 DEFUN ("list", Flist, 0, MANY, 0, /*
951 Return a newly created list with specified arguments as elements.
952 Any number of arguments, even zero arguments, are allowed.
954 (int nargs, Lisp_Object *args))
956 Lisp_Object val = Qnil;
957 Lisp_Object *argp = args + nargs;
960 val = Fcons (*--argp, val);
965 list1 (Lisp_Object obj0)
967 /* This cannot GC. */
968 return Fcons (obj0, Qnil);
972 list2 (Lisp_Object obj0, Lisp_Object obj1)
974 /* This cannot GC. */
975 return Fcons (obj0, Fcons (obj1, Qnil));
979 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
981 /* This cannot GC. */
982 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
986 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
988 /* This cannot GC. */
989 return Fcons (obj0, Fcons (obj1, obj2));
993 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
995 return Fcons (Fcons (key, value), alist);
999 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1001 /* This cannot GC. */
1002 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1006 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1009 /* This cannot GC. */
1010 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1014 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1015 Lisp_Object obj4, Lisp_Object obj5)
1017 /* This cannot GC. */
1018 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1021 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1022 Return a new list of length LENGTH, with each element being OBJECT.
1026 CHECK_NATNUM (length);
1029 Lisp_Object val = Qnil;
1030 size_t size = XINT (length);
1033 val = Fcons (object, val);
1039 /************************************************************************/
1040 /* Float allocation */
1041 /************************************************************************/
1043 #ifdef LISP_FLOAT_TYPE
1045 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1046 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1049 make_float (double float_value)
1054 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1056 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1057 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1060 set_lheader_implementation (&f->lheader, &lrecord_float);
1061 float_data (f) = float_value;
1066 #endif /* LISP_FLOAT_TYPE */
1069 /************************************************************************/
1070 /* Vector allocation */
1071 /************************************************************************/
1074 mark_vector (Lisp_Object obj)
1076 Lisp_Vector *ptr = XVECTOR (obj);
1077 int len = vector_length (ptr);
1080 for (i = 0; i < len - 1; i++)
1081 mark_object (ptr->contents[i]);
1082 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1086 size_vector (const void *lheader)
1088 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
1089 ((Lisp_Vector *) lheader)->size);
1093 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1095 int len = XVECTOR_LENGTH (obj1);
1096 if (len != XVECTOR_LENGTH (obj2))
1100 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1101 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1103 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1110 vector_hash (Lisp_Object obj, int depth)
1112 return HASH2 (XVECTOR_LENGTH (obj),
1113 internal_array_hash (XVECTOR_DATA (obj),
1114 XVECTOR_LENGTH (obj),
1118 static const struct lrecord_description vector_description[] = {
1119 { XD_LONG, offsetof (Lisp_Vector, size) },
1120 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1124 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1125 mark_vector, print_vector, 0,
1129 size_vector, Lisp_Vector);
1131 /* #### should allocate `small' vectors from a frob-block */
1132 static Lisp_Vector *
1133 make_vector_internal (size_t sizei)
1135 /* no vector_next */
1136 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
1138 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1145 make_vector (size_t length, Lisp_Object object)
1147 Lisp_Vector *vecp = make_vector_internal (length);
1148 Lisp_Object *p = vector_data (vecp);
1155 XSETVECTOR (vector, vecp);
1162 make_older_vector (size_t length, Lisp_Object init)
1164 struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
1167 all_lcrecords = all_older_lcrecords;
1168 obj = make_vector (length, init);
1169 all_older_lcrecords = all_lcrecords;
1170 all_lcrecords = orig_all_lcrecords;
1174 void make_vector_newer_1 (Lisp_Object v);
1176 make_vector_newer_1 (Lisp_Object v)
1178 struct lcrecord_header* lcrecords = all_older_lcrecords;
1180 if (lcrecords != NULL)
1182 if (lcrecords == XPNTR (v))
1184 lcrecords->lheader.older = 0;
1185 all_older_lcrecords = all_older_lcrecords->next;
1186 lcrecords->next = all_lcrecords;
1187 all_lcrecords = lcrecords;
1192 struct lcrecord_header* plcrecords = lcrecords;
1194 lcrecords = lcrecords->next;
1195 while (lcrecords != NULL)
1197 if (lcrecords == XPNTR (v))
1199 lcrecords->lheader.older = 0;
1200 plcrecords->next = lcrecords->next;
1201 lcrecords->next = all_lcrecords;
1202 all_lcrecords = lcrecords;
1205 plcrecords = lcrecords;
1206 lcrecords = lcrecords->next;
1213 make_vector_newer (Lisp_Object v)
1217 for (i = 0; i < XVECTOR_LENGTH (v); i++)
1219 Lisp_Object obj = XVECTOR_DATA (v)[i];
1221 if (VECTORP (obj) && !EQ (obj, v))
1222 make_vector_newer (obj);
1224 make_vector_newer_1 (v);
1228 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1229 Return a new vector of length LENGTH, with each element being OBJECT.
1230 See also the function `vector'.
1234 CONCHECK_NATNUM (length);
1235 return make_vector (XINT (length), object);
1238 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1239 Return a newly created vector with specified arguments as elements.
1240 Any number of arguments, even zero arguments, are allowed.
1242 (int nargs, Lisp_Object *args))
1244 Lisp_Vector *vecp = make_vector_internal (nargs);
1245 Lisp_Object *p = vector_data (vecp);
1252 XSETVECTOR (vector, vecp);
1258 vector1 (Lisp_Object obj0)
1260 return Fvector (1, &obj0);
1264 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1266 Lisp_Object args[2];
1269 return Fvector (2, args);
1273 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1275 Lisp_Object args[3];
1279 return Fvector (3, args);
1282 #if 0 /* currently unused */
1285 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1288 Lisp_Object args[4];
1293 return Fvector (4, args);
1297 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1298 Lisp_Object obj3, Lisp_Object obj4)
1300 Lisp_Object args[5];
1306 return Fvector (5, args);
1310 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1311 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1313 Lisp_Object args[6];
1320 return Fvector (6, args);
1324 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1325 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1328 Lisp_Object args[7];
1336 return Fvector (7, args);
1340 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1341 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1342 Lisp_Object obj6, Lisp_Object obj7)
1344 Lisp_Object args[8];
1353 return Fvector (8, args);
1357 /************************************************************************/
1358 /* Bit Vector allocation */
1359 /************************************************************************/
1361 static Lisp_Object all_bit_vectors;
1363 /* #### should allocate `small' bit vectors from a frob-block */
1364 static Lisp_Bit_Vector *
1365 make_bit_vector_internal (size_t sizei)
1367 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1368 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
1370 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1371 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1373 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1375 bit_vector_length (p) = sizei;
1376 bit_vector_next (p) = all_bit_vectors;
1377 /* make sure the extra bits in the last long are 0; the calling
1378 functions might not set them. */
1379 p->bits[num_longs - 1] = 0;
1380 XSETBIT_VECTOR (all_bit_vectors, p);
1385 make_bit_vector (size_t length, Lisp_Object bit)
1387 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1388 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1393 memset (p->bits, 0, num_longs * sizeof (long));
1396 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1397 memset (p->bits, ~0, num_longs * sizeof (long));
1398 /* But we have to make sure that the unused bits in the
1399 last long are 0, so that equal/hash is easy. */
1401 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1405 Lisp_Object bit_vector;
1406 XSETBIT_VECTOR (bit_vector, p);
1412 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1415 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1417 for (i = 0; i < length; i++)
1418 set_bit_vector_bit (p, i, bytevec[i]);
1421 Lisp_Object bit_vector;
1422 XSETBIT_VECTOR (bit_vector, p);
1427 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1428 Return a new bit vector of length LENGTH. with each bit set to BIT.
1429 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1433 CONCHECK_NATNUM (length);
1435 return make_bit_vector (XINT (length), bit);
1438 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1439 Return a newly created bit vector with specified arguments as elements.
1440 Any number of arguments, even zero arguments, are allowed.
1441 Each argument must be one of the integers 0 or 1.
1443 (int nargs, Lisp_Object *args))
1446 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1448 for (i = 0; i < nargs; i++)
1450 CHECK_BIT (args[i]);
1451 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1455 Lisp_Object bit_vector;
1456 XSETBIT_VECTOR (bit_vector, p);
1462 /************************************************************************/
1463 /* Compiled-function allocation */
1464 /************************************************************************/
1466 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1467 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1470 make_compiled_function (void)
1472 Lisp_Compiled_Function *f;
1475 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1476 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1479 f->specpdl_depth = 0;
1480 f->flags.documentationp = 0;
1481 f->flags.interactivep = 0;
1482 f->flags.domainp = 0; /* I18N3 */
1483 f->instructions = Qzero;
1484 f->constants = Qzero;
1486 f->doc_and_interactive = Qnil;
1487 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1488 f->annotated = Qnil;
1490 XSETCOMPILED_FUNCTION (fun, f);
1494 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1495 Return a new compiled-function object.
1496 Usage: (arglist instructions constants stack-depth
1497 &optional doc-string interactive)
1498 Note that, unlike all other emacs-lisp functions, calling this with five
1499 arguments is NOT the same as calling it with six arguments, the last of
1500 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1501 that this function was defined with `(interactive)'. If the arg is not
1502 specified, then that means the function is not interactive.
1503 This is terrible behavior which is retained for compatibility with old
1504 `.elc' files which expect these semantics.
1506 (int nargs, Lisp_Object *args))
1508 /* In a non-insane world this function would have this arglist...
1509 (arglist instructions constants stack_depth &optional doc_string interactive)
1511 Lisp_Object fun = make_compiled_function ();
1512 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1514 Lisp_Object arglist = args[0];
1515 Lisp_Object instructions = args[1];
1516 Lisp_Object constants = args[2];
1517 Lisp_Object stack_depth = args[3];
1518 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1519 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1521 if (nargs < 4 || nargs > 6)
1522 return Fsignal (Qwrong_number_of_arguments,
1523 list2 (intern ("make-byte-code"), make_int (nargs)));
1525 /* Check for valid formal parameter list now, to allow us to use
1526 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1528 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1530 CHECK_SYMBOL (symbol);
1531 if (EQ (symbol, Qt) ||
1532 EQ (symbol, Qnil) ||
1533 SYMBOL_IS_KEYWORD (symbol))
1534 signal_simple_error_2
1535 ("Invalid constant symbol in formal parameter list",
1539 f->arglist = arglist;
1541 /* `instructions' is a string or a cons (string . int) for a
1542 lazy-loaded function. */
1543 if (CONSP (instructions))
1545 CHECK_STRING (XCAR (instructions));
1546 CHECK_INT (XCDR (instructions));
1550 CHECK_STRING (instructions);
1552 f->instructions = instructions;
1554 if (!NILP (constants))
1555 CHECK_VECTOR (constants);
1556 f->constants = constants;
1558 CHECK_NATNUM (stack_depth);
1559 f->stack_depth = (unsigned short) XINT (stack_depth);
1561 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1562 if (!NILP (Vcurrent_compiled_function_annotation))
1563 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1564 else if (!NILP (Vload_file_name_internal_the_purecopy))
1565 f->annotated = Vload_file_name_internal_the_purecopy;
1566 else if (!NILP (Vload_file_name_internal))
1568 struct gcpro gcpro1;
1569 GCPRO1 (fun); /* don't let fun get reaped */
1570 Vload_file_name_internal_the_purecopy =
1571 Ffile_name_nondirectory (Vload_file_name_internal);
1572 f->annotated = Vload_file_name_internal_the_purecopy;
1575 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1577 /* doc_string may be nil, string, int, or a cons (string . int).
1578 interactive may be list or string (or unbound). */
1579 f->doc_and_interactive = Qunbound;
1581 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1582 f->doc_and_interactive = Vfile_domain;
1584 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1586 f->doc_and_interactive
1587 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1588 Fcons (interactive, f->doc_and_interactive));
1590 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1592 f->doc_and_interactive
1593 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1594 Fcons (doc_string, f->doc_and_interactive));
1596 if (UNBOUNDP (f->doc_and_interactive))
1597 f->doc_and_interactive = Qnil;
1603 /************************************************************************/
1604 /* Symbol allocation */
1605 /************************************************************************/
1607 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1608 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1610 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1611 Return a newly allocated uninterned symbol whose name is NAME.
1612 Its value and function definition are void, and its property list is nil.
1619 CHECK_STRING (name);
1621 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1622 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1623 p->name = XSTRING (name);
1625 p->value = Qunbound;
1626 p->function = Qunbound;
1627 symbol_next (p) = 0;
1628 XSETSYMBOL (val, p);
1633 /************************************************************************/
1634 /* Extent allocation */
1635 /************************************************************************/
1637 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1638 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1641 allocate_extent (void)
1645 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1646 set_lheader_implementation (&e->lheader, &lrecord_extent);
1647 extent_object (e) = Qnil;
1648 set_extent_start (e, -1);
1649 set_extent_end (e, -1);
1654 extent_face (e) = Qnil;
1655 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1656 e->flags.detachable = 1;
1662 /************************************************************************/
1663 /* Event allocation */
1664 /************************************************************************/
1666 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1667 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1670 allocate_event (void)
1675 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1676 set_lheader_implementation (&e->lheader, &lrecord_event);
1683 /************************************************************************/
1684 /* Marker allocation */
1685 /************************************************************************/
1687 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1688 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1690 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1691 Return a new marker which does not point at any place.
1698 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1699 set_lheader_implementation (&p->lheader, &lrecord_marker);
1702 marker_next (p) = 0;
1703 marker_prev (p) = 0;
1704 p->insertion_type = 0;
1705 XSETMARKER (val, p);
1710 noseeum_make_marker (void)
1715 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1716 set_lheader_implementation (&p->lheader, &lrecord_marker);
1719 marker_next (p) = 0;
1720 marker_prev (p) = 0;
1721 p->insertion_type = 0;
1722 XSETMARKER (val, p);
1727 /************************************************************************/
1728 /* String allocation */
1729 /************************************************************************/
1731 /* The data for "short" strings generally resides inside of structs of type
1732 string_chars_block. The Lisp_String structure is allocated just like any
1733 other Lisp object (except for vectors), and these are freelisted when
1734 they get garbage collected. The data for short strings get compacted,
1735 but the data for large strings do not.
1737 Previously Lisp_String structures were relocated, but this caused a lot
1738 of bus-errors because the C code didn't include enough GCPRO's for
1739 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1740 that the reference would get relocated).
1742 This new method makes things somewhat bigger, but it is MUCH safer. */
1744 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1745 /* strings are used and freed quite often */
1746 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1747 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1750 mark_string (Lisp_Object obj)
1752 Lisp_String *ptr = XSTRING (obj);
1754 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1755 flush_cached_extent_info (XCAR (ptr->plist));
1760 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1763 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1764 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1767 static const struct lrecord_description string_description[] = {
1768 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1769 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1770 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1774 /* We store the string's extent info as the first element of the string's
1775 property list; and the string's MODIFF as the first or second element
1776 of the string's property list (depending on whether the extent info
1777 is present), but only if the string has been modified. This is ugly
1778 but it reduces the memory allocated for the string in the vast
1779 majority of cases, where the string is never modified and has no
1782 #### This means you can't use an int as a key in a string's plist. */
1784 static Lisp_Object *
1785 string_plist_ptr (Lisp_Object string)
1787 Lisp_Object *ptr = &XSTRING (string)->plist;
1789 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1791 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1797 string_getprop (Lisp_Object string, Lisp_Object property)
1799 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1803 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1805 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1810 string_remprop (Lisp_Object string, Lisp_Object property)
1812 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1816 string_plist (Lisp_Object string)
1818 return *string_plist_ptr (string);
1821 /* No `finalize', or `hash' methods.
1822 internal_hash() already knows how to hash strings and finalization
1823 is done with the ADDITIONAL_FREE_string macro, which is the
1824 standard way to do finalization when using
1825 SWEEP_FIXED_TYPE_BLOCK(). */
1826 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1827 mark_string, print_string,
1836 /* String blocks contain this many useful bytes. */
1837 #define STRING_CHARS_BLOCK_SIZE \
1838 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1839 ((2 * sizeof (struct string_chars_block *)) \
1840 + sizeof (EMACS_INT))))
1841 /* Block header for small strings. */
1842 struct string_chars_block
1845 struct string_chars_block *next;
1846 struct string_chars_block *prev;
1847 /* Contents of string_chars_block->string_chars are interleaved
1848 string_chars structures (see below) and the actual string data */
1849 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1852 static struct string_chars_block *first_string_chars_block;
1853 static struct string_chars_block *current_string_chars_block;
1855 /* If SIZE is the length of a string, this returns how many bytes
1856 * the string occupies in string_chars_block->string_chars
1857 * (including alignment padding).
1859 #define STRING_FULLSIZE(size) \
1860 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1861 ALIGNOF (Lisp_String *))
1863 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1864 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1866 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
1867 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
1871 Lisp_String *string;
1872 unsigned char chars[1];
1875 struct unused_string_chars
1877 Lisp_String *string;
1882 init_string_chars_alloc (void)
1884 first_string_chars_block = xnew (struct string_chars_block);
1885 first_string_chars_block->prev = 0;
1886 first_string_chars_block->next = 0;
1887 first_string_chars_block->pos = 0;
1888 current_string_chars_block = first_string_chars_block;
1891 static struct string_chars *
1892 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1895 struct string_chars *s_chars;
1898 (countof (current_string_chars_block->string_chars)
1899 - current_string_chars_block->pos))
1901 /* This string can fit in the current string chars block */
1902 s_chars = (struct string_chars *)
1903 (current_string_chars_block->string_chars
1904 + current_string_chars_block->pos);
1905 current_string_chars_block->pos += fullsize;
1909 /* Make a new current string chars block */
1910 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1912 current_string_chars_block->next = new_scb;
1913 new_scb->prev = current_string_chars_block;
1915 current_string_chars_block = new_scb;
1916 new_scb->pos = fullsize;
1917 s_chars = (struct string_chars *)
1918 current_string_chars_block->string_chars;
1921 s_chars->string = string_it_goes_with;
1923 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1929 make_uninit_string (Bytecount length)
1932 EMACS_INT fullsize = STRING_FULLSIZE (length);
1935 assert (length >= 0 && fullsize > 0);
1937 /* Allocate the string header */
1938 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1939 set_lheader_implementation (&s->lheader, &lrecord_string);
1941 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1942 ? xnew_array (Bufbyte, length + 1)
1943 : allocate_string_chars_struct (s, fullsize)->chars);
1945 set_string_length (s, length);
1948 set_string_byte (s, length, 0);
1950 XSETSTRING (val, s);
1954 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1955 static void verify_string_chars_integrity (void);
1958 /* Resize the string S so that DELTA bytes can be inserted starting
1959 at POS. If DELTA < 0, it means deletion starting at POS. If
1960 POS < 0, resize the string but don't copy any characters. Use
1961 this if you're planning on completely overwriting the string.
1965 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1967 Bytecount oldfullsize, newfullsize;
1968 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1969 verify_string_chars_integrity ();
1972 #ifdef ERROR_CHECK_BUFPOS
1975 assert (pos <= string_length (s));
1977 assert (pos + (-delta) <= string_length (s));
1982 assert ((-delta) <= string_length (s));
1984 #endif /* ERROR_CHECK_BUFPOS */
1987 /* simplest case: no size change. */
1990 if (pos >= 0 && delta < 0)
1991 /* If DELTA < 0, the functions below will delete the characters
1992 before POS. We want to delete characters *after* POS, however,
1993 so convert this to the appropriate form. */
1996 oldfullsize = STRING_FULLSIZE (string_length (s));
1997 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1999 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2001 if (BIG_STRING_FULLSIZE_P (newfullsize))
2003 /* Both strings are big. We can just realloc().
2004 But careful! If the string is shrinking, we have to
2005 memmove() _before_ realloc(), and if growing, we have to
2006 memmove() _after_ realloc() - otherwise the access is
2007 illegal, and we might crash. */
2008 Bytecount len = string_length (s) + 1 - pos;
2010 if (delta < 0 && pos >= 0)
2011 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2012 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2013 string_length (s) + delta + 1));
2014 if (delta > 0 && pos >= 0)
2015 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2017 else /* String has been demoted from BIG_STRING. */
2020 allocate_string_chars_struct (s, newfullsize)->chars;
2021 Bufbyte *old_data = string_data (s);
2025 memcpy (new_data, old_data, pos);
2026 memcpy (new_data + pos + delta, old_data + pos,
2027 string_length (s) + 1 - pos);
2029 set_string_data (s, new_data);
2033 else /* old string is small */
2035 if (oldfullsize == newfullsize)
2037 /* special case; size change but the necessary
2038 allocation size won't change (up or down; code
2039 somewhere depends on there not being any unused
2040 allocation space, modulo any alignment
2044 Bufbyte *addroff = pos + string_data (s);
2046 memmove (addroff + delta, addroff,
2047 /* +1 due to zero-termination. */
2048 string_length (s) + 1 - pos);
2053 Bufbyte *old_data = string_data (s);
2055 BIG_STRING_FULLSIZE_P (newfullsize)
2056 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2057 : allocate_string_chars_struct (s, newfullsize)->chars;
2061 memcpy (new_data, old_data, pos);
2062 memcpy (new_data + pos + delta, old_data + pos,
2063 string_length (s) + 1 - pos);
2065 set_string_data (s, new_data);
2068 /* We need to mark this chunk of the string_chars_block
2069 as unused so that compact_string_chars() doesn't
2071 struct string_chars *old_s_chars = (struct string_chars *)
2072 ((char *) old_data - offsetof (struct string_chars, chars));
2073 /* Sanity check to make sure we aren't hosed by strange
2074 alignment/padding. */
2075 assert (old_s_chars->string == s);
2076 MARK_STRING_CHARS_AS_FREE (old_s_chars);
2077 ((struct unused_string_chars *) old_s_chars)->fullsize =
2083 set_string_length (s, string_length (s) + delta);
2084 /* If pos < 0, the string won't be zero-terminated.
2085 Terminate now just to make sure. */
2086 string_data (s)[string_length (s)] = '\0';
2092 XSETSTRING (string, s);
2093 /* We also have to adjust all of the extent indices after the
2094 place we did the change. We say "pos - 1" because
2095 adjust_extents() is exclusive of the starting position
2097 adjust_extents (string, pos - 1, string_length (s),
2101 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2102 verify_string_chars_integrity ();
2109 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2111 Bufbyte newstr[MAX_EMCHAR_LEN];
2112 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2113 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2114 Bytecount newlen = set_charptr_emchar (newstr, c);
2116 if (oldlen != newlen)
2117 resize_string (s, bytoff, newlen - oldlen);
2118 /* Remember, string_data (s) might have changed so we can't cache it. */
2119 memcpy (string_data (s) + bytoff, newstr, newlen);
2124 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2125 Return a new string consisting of LENGTH copies of CHARACTER.
2126 LENGTH must be a non-negative integer.
2128 (length, character))
2130 CHECK_NATNUM (length);
2131 CHECK_CHAR_COERCE_INT (character);
2133 Bufbyte init_str[MAX_EMCHAR_LEN];
2134 int len = set_charptr_emchar (init_str, XCHAR (character));
2135 Lisp_Object val = make_uninit_string (len * XINT (length));
2138 /* Optimize the single-byte case */
2139 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2143 Bufbyte *ptr = XSTRING_DATA (val);
2145 for (i = XINT (length); i; i--)
2147 Bufbyte *init_ptr = init_str;
2151 case 6: *ptr++ = *init_ptr++;
2152 case 5: *ptr++ = *init_ptr++;
2154 case 4: *ptr++ = *init_ptr++;
2155 case 3: *ptr++ = *init_ptr++;
2156 case 2: *ptr++ = *init_ptr++;
2157 case 1: *ptr++ = *init_ptr++;
2165 DEFUN ("string", Fstring, 0, MANY, 0, /*
2166 Concatenate all the argument characters and make the result a string.
2168 (int nargs, Lisp_Object *args))
2170 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2171 Bufbyte *p = storage;
2173 for (; nargs; nargs--, args++)
2175 Lisp_Object lisp_char = *args;
2176 CHECK_CHAR_COERCE_INT (lisp_char);
2177 p += set_charptr_emchar (p, XCHAR (lisp_char));
2179 return make_string (storage, p - storage);
2183 /* Take some raw memory, which MUST already be in internal format,
2184 and package it up into a Lisp string. */
2186 make_string (const Bufbyte *contents, Bytecount length)
2190 /* Make sure we find out about bad make_string's when they happen */
2191 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2192 bytecount_to_charcount (contents, length); /* Just for the assertions */
2195 val = make_uninit_string (length);
2196 memcpy (XSTRING_DATA (val), contents, length);
2200 /* Take some raw memory, encoded in some external data format,
2201 and convert it into a Lisp string. */
2203 make_ext_string (const Extbyte *contents, EMACS_INT length,
2204 Lisp_Object coding_system)
2207 TO_INTERNAL_FORMAT (DATA, (contents, length),
2208 LISP_STRING, string,
2214 build_string (const char *str)
2216 /* Some strlen's crash and burn if passed null. */
2217 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2221 build_ext_string (const char *str, Lisp_Object coding_system)
2223 /* Some strlen's crash and burn if passed null. */
2224 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2229 build_translated_string (const char *str)
2231 return build_string (GETTEXT (str));
2235 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2240 /* Make sure we find out about bad make_string_nocopy's when they happen */
2241 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2242 bytecount_to_charcount (contents, length); /* Just for the assertions */
2245 /* Allocate the string header */
2246 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2247 set_lheader_implementation (&s->lheader, &lrecord_string);
2248 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2250 set_string_data (s, (Bufbyte *)contents);
2251 set_string_length (s, length);
2253 XSETSTRING (val, s);
2258 /************************************************************************/
2259 /* lcrecord lists */
2260 /************************************************************************/
2262 /* Lcrecord lists are used to manage the allocation of particular
2263 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2264 malloc() and garbage-collection junk) as much as possible.
2265 It is similar to the Blocktype class.
2269 1) Create an lcrecord-list object using make_lcrecord_list().
2270 This is often done at initialization. Remember to staticpro_nodump
2271 this object! The arguments to make_lcrecord_list() are the
2272 same as would be passed to alloc_lcrecord().
2273 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2274 and pass the lcrecord-list earlier created.
2275 3) When done with the lcrecord, call free_managed_lcrecord().
2276 The standard freeing caveats apply: ** make sure there are no
2277 pointers to the object anywhere! **
2278 4) Calling free_managed_lcrecord() is just like kissing the
2279 lcrecord goodbye as if it were garbage-collected. This means:
2280 -- the contents of the freed lcrecord are undefined, and the
2281 contents of something produced by allocate_managed_lcrecord()
2282 are undefined, just like for alloc_lcrecord().
2283 -- the mark method for the lcrecord's type will *NEVER* be called
2285 -- the finalize method for the lcrecord's type will be called
2286 at the time that free_managed_lcrecord() is called.
2291 mark_lcrecord_list (Lisp_Object obj)
2293 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2294 Lisp_Object chain = list->free;
2296 while (!NILP (chain))
2298 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2299 struct free_lcrecord_header *free_header =
2300 (struct free_lcrecord_header *) lheader;
2303 (/* There should be no other pointers to the free list. */
2304 ! MARKED_RECORD_HEADER_P (lheader)
2306 /* Only lcrecords should be here. */
2307 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2309 /* Only free lcrecords should be here. */
2310 free_header->lcheader.free
2312 /* The type of the lcrecord must be right. */
2313 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2315 /* So must the size. */
2316 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2317 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2320 MARK_RECORD_HEADER (lheader);
2321 chain = free_header->chain;
2327 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2328 mark_lcrecord_list, internal_object_printer,
2329 0, 0, 0, 0, struct lcrecord_list);
2331 make_lcrecord_list (size_t size,
2332 const struct lrecord_implementation *implementation)
2334 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2335 &lrecord_lcrecord_list);
2338 p->implementation = implementation;
2341 XSETLCRECORD_LIST (val, p);
2346 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2348 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2349 if (!NILP (list->free))
2351 Lisp_Object val = list->free;
2352 struct free_lcrecord_header *free_header =
2353 (struct free_lcrecord_header *) XPNTR (val);
2355 #ifdef ERROR_CHECK_GC
2356 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2358 /* There should be no other pointers to the free list. */
2359 assert (! MARKED_RECORD_HEADER_P (lheader));
2360 /* Only lcrecords should be here. */
2361 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2362 /* Only free lcrecords should be here. */
2363 assert (free_header->lcheader.free);
2364 /* The type of the lcrecord must be right. */
2365 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2366 /* So must the size. */
2367 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2368 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2369 #endif /* ERROR_CHECK_GC */
2371 list->free = free_header->chain;
2372 free_header->lcheader.free = 0;
2379 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2385 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2387 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2388 struct free_lcrecord_header *free_header =
2389 (struct free_lcrecord_header *) XPNTR (lcrecord);
2390 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2391 const struct lrecord_implementation *implementation
2392 = LHEADER_IMPLEMENTATION (lheader);
2394 /* Make sure the size is correct. This will catch, for example,
2395 putting a window configuration on the wrong free list. */
2396 gc_checking_assert ((implementation->size_in_bytes_method ?
2397 implementation->size_in_bytes_method (lheader) :
2398 implementation->static_size)
2401 if (implementation->finalizer)
2402 implementation->finalizer (lheader, 0);
2403 free_header->chain = list->free;
2404 free_header->lcheader.free = 1;
2405 list->free = lcrecord;
2411 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2412 Kept for compatibility, returns its argument.
2414 Make a copy of OBJECT in pure storage.
2415 Recursively copies contents of vectors and cons cells.
2416 Does not copy symbols.
2424 /************************************************************************/
2425 /* Garbage Collection */
2426 /************************************************************************/
2428 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2429 Additional ones may be defined by a module (none yet). We leave some
2430 room in `lrecord_implementations_table' for such new lisp object types. */
2431 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2432 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2433 /* Object marker functions are in the lrecord_implementation structure.
2434 But copying them to a parallel array is much more cache-friendly.
2435 This hack speeds up (garbage-collect) by about 5%. */
2436 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2438 struct gcpro *gcprolist;
2440 /* We want the staticpros relocated, but not the pointers found therein.
2441 Hence we use a trivial description, as for pointerless objects. */
2442 static const struct lrecord_description staticpro_description_1[] = {
2446 static const struct struct_description staticpro_description = {
2447 sizeof (Lisp_Object *),
2448 staticpro_description_1
2451 static const struct lrecord_description staticpros_description_1[] = {
2452 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
2456 static const struct struct_description staticpros_description = {
2457 sizeof (Lisp_Object_ptr_dynarr),
2458 staticpros_description_1
2461 Lisp_Object_ptr_dynarr *staticpros;
2463 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2464 garbage collection, and for dumping. */
2466 staticpro (Lisp_Object *varaddress)
2468 Dynarr_add (staticpros, varaddress);
2469 dump_add_root_object (varaddress);
2473 Lisp_Object_ptr_dynarr *staticpros_nodump;
2475 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2476 garbage collection, but not for dumping. */
2478 staticpro_nodump (Lisp_Object *varaddress)
2480 Dynarr_add (staticpros_nodump, varaddress);
2483 #ifdef ERROR_CHECK_GC
2484 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2485 struct lrecord_header * GCLI_lh = (lheader); \
2486 assert (GCLI_lh != 0); \
2487 assert (GCLI_lh->type < lrecord_type_count); \
2488 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2489 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2490 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2493 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2497 /* Mark reference to a Lisp_Object. If the object referred to has not been
2498 seen yet, recursively mark all the references contained in it. */
2501 mark_object (Lisp_Object obj)
2505 /* Checks we used to perform */
2506 /* if (EQ (obj, Qnull_pointer)) return; */
2507 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2508 /* if (PURIFIED (XPNTR (obj))) return; */
2510 if (XTYPE (obj) == Lisp_Type_Record)
2512 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2514 GC_CHECK_LHEADER_INVARIANTS (lheader);
2516 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2517 ! ((struct lcrecord_header *) lheader)->free);
2519 /* All c_readonly objects have their mark bit set,
2520 so that we only need to check the mark bit here. */
2521 if ( (!MARKED_RECORD_HEADER_P (lheader))
2523 && (!OLDER_RECORD_HEADER_P (lheader))
2527 MARK_RECORD_HEADER (lheader);
2529 if (RECORD_MARKER (lheader))
2531 obj = RECORD_MARKER (lheader) (obj);
2532 if (!NILP (obj)) goto tail_recurse;
2538 /* mark all of the conses in a list and mark the final cdr; but
2539 DO NOT mark the cars.
2541 Use only for internal lists! There should never be other pointers
2542 to the cons cells, because if so, the cars will remain unmarked
2543 even when they maybe should be marked. */
2545 mark_conses_in_list (Lisp_Object obj)
2549 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2551 if (CONS_MARKED_P (XCONS (rest)))
2553 MARK_CONS (XCONS (rest));
2560 /* Find all structures not marked, and free them. */
2562 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2563 static int gc_count_bit_vector_storage;
2564 static int gc_count_num_short_string_in_use;
2565 static int gc_count_string_total_size;
2566 static int gc_count_short_string_total_size;
2568 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2571 /* stats on lcrecords in use - kinda kludgy */
2575 int instances_in_use;
2577 int instances_freed;
2579 int instances_on_free_list;
2580 } lcrecord_stats [countof (lrecord_implementations_table)];
2583 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2585 unsigned int type_index = h->type;
2587 if (((struct lcrecord_header *) h)->free)
2589 gc_checking_assert (!free_p);
2590 lcrecord_stats[type_index].instances_on_free_list++;
2594 const struct lrecord_implementation *implementation =
2595 LHEADER_IMPLEMENTATION (h);
2597 size_t sz = (implementation->size_in_bytes_method ?
2598 implementation->size_in_bytes_method (h) :
2599 implementation->static_size);
2602 lcrecord_stats[type_index].instances_freed++;
2603 lcrecord_stats[type_index].bytes_freed += sz;
2607 lcrecord_stats[type_index].instances_in_use++;
2608 lcrecord_stats[type_index].bytes_in_use += sz;
2614 /* Free all unmarked records */
2616 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2618 struct lcrecord_header *header;
2620 /* int total_size = 0; */
2622 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2624 /* First go through and call all the finalize methods.
2625 Then go through and free the objects. There used to
2626 be only one loop here, with the call to the finalizer
2627 occurring directly before the xfree() below. That
2628 is marginally faster but much less safe -- if the
2629 finalize method for an object needs to reference any
2630 other objects contained within it (and many do),
2631 we could easily be screwed by having already freed that
2634 for (header = *prev; header; header = header->next)
2636 struct lrecord_header *h = &(header->lheader);
2638 GC_CHECK_LHEADER_INVARIANTS (h);
2640 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2642 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2643 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2647 for (header = *prev; header; )
2649 struct lrecord_header *h = &(header->lheader);
2650 if (MARKED_RECORD_HEADER_P (h))
2652 if (! C_READONLY_RECORD_HEADER_P (h))
2653 UNMARK_RECORD_HEADER (h);
2655 /* total_size += n->implementation->size_in_bytes (h);*/
2656 /* #### May modify header->next on a C_READONLY lcrecord */
2657 prev = &(header->next);
2659 tick_lcrecord_stats (h, 0);
2663 struct lcrecord_header *next = header->next;
2665 tick_lcrecord_stats (h, 1);
2666 /* used to call finalizer right here. */
2672 /* *total = total_size; */
2677 sweep_bit_vectors_1 (Lisp_Object *prev,
2678 int *used, int *total, int *storage)
2680 Lisp_Object bit_vector;
2683 int total_storage = 0;
2685 /* BIT_VECTORP fails because the objects are marked, which changes
2686 their implementation */
2687 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2689 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2691 if (MARKED_RECORD_P (bit_vector))
2693 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2694 UNMARK_RECORD_HEADER (&(v->lheader));
2698 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
2699 bits, BIT_VECTOR_LONG_STORAGE (len));
2701 /* #### May modify next on a C_READONLY bitvector */
2702 prev = &(bit_vector_next (v));
2707 Lisp_Object next = bit_vector_next (v);
2714 *total = total_size;
2715 *storage = total_storage;
2718 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2719 to make macros prettier. */
2721 #ifdef ERROR_CHECK_GC
2723 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2725 struct typename##_block *SFTB_current; \
2727 int num_free = 0, num_used = 0; \
2729 for (SFTB_current = current_##typename##_block, \
2730 SFTB_limit = current_##typename##_block_index; \
2736 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2738 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2740 if (LRECORD_FREE_P (SFTB_victim)) \
2744 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2748 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2751 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2756 UNMARK_##typename (SFTB_victim); \
2759 SFTB_current = SFTB_current->prev; \
2760 SFTB_limit = countof (current_##typename##_block->block); \
2763 gc_count_num_##typename##_in_use = num_used; \
2764 gc_count_num_##typename##_freelist = num_free; \
2767 #else /* !ERROR_CHECK_GC */
2769 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2771 struct typename##_block *SFTB_current; \
2772 struct typename##_block **SFTB_prev; \
2774 int num_free = 0, num_used = 0; \
2776 typename##_free_list = 0; \
2778 for (SFTB_prev = ¤t_##typename##_block, \
2779 SFTB_current = current_##typename##_block, \
2780 SFTB_limit = current_##typename##_block_index; \
2785 int SFTB_empty = 1; \
2786 Lisp_Free *SFTB_old_free_list = typename##_free_list; \
2788 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2790 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2792 if (LRECORD_FREE_P (SFTB_victim)) \
2795 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2797 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2802 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2805 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2811 UNMARK_##typename (SFTB_victim); \
2816 SFTB_prev = &(SFTB_current->prev); \
2817 SFTB_current = SFTB_current->prev; \
2819 else if (SFTB_current == current_##typename##_block \
2820 && !SFTB_current->prev) \
2822 /* No real point in freeing sole allocation block */ \
2827 struct typename##_block *SFTB_victim_block = SFTB_current; \
2828 if (SFTB_victim_block == current_##typename##_block) \
2829 current_##typename##_block_index \
2830 = countof (current_##typename##_block->block); \
2831 SFTB_current = SFTB_current->prev; \
2833 *SFTB_prev = SFTB_current; \
2834 xfree (SFTB_victim_block); \
2835 /* Restore free list to what it was before victim was swept */ \
2836 typename##_free_list = SFTB_old_free_list; \
2837 num_free -= SFTB_limit; \
2840 SFTB_limit = countof (current_##typename##_block->block); \
2843 gc_count_num_##typename##_in_use = num_used; \
2844 gc_count_num_##typename##_freelist = num_free; \
2847 #endif /* !ERROR_CHECK_GC */
2855 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2856 #define ADDITIONAL_FREE_cons(ptr)
2858 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2861 /* Explicitly free a cons cell. */
2863 free_cons (Lisp_Cons *ptr)
2865 #ifdef ERROR_CHECK_GC
2866 /* If the CAR is not an int, then it will be a pointer, which will
2867 always be four-byte aligned. If this cons cell has already been
2868 placed on the free list, however, its car will probably contain
2869 a chain pointer to the next cons on the list, which has cleverly
2870 had all its 0's and 1's inverted. This allows for a quick
2871 check to make sure we're not freeing something already freed. */
2872 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2873 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2874 #endif /* ERROR_CHECK_GC */
2876 #ifndef ALLOC_NO_POOLS
2877 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2878 #endif /* ALLOC_NO_POOLS */
2881 /* explicitly free a list. You **must make sure** that you have
2882 created all the cons cells that make up this list and that there
2883 are no pointers to any of these cons cells anywhere else. If there
2884 are, you will lose. */
2887 free_list (Lisp_Object list)
2889 Lisp_Object rest, next;
2891 for (rest = list; !NILP (rest); rest = next)
2894 free_cons (XCONS (rest));
2898 /* explicitly free an alist. You **must make sure** that you have
2899 created all the cons cells that make up this alist and that there
2900 are no pointers to any of these cons cells anywhere else. If there
2901 are, you will lose. */
2904 free_alist (Lisp_Object alist)
2906 Lisp_Object rest, next;
2908 for (rest = alist; !NILP (rest); rest = next)
2911 free_cons (XCONS (XCAR (rest)));
2912 free_cons (XCONS (rest));
2917 sweep_compiled_functions (void)
2919 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2920 #define ADDITIONAL_FREE_compiled_function(ptr)
2922 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2926 #ifdef LISP_FLOAT_TYPE
2930 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2931 #define ADDITIONAL_FREE_float(ptr)
2933 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2935 #endif /* LISP_FLOAT_TYPE */
2938 sweep_symbols (void)
2940 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2941 #define ADDITIONAL_FREE_symbol(ptr)
2943 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2947 sweep_extents (void)
2949 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2950 #define ADDITIONAL_FREE_extent(ptr)
2952 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2958 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2959 #define ADDITIONAL_FREE_event(ptr)
2961 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2965 sweep_markers (void)
2967 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2968 #define ADDITIONAL_FREE_marker(ptr) \
2969 do { Lisp_Object tem; \
2970 XSETMARKER (tem, ptr); \
2971 unchain_marker (tem); \
2974 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2977 /* Explicitly free a marker. */
2979 free_marker (Lisp_Marker *ptr)
2981 /* Perhaps this will catch freeing an already-freed marker. */
2982 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
2984 #ifndef ALLOC_NO_POOLS
2985 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2986 #endif /* ALLOC_NO_POOLS */
2990 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2993 verify_string_chars_integrity (void)
2995 struct string_chars_block *sb;
2997 /* Scan each existing string block sequentially, string by string. */
2998 for (sb = first_string_chars_block; sb; sb = sb->next)
3001 /* POS is the index of the next string in the block. */
3002 while (pos < sb->pos)
3004 struct string_chars *s_chars =
3005 (struct string_chars *) &(sb->string_chars[pos]);
3006 Lisp_String *string;
3010 /* If the string_chars struct is marked as free (i.e. the
3011 STRING pointer is NULL) then this is an unused chunk of
3012 string storage. (See below.) */
3014 if (STRING_CHARS_FREE_P (s_chars))
3016 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3021 string = s_chars->string;
3022 /* Must be 32-bit aligned. */
3023 assert ((((int) string) & 3) == 0);
3025 size = string_length (string);
3026 fullsize = STRING_FULLSIZE (size);
3028 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3029 assert (string_data (string) == s_chars->chars);
3032 assert (pos == sb->pos);
3036 #endif /* MULE && ERROR_CHECK_GC */
3038 /* Compactify string chars, relocating the reference to each --
3039 free any empty string_chars_block we see. */
3041 compact_string_chars (void)
3043 struct string_chars_block *to_sb = first_string_chars_block;
3045 struct string_chars_block *from_sb;
3047 /* Scan each existing string block sequentially, string by string. */
3048 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3051 /* FROM_POS is the index of the next string in the block. */
3052 while (from_pos < from_sb->pos)
3054 struct string_chars *from_s_chars =
3055 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3056 struct string_chars *to_s_chars;
3057 Lisp_String *string;
3061 /* If the string_chars struct is marked as free (i.e. the
3062 STRING pointer is NULL) then this is an unused chunk of
3063 string storage. This happens under Mule when a string's
3064 size changes in such a way that its fullsize changes.
3065 (Strings can change size because a different-length
3066 character can be substituted for another character.)
3067 In this case, after the bogus string pointer is the
3068 "fullsize" of this entry, i.e. how many bytes to skip. */
3070 if (STRING_CHARS_FREE_P (from_s_chars))
3072 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3073 from_pos += fullsize;
3077 string = from_s_chars->string;
3078 assert (!(LRECORD_FREE_P (string)));
3080 size = string_length (string);
3081 fullsize = STRING_FULLSIZE (size);
3083 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3085 /* Just skip it if it isn't marked. */
3086 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3088 from_pos += fullsize;
3092 /* If it won't fit in what's left of TO_SB, close TO_SB out
3093 and go on to the next string_chars_block. We know that TO_SB
3094 cannot advance past FROM_SB here since FROM_SB is large enough
3095 to currently contain this string. */
3096 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3098 to_sb->pos = to_pos;
3099 to_sb = to_sb->next;
3103 /* Compute new address of this string
3104 and update TO_POS for the space being used. */
3105 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3107 /* Copy the string_chars to the new place. */
3108 if (from_s_chars != to_s_chars)
3109 memmove (to_s_chars, from_s_chars, fullsize);
3111 /* Relocate FROM_S_CHARS's reference */
3112 set_string_data (string, &(to_s_chars->chars[0]));
3114 from_pos += fullsize;
3119 /* Set current to the last string chars block still used and
3120 free any that follow. */
3122 struct string_chars_block *victim;
3124 for (victim = to_sb->next; victim; )
3126 struct string_chars_block *next = victim->next;
3131 current_string_chars_block = to_sb;
3132 current_string_chars_block->pos = to_pos;
3133 current_string_chars_block->next = 0;
3137 #if 1 /* Hack to debug missing purecopy's */
3138 static int debug_string_purity;
3141 debug_string_purity_print (Lisp_String *p)
3144 Charcount s = string_char_length (p);
3146 for (i = 0; i < s; i++)
3148 Emchar ch = string_char (p, i);
3149 if (ch < 32 || ch >= 126)
3150 stderr_out ("\\%03o", ch);
3151 else if (ch == '\\' || ch == '\"')
3152 stderr_out ("\\%c", ch);
3154 stderr_out ("%c", ch);
3156 stderr_out ("\"\n");
3162 sweep_strings (void)
3164 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3165 int debug = debug_string_purity;
3167 #define UNMARK_string(ptr) do { \
3168 Lisp_String *p = (ptr); \
3169 size_t size = string_length (p); \
3170 UNMARK_RECORD_HEADER (&(p->lheader)); \
3171 num_bytes += size; \
3172 if (!BIG_STRING_SIZE_P (size)) \
3174 num_small_bytes += size; \
3178 debug_string_purity_print (p); \
3180 #define ADDITIONAL_FREE_string(ptr) do { \
3181 size_t size = string_length (ptr); \
3182 if (BIG_STRING_SIZE_P (size)) \
3183 xfree (ptr->data); \
3186 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3188 gc_count_num_short_string_in_use = num_small_used;
3189 gc_count_string_total_size = num_bytes;
3190 gc_count_short_string_total_size = num_small_bytes;
3194 /* I hate duplicating all this crap! */
3196 marked_p (Lisp_Object obj)
3198 /* Checks we used to perform. */
3199 /* if (EQ (obj, Qnull_pointer)) return 1; */
3200 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3201 /* if (PURIFIED (XPNTR (obj))) return 1; */
3203 if (XTYPE (obj) == Lisp_Type_Record)
3205 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3207 GC_CHECK_LHEADER_INVARIANTS (lheader);
3209 return MARKED_RECORD_HEADER_P (lheader);
3217 /* Free all unmarked records. Do this at the very beginning,
3218 before anything else, so that the finalize methods can safely
3219 examine items in the objects. sweep_lcrecords_1() makes
3220 sure to call all the finalize methods *before* freeing anything,
3221 to complete the safety. */
3224 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3227 compact_string_chars ();
3229 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3230 macros) must be *extremely* careful to make sure they're not
3231 referencing freed objects. The only two existing finalize
3232 methods (for strings and markers) pass muster -- the string
3233 finalizer doesn't look at anything but its own specially-
3234 created block, and the marker finalizer only looks at live
3235 buffers (which will never be freed) and at the markers before
3236 and after it in the chain (which, by induction, will never be
3237 freed because if so, they would have already removed themselves
3240 /* Put all unmarked strings on free list, free'ing the string chars
3241 of large unmarked strings */
3244 /* Put all unmarked conses on free list */
3247 /* Free all unmarked bit vectors */
3248 sweep_bit_vectors_1 (&all_bit_vectors,
3249 &gc_count_num_bit_vector_used,
3250 &gc_count_bit_vector_total_size,
3251 &gc_count_bit_vector_storage);
3253 /* Free all unmarked compiled-function objects */
3254 sweep_compiled_functions ();
3256 #ifdef LISP_FLOAT_TYPE
3257 /* Put all unmarked floats on free list */
3261 /* Put all unmarked symbols on free list */
3264 /* Put all unmarked extents on free list */
3267 /* Put all unmarked markers on free list.
3268 Dechain each one first from the buffer into which it points. */
3274 pdump_objects_unmark ();
3278 /* Clearing for disksave. */
3281 disksave_object_finalization (void)
3283 /* It's important that certain information from the environment not get
3284 dumped with the executable (pathnames, environment variables, etc.).
3285 To make it easier to tell when this has happened with strings(1) we
3286 clear some known-to-be-garbage blocks of memory, so that leftover
3287 results of old evaluation don't look like potential problems.
3288 But first we set some notable variables to nil and do one more GC,
3289 to turn those strings into garbage.
3292 /* Yeah, this list is pretty ad-hoc... */
3293 Vprocess_environment = Qnil;
3294 Vexec_directory = Qnil;
3295 Vdata_directory = Qnil;
3296 Vsite_directory = Qnil;
3297 Vdoc_directory = Qnil;
3298 Vconfigure_info_directory = Qnil;
3301 /* Vdump_load_path = Qnil; */
3302 /* Release hash tables for locate_file */
3303 Flocate_file_clear_hashing (Qt);
3304 uncache_home_directory();
3306 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3307 defined(LOADHIST_BUILTIN))
3308 Vload_history = Qnil;
3310 Vshell_file_name = Qnil;
3312 garbage_collect_1 ();
3314 /* Run the disksave finalization methods of all live objects. */
3315 disksave_object_finalization_1 ();
3317 /* Zero out the uninitialized (really, unused) part of the containers
3318 for the live strings. */
3320 struct string_chars_block *scb;
3321 for (scb = first_string_chars_block; scb; scb = scb->next)
3323 int count = sizeof (scb->string_chars) - scb->pos;
3325 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3328 /* from the block's fill ptr to the end */
3329 memset ((scb->string_chars + scb->pos), 0, count);
3334 /* There, that ought to be enough... */
3340 restore_gc_inhibit (Lisp_Object val)
3342 gc_currently_forbidden = XINT (val);
3346 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3347 static int gc_hooks_inhibited;
3351 garbage_collect_1 (void)
3353 #if MAX_SAVE_STACK > 0
3354 char stack_top_variable;
3355 extern char *stack_bottom;
3360 Lisp_Object pre_gc_cursor;
3361 struct gcpro gcpro1;
3364 || gc_currently_forbidden
3366 || preparing_for_armageddon)
3369 /* We used to call selected_frame() here.
3371 The following functions cannot be called inside GC
3372 so we move to after the above tests. */
3375 Lisp_Object device = Fselected_device (Qnil);
3376 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3378 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3380 signal_simple_error ("No frames exist on device", device);
3384 pre_gc_cursor = Qnil;
3387 GCPRO1 (pre_gc_cursor);
3389 /* Very important to prevent GC during any of the following
3390 stuff that might run Lisp code; otherwise, we'll likely
3391 have infinite GC recursion. */
3392 speccount = specpdl_depth ();
3393 record_unwind_protect (restore_gc_inhibit,
3394 make_int (gc_currently_forbidden));
3395 gc_currently_forbidden = 1;
3397 if (!gc_hooks_inhibited)
3398 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3400 /* Now show the GC cursor/message. */
3401 if (!noninteractive)
3403 if (FRAME_WIN_P (f))
3405 Lisp_Object frame = make_frame (f);
3406 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3407 FRAME_SELECTED_WINDOW (f),
3409 pre_gc_cursor = f->pointer;
3410 if (POINTER_IMAGE_INSTANCEP (cursor)
3411 /* don't change if we don't know how to change back. */
3412 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3415 Fset_frame_pointer (frame, cursor);
3419 /* Don't print messages to the stream device. */
3420 if (!cursor_changed && !FRAME_STREAM_P (f))
3422 char *msg = (STRINGP (Vgc_message)
3423 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3425 Lisp_Object args[2], whole_msg;
3426 args[0] = build_string (msg ? msg :
3427 GETTEXT ((const char *) gc_default_message));
3428 args[1] = build_string ("...");
3429 whole_msg = Fconcat (2, args);
3430 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3431 Qgarbage_collecting);
3435 /***** Now we actually start the garbage collection. */
3439 gc_generation_number[0]++;
3441 #if MAX_SAVE_STACK > 0
3443 /* Save a copy of the contents of the stack, for debugging. */
3446 /* Static buffer in which we save a copy of the C stack at each GC. */
3447 static char *stack_copy;
3448 static size_t stack_copy_size;
3450 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3451 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3452 if (stack_size < MAX_SAVE_STACK)
3454 if (stack_copy_size < stack_size)
3456 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3457 stack_copy_size = stack_size;
3461 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3465 #endif /* MAX_SAVE_STACK > 0 */
3467 /* Do some totally ad-hoc resource clearing. */
3468 /* #### generalize this? */
3469 clear_event_resource ();
3470 cleanup_specifiers ();
3472 /* Mark all the special slots that serve as the roots of accessibility. */
3475 Lisp_Object **p = Dynarr_begin (staticpros);
3477 for (count = Dynarr_length (staticpros); count; count--)
3478 mark_object (**p++);
3481 { /* staticpro_nodump() */
3482 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
3484 for (count = Dynarr_length (staticpros_nodump); count; count--)
3485 mark_object (**p++);
3491 for (tail = gcprolist; tail; tail = tail->next)
3492 for (i = 0; i < tail->nvars; i++)
3493 mark_object (tail->var[i]);
3497 struct specbinding *bind;
3498 for (bind = specpdl; bind != specpdl_ptr; bind++)
3500 mark_object (bind->symbol);
3501 mark_object (bind->old_value);
3506 struct catchtag *catch;
3507 for (catch = catchlist; catch; catch = catch->next)
3509 mark_object (catch->tag);
3510 mark_object (catch->val);
3515 struct backtrace *backlist;
3516 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3518 int nargs = backlist->nargs;
3521 mark_object (*backlist->function);
3522 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
3523 mark_object (backlist->args[0]);
3525 for (i = 0; i < nargs; i++)
3526 mark_object (backlist->args[i]);
3531 mark_profiling_info ();
3533 /* OK, now do the after-mark stuff. This is for things that
3534 are only marked when something else is marked (e.g. weak hash tables).
3535 There may be complex dependencies between such objects -- e.g.
3536 a weak hash table might be unmarked, but after processing a later
3537 weak hash table, the former one might get marked. So we have to
3538 iterate until nothing more gets marked. */
3540 while (finish_marking_weak_hash_tables () > 0 ||
3541 finish_marking_weak_lists () > 0)
3544 /* And prune (this needs to be called after everything else has been
3545 marked and before we do any sweeping). */
3546 /* #### this is somewhat ad-hoc and should probably be an object
3548 prune_weak_hash_tables ();
3549 prune_weak_lists ();
3550 prune_specifiers ();
3551 prune_syntax_tables ();
3555 consing_since_gc = 0;
3556 #ifndef DEBUG_XEMACS
3557 /* Allow you to set it really fucking low if you really want ... */
3558 if (gc_cons_threshold < 10000)
3559 gc_cons_threshold = 10000;
3564 /******* End of garbage collection ********/
3566 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3568 /* Now remove the GC cursor/message */
3569 if (!noninteractive)
3572 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3573 else if (!FRAME_STREAM_P (f))
3575 char *msg = (STRINGP (Vgc_message)
3576 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3579 /* Show "...done" only if the echo area would otherwise be empty. */
3580 if (NILP (clear_echo_area (selected_frame (),
3581 Qgarbage_collecting, 0)))
3583 Lisp_Object args[2], whole_msg;
3584 args[0] = build_string (msg ? msg :
3585 GETTEXT ((const char *)
3586 gc_default_message));
3587 args[1] = build_string ("... done");
3588 whole_msg = Fconcat (2, args);
3589 echo_area_message (selected_frame (), (Bufbyte *) 0,
3591 Qgarbage_collecting);
3596 /* now stop inhibiting GC */
3597 unbind_to (speccount, Qnil);
3599 if (!breathing_space)
3601 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3608 /* Debugging aids. */
3611 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3613 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3614 or portable numeric datatypes, or bit-vectors, or characters, or
3615 arrays, or exceptions, or ...) */
3616 return cons3 (intern (name), make_int (value), tail);
3619 #define HACK_O_MATIC(type, name, pl) do { \
3621 struct type##_block *x = current_##type##_block; \
3622 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3623 (pl) = gc_plist_hack ((name), s, (pl)); \
3626 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3627 Reclaim storage for Lisp objects no longer needed.
3628 Return info on amount of space in use:
3629 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3630 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3632 where `PLIST' is a list of alternating keyword/value pairs providing
3633 more detailed information.
3634 Garbage collection happens automatically if you cons more than
3635 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3639 Lisp_Object pl = Qnil;
3641 int gc_count_vector_total_size = 0;
3643 garbage_collect_1 ();
3645 for (i = 0; i < lrecord_type_count; i++)
3647 if (lcrecord_stats[i].bytes_in_use != 0
3648 || lcrecord_stats[i].bytes_freed != 0
3649 || lcrecord_stats[i].instances_on_free_list != 0)
3652 const char *name = lrecord_implementations_table[i]->name;
3653 int len = strlen (name);
3654 /* save this for the FSFmacs-compatible part of the summary */
3655 if (i == lrecord_vector.lrecord_type_index)
3656 gc_count_vector_total_size =
3657 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3659 sprintf (buf, "%s-storage", name);
3660 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3661 /* Okay, simple pluralization check for `symbol-value-varalias' */
3662 if (name[len-1] == 's')
3663 sprintf (buf, "%ses-freed", name);
3665 sprintf (buf, "%ss-freed", name);
3666 if (lcrecord_stats[i].instances_freed != 0)
3667 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3668 if (name[len-1] == 's')
3669 sprintf (buf, "%ses-on-free-list", name);
3671 sprintf (buf, "%ss-on-free-list", name);
3672 if (lcrecord_stats[i].instances_on_free_list != 0)
3673 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3675 if (name[len-1] == 's')
3676 sprintf (buf, "%ses-used", name);
3678 sprintf (buf, "%ss-used", name);
3679 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3683 HACK_O_MATIC (extent, "extent-storage", pl);
3684 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3685 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3686 HACK_O_MATIC (event, "event-storage", pl);
3687 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3688 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3689 HACK_O_MATIC (marker, "marker-storage", pl);
3690 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3691 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3692 #ifdef LISP_FLOAT_TYPE
3693 HACK_O_MATIC (float, "float-storage", pl);
3694 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3695 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3696 #endif /* LISP_FLOAT_TYPE */
3697 HACK_O_MATIC (string, "string-header-storage", pl);
3698 pl = gc_plist_hack ("long-strings-total-length",
3699 gc_count_string_total_size
3700 - gc_count_short_string_total_size, pl);
3701 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3702 pl = gc_plist_hack ("short-strings-total-length",
3703 gc_count_short_string_total_size, pl);
3704 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3705 pl = gc_plist_hack ("long-strings-used",
3706 gc_count_num_string_in_use
3707 - gc_count_num_short_string_in_use, pl);
3708 pl = gc_plist_hack ("short-strings-used",
3709 gc_count_num_short_string_in_use, pl);
3711 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3712 pl = gc_plist_hack ("compiled-functions-free",
3713 gc_count_num_compiled_function_freelist, pl);
3714 pl = gc_plist_hack ("compiled-functions-used",
3715 gc_count_num_compiled_function_in_use, pl);
3717 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3718 pl = gc_plist_hack ("bit-vectors-total-length",
3719 gc_count_bit_vector_total_size, pl);
3720 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3722 HACK_O_MATIC (symbol, "symbol-storage", pl);
3723 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3724 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3726 HACK_O_MATIC (cons, "cons-storage", pl);
3727 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3728 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3730 /* The things we do for backwards-compatibility */
3732 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3733 make_int (gc_count_num_cons_freelist)),
3734 Fcons (make_int (gc_count_num_symbol_in_use),
3735 make_int (gc_count_num_symbol_freelist)),
3736 Fcons (make_int (gc_count_num_marker_in_use),
3737 make_int (gc_count_num_marker_freelist)),
3738 make_int (gc_count_string_total_size),
3739 make_int (gc_count_vector_total_size),
3744 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3745 Return the number of bytes consed since the last garbage collection.
3746 \"Consed\" is a misnomer in that this actually counts allocation
3747 of all different kinds of objects, not just conses.
3749 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3753 return make_int (consing_since_gc);
3757 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
3758 Return the address of the last byte Emacs has allocated, divided by 1024.
3759 This may be helpful in debugging Emacs's memory usage.
3760 The value is divided by 1024 to make sure it will fit in a lisp integer.
3764 return make_int ((EMACS_INT) sbrk (0) / 1024);
3770 object_dead_p (Lisp_Object obj)
3772 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3773 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3774 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3775 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3776 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3777 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3778 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3781 #ifdef MEMORY_USAGE_STATS
3783 /* Attempt to determine the actual amount of space that is used for
3784 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3786 It seems that the following holds:
3788 1. When using the old allocator (malloc.c):
3790 -- blocks are always allocated in chunks of powers of two. For
3791 each block, there is an overhead of 8 bytes if rcheck is not
3792 defined, 20 bytes if it is defined. In other words, a
3793 one-byte allocation needs 8 bytes of overhead for a total of
3794 9 bytes, and needs to have 16 bytes of memory chunked out for
3797 2. When using the new allocator (gmalloc.c):
3799 -- blocks are always allocated in chunks of powers of two up
3800 to 4096 bytes. Larger blocks are allocated in chunks of
3801 an integral multiple of 4096 bytes. The minimum block
3802 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3803 is defined. There is no per-block overhead, but there
3804 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3807 3. When using the system malloc, anything goes, but they are
3808 generally slower and more space-efficient than the GNU
3809 allocators. One possibly reasonable assumption to make
3810 for want of better data is that sizeof (void *), or maybe
3811 2 * sizeof (void *), is required as overhead and that
3812 blocks are allocated in the minimum required size except
3813 that some minimum block size is imposed (e.g. 16 bytes). */
3816 malloced_storage_size (void *ptr, size_t claimed_size,
3817 struct overhead_stats *stats)
3819 size_t orig_claimed_size = claimed_size;
3823 if (claimed_size < 2 * sizeof (void *))
3824 claimed_size = 2 * sizeof (void *);
3825 # ifdef SUNOS_LOCALTIME_BUG
3826 if (claimed_size < 16)
3829 if (claimed_size < 4096)
3833 /* compute the log base two, more or less, then use it to compute
3834 the block size needed. */
3836 /* It's big, it's heavy, it's wood! */
3837 while ((claimed_size /= 2) != 0)
3840 /* It's better than bad, it's good! */
3846 /* We have to come up with some average about the amount of
3848 if ((size_t) (rand () & 4095) < claimed_size)
3849 claimed_size += 3 * sizeof (void *);
3853 claimed_size += 4095;
3854 claimed_size &= ~4095;
3855 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3858 #elif defined (SYSTEM_MALLOC)
3860 if (claimed_size < 16)
3862 claimed_size += 2 * sizeof (void *);
3864 #else /* old GNU allocator */
3866 # ifdef rcheck /* #### may not be defined here */
3874 /* compute the log base two, more or less, then use it to compute
3875 the block size needed. */
3877 /* It's big, it's heavy, it's wood! */
3878 while ((claimed_size /= 2) != 0)
3881 /* It's better than bad, it's good! */
3889 #endif /* old GNU allocator */
3893 stats->was_requested += orig_claimed_size;
3894 stats->malloc_overhead += claimed_size - orig_claimed_size;
3896 return claimed_size;
3900 fixed_type_block_overhead (size_t size)
3902 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3903 size_t overhead = 0;
3904 size_t storage_size = malloced_storage_size (0, per_block, 0);
3905 while (size >= per_block)
3908 overhead += sizeof (void *) + per_block - storage_size;
3910 if (rand () % per_block < size)
3911 overhead += sizeof (void *) + per_block - storage_size;
3915 #endif /* MEMORY_USAGE_STATS */
3918 /* Initialization */
3920 reinit_alloc_once_early (void)
3922 gc_generation_number[0] = 0;
3923 breathing_space = 0;
3924 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3925 XSETINT (Vgc_message, 0);
3928 all_older_lcrecords = 0;
3930 ignore_malloc_warnings = 1;
3931 #ifdef DOUG_LEA_MALLOC
3932 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3933 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3934 #if 0 /* Moved to emacs.c */
3935 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3938 init_string_alloc ();
3939 init_string_chars_alloc ();
3941 init_symbol_alloc ();
3942 init_compiled_function_alloc ();
3943 #ifdef LISP_FLOAT_TYPE
3944 init_float_alloc ();
3945 #endif /* LISP_FLOAT_TYPE */
3946 init_marker_alloc ();
3947 init_extent_alloc ();
3948 init_event_alloc ();
3950 ignore_malloc_warnings = 0;
3952 if (staticpros_nodump)
3953 Dynarr_free (staticpros_nodump);
3954 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3955 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
3957 consing_since_gc = 0;
3959 gc_cons_threshold = 500000; /* XEmacs change */
3961 gc_cons_threshold = 15000; /* debugging */
3963 lrecord_uid_counter = 259;
3964 debug_string_purity = 0;
3967 gc_currently_forbidden = 0;
3968 gc_hooks_inhibited = 0;
3970 #ifdef ERROR_CHECK_TYPECHECK
3971 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3974 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3976 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3978 #endif /* ERROR_CHECK_TYPECHECK */
3982 init_alloc_once_early (void)
3984 reinit_alloc_once_early ();
3988 for (i = 0; i < countof (lrecord_implementations_table); i++)
3989 lrecord_implementations_table[i] = 0;
3992 INIT_LRECORD_IMPLEMENTATION (cons);
3993 INIT_LRECORD_IMPLEMENTATION (vector);
3994 INIT_LRECORD_IMPLEMENTATION (string);
3995 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3997 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3998 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3999 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
4009 syms_of_alloc (void)
4011 DEFSYMBOL (Qpre_gc_hook);
4012 DEFSYMBOL (Qpost_gc_hook);
4013 DEFSYMBOL (Qgarbage_collecting);
4018 DEFSUBR (Fbit_vector);
4019 DEFSUBR (Fmake_byte_code);
4020 DEFSUBR (Fmake_list);
4021 DEFSUBR (Fmake_vector);
4022 DEFSUBR (Fmake_bit_vector);
4023 DEFSUBR (Fmake_string);
4025 DEFSUBR (Fmake_symbol);
4026 DEFSUBR (Fmake_marker);
4027 DEFSUBR (Fpurecopy);
4028 DEFSUBR (Fgarbage_collect);
4030 DEFSUBR (Fmemory_limit);
4032 DEFSUBR (Fconsing_since_gc);
4036 vars_of_alloc (void)
4038 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4039 *Number of bytes of consing between garbage collections.
4040 \"Consing\" is a misnomer in that this actually counts allocation
4041 of all different kinds of objects, not just conses.
4042 Garbage collection can happen automatically once this many bytes have been
4043 allocated since the last garbage collection. All data types count.
4045 Garbage collection happens automatically when `eval' or `funcall' are
4046 called. (Note that `funcall' is called implicitly as part of evaluation.)
4047 By binding this temporarily to a large number, you can effectively
4048 prevent garbage collection during a part of the program.
4050 See also `consing-since-gc'.
4054 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4055 If non-zero, print out information to stderr about all objects allocated.
4056 See also `debug-allocation-backtrace-length'.
4058 debug_allocation = 0;
4060 DEFVAR_INT ("debug-allocation-backtrace-length",
4061 &debug_allocation_backtrace_length /*
4062 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4064 debug_allocation_backtrace_length = 2;
4067 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4068 Non-nil means loading Lisp code in order to dump an executable.
4069 This means that certain objects should be allocated in readonly space.
4072 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4073 Function or functions to be run just before each garbage collection.
4074 Interrupts, garbage collection, and errors are inhibited while this hook
4075 runs, so be extremely careful in what you add here. In particular, avoid
4076 consing, and do not interact with the user.
4078 Vpre_gc_hook = Qnil;
4080 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4081 Function or functions to be run just after each garbage collection.
4082 Interrupts, garbage collection, and errors are inhibited while this hook
4083 runs, so be extremely careful in what you add here. In particular, avoid
4084 consing, and do not interact with the user.
4086 Vpost_gc_hook = Qnil;
4088 DEFVAR_LISP ("gc-message", &Vgc_message /*
4089 String to print to indicate that a garbage collection is in progress.
4090 This is printed in the echo area. If the selected frame is on a
4091 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4092 image instance) in the domain of the selected frame, the mouse pointer
4093 will change instead of this message being printed.
4095 Vgc_message = build_string (gc_default_message);
4097 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4098 Pointer glyph used to indicate that a garbage collection is in progress.
4099 If the selected window is on a window system and this glyph specifies a
4100 value (i.e. a pointer image instance) in the domain of the selected
4101 window, the pointer will be changed as specified during garbage collection.
4102 Otherwise, a message will be printed in the echo area, as controlled
4108 complex_vars_of_alloc (void)
4110 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);