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, 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, contents, sizei);
1137 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1144 make_vector (size_t length, Lisp_Object object)
1146 Lisp_Vector *vecp = make_vector_internal (length);
1147 Lisp_Object *p = vector_data (vecp);
1154 XSETVECTOR (vector, vecp);
1161 make_older_vector (size_t length, Lisp_Object init)
1163 struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
1166 all_lcrecords = all_older_lcrecords;
1167 obj = make_vector (length, init);
1168 all_older_lcrecords = all_lcrecords;
1169 all_lcrecords = orig_all_lcrecords;
1173 void make_vector_newer_1 (Lisp_Object v);
1175 make_vector_newer_1 (Lisp_Object v)
1177 struct lcrecord_header* lcrecords = all_older_lcrecords;
1179 if (lcrecords != NULL)
1181 if (lcrecords == XPNTR (v))
1183 lcrecords->lheader.older = 0;
1184 all_older_lcrecords = all_older_lcrecords->next;
1185 lcrecords->next = all_lcrecords;
1186 all_lcrecords = lcrecords;
1191 struct lcrecord_header* plcrecords = lcrecords;
1193 lcrecords = lcrecords->next;
1194 while (lcrecords != NULL)
1196 if (lcrecords == XPNTR (v))
1198 lcrecords->lheader.older = 0;
1199 plcrecords->next = lcrecords->next;
1200 lcrecords->next = all_lcrecords;
1201 all_lcrecords = lcrecords;
1204 plcrecords = lcrecords;
1205 lcrecords = lcrecords->next;
1212 make_vector_newer (Lisp_Object v)
1216 for (i = 0; i < XVECTOR_LENGTH (v); i++)
1218 Lisp_Object obj = XVECTOR_DATA (v)[i];
1220 if (VECTORP (obj) && !EQ (obj, v))
1221 make_vector_newer (obj);
1223 make_vector_newer_1 (v);
1227 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1228 Return a new vector of length LENGTH, with each element being OBJECT.
1229 See also the function `vector'.
1233 CONCHECK_NATNUM (length);
1234 return make_vector (XINT (length), object);
1237 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1238 Return a newly created vector with specified arguments as elements.
1239 Any number of arguments, even zero arguments, are allowed.
1241 (int nargs, Lisp_Object *args))
1243 Lisp_Vector *vecp = make_vector_internal (nargs);
1244 Lisp_Object *p = vector_data (vecp);
1251 XSETVECTOR (vector, vecp);
1257 vector1 (Lisp_Object obj0)
1259 return Fvector (1, &obj0);
1263 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1265 Lisp_Object args[2];
1268 return Fvector (2, args);
1272 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1274 Lisp_Object args[3];
1278 return Fvector (3, args);
1281 #if 0 /* currently unused */
1284 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1287 Lisp_Object args[4];
1292 return Fvector (4, args);
1296 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1297 Lisp_Object obj3, Lisp_Object obj4)
1299 Lisp_Object args[5];
1305 return Fvector (5, args);
1309 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1310 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1312 Lisp_Object args[6];
1319 return Fvector (6, args);
1323 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1324 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1327 Lisp_Object args[7];
1335 return Fvector (7, args);
1339 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1340 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1341 Lisp_Object obj6, Lisp_Object obj7)
1343 Lisp_Object args[8];
1352 return Fvector (8, args);
1356 /************************************************************************/
1357 /* Bit Vector allocation */
1358 /************************************************************************/
1360 static Lisp_Object all_bit_vectors;
1362 /* #### should allocate `small' bit vectors from a frob-block */
1363 static Lisp_Bit_Vector *
1364 make_bit_vector_internal (size_t sizei)
1366 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1367 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1368 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1369 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1371 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1373 bit_vector_length (p) = sizei;
1374 bit_vector_next (p) = all_bit_vectors;
1375 /* make sure the extra bits in the last long are 0; the calling
1376 functions might not set them. */
1377 p->bits[num_longs - 1] = 0;
1378 XSETBIT_VECTOR (all_bit_vectors, p);
1383 make_bit_vector (size_t length, Lisp_Object bit)
1385 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1386 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1391 memset (p->bits, 0, num_longs * sizeof (long));
1394 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1395 memset (p->bits, ~0, num_longs * sizeof (long));
1396 /* But we have to make sure that the unused bits in the
1397 last long are 0, so that equal/hash is easy. */
1399 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1403 Lisp_Object bit_vector;
1404 XSETBIT_VECTOR (bit_vector, p);
1410 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1413 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1415 for (i = 0; i < length; i++)
1416 set_bit_vector_bit (p, i, bytevec[i]);
1419 Lisp_Object bit_vector;
1420 XSETBIT_VECTOR (bit_vector, p);
1425 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1426 Return a new bit vector of length LENGTH. with each bit set to BIT.
1427 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1431 CONCHECK_NATNUM (length);
1433 return make_bit_vector (XINT (length), bit);
1436 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1437 Return a newly created bit vector with specified arguments as elements.
1438 Any number of arguments, even zero arguments, are allowed.
1439 Each argument must be one of the integers 0 or 1.
1441 (int nargs, Lisp_Object *args))
1444 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1446 for (i = 0; i < nargs; i++)
1448 CHECK_BIT (args[i]);
1449 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1453 Lisp_Object bit_vector;
1454 XSETBIT_VECTOR (bit_vector, p);
1460 /************************************************************************/
1461 /* Compiled-function allocation */
1462 /************************************************************************/
1464 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1465 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1468 make_compiled_function (void)
1470 Lisp_Compiled_Function *f;
1473 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1474 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1477 f->specpdl_depth = 0;
1478 f->flags.documentationp = 0;
1479 f->flags.interactivep = 0;
1480 f->flags.domainp = 0; /* I18N3 */
1481 f->instructions = Qzero;
1482 f->constants = Qzero;
1484 f->doc_and_interactive = Qnil;
1485 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1486 f->annotated = Qnil;
1488 XSETCOMPILED_FUNCTION (fun, f);
1492 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1493 Return a new compiled-function object.
1494 Usage: (arglist instructions constants stack-depth
1495 &optional doc-string interactive)
1496 Note that, unlike all other emacs-lisp functions, calling this with five
1497 arguments is NOT the same as calling it with six arguments, the last of
1498 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1499 that this function was defined with `(interactive)'. If the arg is not
1500 specified, then that means the function is not interactive.
1501 This is terrible behavior which is retained for compatibility with old
1502 `.elc' files which expect these semantics.
1504 (int nargs, Lisp_Object *args))
1506 /* In a non-insane world this function would have this arglist...
1507 (arglist instructions constants stack_depth &optional doc_string interactive)
1509 Lisp_Object fun = make_compiled_function ();
1510 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1512 Lisp_Object arglist = args[0];
1513 Lisp_Object instructions = args[1];
1514 Lisp_Object constants = args[2];
1515 Lisp_Object stack_depth = args[3];
1516 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1517 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1519 if (nargs < 4 || nargs > 6)
1520 return Fsignal (Qwrong_number_of_arguments,
1521 list2 (intern ("make-byte-code"), make_int (nargs)));
1523 /* Check for valid formal parameter list now, to allow us to use
1524 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1526 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1528 CHECK_SYMBOL (symbol);
1529 if (EQ (symbol, Qt) ||
1530 EQ (symbol, Qnil) ||
1531 SYMBOL_IS_KEYWORD (symbol))
1532 signal_simple_error_2
1533 ("Invalid constant symbol in formal parameter list",
1537 f->arglist = arglist;
1539 /* `instructions' is a string or a cons (string . int) for a
1540 lazy-loaded function. */
1541 if (CONSP (instructions))
1543 CHECK_STRING (XCAR (instructions));
1544 CHECK_INT (XCDR (instructions));
1548 CHECK_STRING (instructions);
1550 f->instructions = instructions;
1552 if (!NILP (constants))
1553 CHECK_VECTOR (constants);
1554 f->constants = constants;
1556 CHECK_NATNUM (stack_depth);
1557 f->stack_depth = (unsigned short) XINT (stack_depth);
1559 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1560 if (!NILP (Vcurrent_compiled_function_annotation))
1561 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1562 else if (!NILP (Vload_file_name_internal_the_purecopy))
1563 f->annotated = Vload_file_name_internal_the_purecopy;
1564 else if (!NILP (Vload_file_name_internal))
1566 struct gcpro gcpro1;
1567 GCPRO1 (fun); /* don't let fun get reaped */
1568 Vload_file_name_internal_the_purecopy =
1569 Ffile_name_nondirectory (Vload_file_name_internal);
1570 f->annotated = Vload_file_name_internal_the_purecopy;
1573 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1575 /* doc_string may be nil, string, int, or a cons (string . int).
1576 interactive may be list or string (or unbound). */
1577 f->doc_and_interactive = Qunbound;
1579 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1580 f->doc_and_interactive = Vfile_domain;
1582 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1584 f->doc_and_interactive
1585 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1586 Fcons (interactive, f->doc_and_interactive));
1588 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1590 f->doc_and_interactive
1591 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1592 Fcons (doc_string, f->doc_and_interactive));
1594 if (UNBOUNDP (f->doc_and_interactive))
1595 f->doc_and_interactive = Qnil;
1601 /************************************************************************/
1602 /* Symbol allocation */
1603 /************************************************************************/
1605 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1606 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1608 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1609 Return a newly allocated uninterned symbol whose name is NAME.
1610 Its value and function definition are void, and its property list is nil.
1617 CHECK_STRING (name);
1619 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1620 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1621 p->name = XSTRING (name);
1623 p->value = Qunbound;
1624 p->function = Qunbound;
1625 symbol_next (p) = 0;
1626 XSETSYMBOL (val, p);
1631 /************************************************************************/
1632 /* Extent allocation */
1633 /************************************************************************/
1635 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1636 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1639 allocate_extent (void)
1643 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1644 set_lheader_implementation (&e->lheader, &lrecord_extent);
1645 extent_object (e) = Qnil;
1646 set_extent_start (e, -1);
1647 set_extent_end (e, -1);
1652 extent_face (e) = Qnil;
1653 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1654 e->flags.detachable = 1;
1660 /************************************************************************/
1661 /* Event allocation */
1662 /************************************************************************/
1664 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1665 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1668 allocate_event (void)
1673 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1674 set_lheader_implementation (&e->lheader, &lrecord_event);
1681 /************************************************************************/
1682 /* Marker allocation */
1683 /************************************************************************/
1685 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1686 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1688 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1689 Return a new marker which does not point at any place.
1696 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1697 set_lheader_implementation (&p->lheader, &lrecord_marker);
1700 marker_next (p) = 0;
1701 marker_prev (p) = 0;
1702 p->insertion_type = 0;
1703 XSETMARKER (val, p);
1708 noseeum_make_marker (void)
1713 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1714 set_lheader_implementation (&p->lheader, &lrecord_marker);
1717 marker_next (p) = 0;
1718 marker_prev (p) = 0;
1719 p->insertion_type = 0;
1720 XSETMARKER (val, p);
1725 /************************************************************************/
1726 /* String allocation */
1727 /************************************************************************/
1729 /* The data for "short" strings generally resides inside of structs of type
1730 string_chars_block. The Lisp_String structure is allocated just like any
1731 other Lisp object (except for vectors), and these are freelisted when
1732 they get garbage collected. The data for short strings get compacted,
1733 but the data for large strings do not.
1735 Previously Lisp_String structures were relocated, but this caused a lot
1736 of bus-errors because the C code didn't include enough GCPRO's for
1737 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1738 that the reference would get relocated).
1740 This new method makes things somewhat bigger, but it is MUCH safer. */
1742 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1743 /* strings are used and freed quite often */
1744 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1745 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1748 mark_string (Lisp_Object obj)
1750 Lisp_String *ptr = XSTRING (obj);
1752 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1753 flush_cached_extent_info (XCAR (ptr->plist));
1758 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1761 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1762 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1765 static const struct lrecord_description string_description[] = {
1766 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1767 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1768 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1772 /* We store the string's extent info as the first element of the string's
1773 property list; and the string's MODIFF as the first or second element
1774 of the string's property list (depending on whether the extent info
1775 is present), but only if the string has been modified. This is ugly
1776 but it reduces the memory allocated for the string in the vast
1777 majority of cases, where the string is never modified and has no
1780 #### This means you can't use an int as a key in a string's plist. */
1782 static Lisp_Object *
1783 string_plist_ptr (Lisp_Object string)
1785 Lisp_Object *ptr = &XSTRING (string)->plist;
1787 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1789 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1795 string_getprop (Lisp_Object string, Lisp_Object property)
1797 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1801 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1803 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1808 string_remprop (Lisp_Object string, Lisp_Object property)
1810 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1814 string_plist (Lisp_Object string)
1816 return *string_plist_ptr (string);
1819 /* No `finalize', or `hash' methods.
1820 internal_hash() already knows how to hash strings and finalization
1821 is done with the ADDITIONAL_FREE_string macro, which is the
1822 standard way to do finalization when using
1823 SWEEP_FIXED_TYPE_BLOCK(). */
1824 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1825 mark_string, print_string,
1834 /* String blocks contain this many useful bytes. */
1835 #define STRING_CHARS_BLOCK_SIZE \
1836 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1837 ((2 * sizeof (struct string_chars_block *)) \
1838 + sizeof (EMACS_INT))))
1839 /* Block header for small strings. */
1840 struct string_chars_block
1843 struct string_chars_block *next;
1844 struct string_chars_block *prev;
1845 /* Contents of string_chars_block->string_chars are interleaved
1846 string_chars structures (see below) and the actual string data */
1847 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1850 static struct string_chars_block *first_string_chars_block;
1851 static struct string_chars_block *current_string_chars_block;
1853 /* If SIZE is the length of a string, this returns how many bytes
1854 * the string occupies in string_chars_block->string_chars
1855 * (including alignment padding).
1857 #define STRING_FULLSIZE(size) \
1858 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1859 ALIGNOF (Lisp_String *))
1861 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1862 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1864 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
1865 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
1869 Lisp_String *string;
1870 unsigned char chars[1];
1873 struct unused_string_chars
1875 Lisp_String *string;
1880 init_string_chars_alloc (void)
1882 first_string_chars_block = xnew (struct string_chars_block);
1883 first_string_chars_block->prev = 0;
1884 first_string_chars_block->next = 0;
1885 first_string_chars_block->pos = 0;
1886 current_string_chars_block = first_string_chars_block;
1889 static struct string_chars *
1890 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1893 struct string_chars *s_chars;
1896 (countof (current_string_chars_block->string_chars)
1897 - current_string_chars_block->pos))
1899 /* This string can fit in the current string chars block */
1900 s_chars = (struct string_chars *)
1901 (current_string_chars_block->string_chars
1902 + current_string_chars_block->pos);
1903 current_string_chars_block->pos += fullsize;
1907 /* Make a new current string chars block */
1908 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1910 current_string_chars_block->next = new_scb;
1911 new_scb->prev = current_string_chars_block;
1913 current_string_chars_block = new_scb;
1914 new_scb->pos = fullsize;
1915 s_chars = (struct string_chars *)
1916 current_string_chars_block->string_chars;
1919 s_chars->string = string_it_goes_with;
1921 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1927 make_uninit_string (Bytecount length)
1930 EMACS_INT fullsize = STRING_FULLSIZE (length);
1933 assert (length >= 0 && fullsize > 0);
1935 /* Allocate the string header */
1936 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1937 set_lheader_implementation (&s->lheader, &lrecord_string);
1939 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1940 ? xnew_array (Bufbyte, length + 1)
1941 : allocate_string_chars_struct (s, fullsize)->chars);
1943 set_string_length (s, length);
1946 set_string_byte (s, length, 0);
1948 XSETSTRING (val, s);
1952 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1953 static void verify_string_chars_integrity (void);
1956 /* Resize the string S so that DELTA bytes can be inserted starting
1957 at POS. If DELTA < 0, it means deletion starting at POS. If
1958 POS < 0, resize the string but don't copy any characters. Use
1959 this if you're planning on completely overwriting the string.
1963 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1965 Bytecount oldfullsize, newfullsize;
1966 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1967 verify_string_chars_integrity ();
1970 #ifdef ERROR_CHECK_BUFPOS
1973 assert (pos <= string_length (s));
1975 assert (pos + (-delta) <= string_length (s));
1980 assert ((-delta) <= string_length (s));
1982 #endif /* ERROR_CHECK_BUFPOS */
1985 /* simplest case: no size change. */
1988 if (pos >= 0 && delta < 0)
1989 /* If DELTA < 0, the functions below will delete the characters
1990 before POS. We want to delete characters *after* POS, however,
1991 so convert this to the appropriate form. */
1994 oldfullsize = STRING_FULLSIZE (string_length (s));
1995 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1997 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1999 if (BIG_STRING_FULLSIZE_P (newfullsize))
2001 /* Both strings are big. We can just realloc().
2002 But careful! If the string is shrinking, we have to
2003 memmove() _before_ realloc(), and if growing, we have to
2004 memmove() _after_ realloc() - otherwise the access is
2005 illegal, and we might crash. */
2006 Bytecount len = string_length (s) + 1 - pos;
2008 if (delta < 0 && pos >= 0)
2009 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2010 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2011 string_length (s) + delta + 1));
2012 if (delta > 0 && pos >= 0)
2013 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2015 else /* String has been demoted from BIG_STRING. */
2018 allocate_string_chars_struct (s, newfullsize)->chars;
2019 Bufbyte *old_data = string_data (s);
2023 memcpy (new_data, old_data, pos);
2024 memcpy (new_data + pos + delta, old_data + pos,
2025 string_length (s) + 1 - pos);
2027 set_string_data (s, new_data);
2031 else /* old string is small */
2033 if (oldfullsize == newfullsize)
2035 /* special case; size change but the necessary
2036 allocation size won't change (up or down; code
2037 somewhere depends on there not being any unused
2038 allocation space, modulo any alignment
2042 Bufbyte *addroff = pos + string_data (s);
2044 memmove (addroff + delta, addroff,
2045 /* +1 due to zero-termination. */
2046 string_length (s) + 1 - pos);
2051 Bufbyte *old_data = string_data (s);
2053 BIG_STRING_FULLSIZE_P (newfullsize)
2054 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2055 : allocate_string_chars_struct (s, newfullsize)->chars;
2059 memcpy (new_data, old_data, pos);
2060 memcpy (new_data + pos + delta, old_data + pos,
2061 string_length (s) + 1 - pos);
2063 set_string_data (s, new_data);
2066 /* We need to mark this chunk of the string_chars_block
2067 as unused so that compact_string_chars() doesn't
2069 struct string_chars *old_s_chars = (struct string_chars *)
2070 ((char *) old_data - offsetof (struct string_chars, chars));
2071 /* Sanity check to make sure we aren't hosed by strange
2072 alignment/padding. */
2073 assert (old_s_chars->string == s);
2074 MARK_STRING_CHARS_AS_FREE (old_s_chars);
2075 ((struct unused_string_chars *) old_s_chars)->fullsize =
2081 set_string_length (s, string_length (s) + delta);
2082 /* If pos < 0, the string won't be zero-terminated.
2083 Terminate now just to make sure. */
2084 string_data (s)[string_length (s)] = '\0';
2090 XSETSTRING (string, s);
2091 /* We also have to adjust all of the extent indices after the
2092 place we did the change. We say "pos - 1" because
2093 adjust_extents() is exclusive of the starting position
2095 adjust_extents (string, pos - 1, string_length (s),
2099 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2100 verify_string_chars_integrity ();
2107 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2109 Bufbyte newstr[MAX_EMCHAR_LEN];
2110 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2111 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2112 Bytecount newlen = set_charptr_emchar (newstr, c);
2114 if (oldlen != newlen)
2115 resize_string (s, bytoff, newlen - oldlen);
2116 /* Remember, string_data (s) might have changed so we can't cache it. */
2117 memcpy (string_data (s) + bytoff, newstr, newlen);
2122 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2123 Return a new string consisting of LENGTH copies of CHARACTER.
2124 LENGTH must be a non-negative integer.
2126 (length, character))
2128 CHECK_NATNUM (length);
2129 CHECK_CHAR_COERCE_INT (character);
2131 Bufbyte init_str[MAX_EMCHAR_LEN];
2132 int len = set_charptr_emchar (init_str, XCHAR (character));
2133 Lisp_Object val = make_uninit_string (len * XINT (length));
2136 /* Optimize the single-byte case */
2137 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2141 Bufbyte *ptr = XSTRING_DATA (val);
2143 for (i = XINT (length); i; i--)
2145 Bufbyte *init_ptr = init_str;
2149 case 6: *ptr++ = *init_ptr++;
2150 case 5: *ptr++ = *init_ptr++;
2152 case 4: *ptr++ = *init_ptr++;
2153 case 3: *ptr++ = *init_ptr++;
2154 case 2: *ptr++ = *init_ptr++;
2155 case 1: *ptr++ = *init_ptr++;
2163 DEFUN ("string", Fstring, 0, MANY, 0, /*
2164 Concatenate all the argument characters and make the result a string.
2166 (int nargs, Lisp_Object *args))
2168 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2169 Bufbyte *p = storage;
2171 for (; nargs; nargs--, args++)
2173 Lisp_Object lisp_char = *args;
2174 CHECK_CHAR_COERCE_INT (lisp_char);
2175 p += set_charptr_emchar (p, XCHAR (lisp_char));
2177 return make_string (storage, p - storage);
2181 /* Take some raw memory, which MUST already be in internal format,
2182 and package it up into a Lisp string. */
2184 make_string (const Bufbyte *contents, Bytecount length)
2188 /* Make sure we find out about bad make_string's when they happen */
2189 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2190 bytecount_to_charcount (contents, length); /* Just for the assertions */
2193 val = make_uninit_string (length);
2194 memcpy (XSTRING_DATA (val), contents, length);
2198 /* Take some raw memory, encoded in some external data format,
2199 and convert it into a Lisp string. */
2201 make_ext_string (const Extbyte *contents, EMACS_INT length,
2202 Lisp_Object coding_system)
2205 TO_INTERNAL_FORMAT (DATA, (contents, length),
2206 LISP_STRING, string,
2212 build_string (const char *str)
2214 /* Some strlen's crash and burn if passed null. */
2215 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2219 build_ext_string (const char *str, Lisp_Object coding_system)
2221 /* Some strlen's crash and burn if passed null. */
2222 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2227 build_translated_string (const char *str)
2229 return build_string (GETTEXT (str));
2233 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2238 /* Make sure we find out about bad make_string_nocopy's when they happen */
2239 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2240 bytecount_to_charcount (contents, length); /* Just for the assertions */
2243 /* Allocate the string header */
2244 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2245 set_lheader_implementation (&s->lheader, &lrecord_string);
2246 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2248 set_string_data (s, (Bufbyte *)contents);
2249 set_string_length (s, length);
2251 XSETSTRING (val, s);
2256 /************************************************************************/
2257 /* lcrecord lists */
2258 /************************************************************************/
2260 /* Lcrecord lists are used to manage the allocation of particular
2261 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2262 malloc() and garbage-collection junk) as much as possible.
2263 It is similar to the Blocktype class.
2267 1) Create an lcrecord-list object using make_lcrecord_list().
2268 This is often done at initialization. Remember to staticpro_nodump
2269 this object! The arguments to make_lcrecord_list() are the
2270 same as would be passed to alloc_lcrecord().
2271 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2272 and pass the lcrecord-list earlier created.
2273 3) When done with the lcrecord, call free_managed_lcrecord().
2274 The standard freeing caveats apply: ** make sure there are no
2275 pointers to the object anywhere! **
2276 4) Calling free_managed_lcrecord() is just like kissing the
2277 lcrecord goodbye as if it were garbage-collected. This means:
2278 -- the contents of the freed lcrecord are undefined, and the
2279 contents of something produced by allocate_managed_lcrecord()
2280 are undefined, just like for alloc_lcrecord().
2281 -- the mark method for the lcrecord's type will *NEVER* be called
2283 -- the finalize method for the lcrecord's type will be called
2284 at the time that free_managed_lcrecord() is called.
2289 mark_lcrecord_list (Lisp_Object obj)
2291 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2292 Lisp_Object chain = list->free;
2294 while (!NILP (chain))
2296 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2297 struct free_lcrecord_header *free_header =
2298 (struct free_lcrecord_header *) lheader;
2301 (/* There should be no other pointers to the free list. */
2302 ! MARKED_RECORD_HEADER_P (lheader)
2304 /* Only lcrecords should be here. */
2305 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2307 /* Only free lcrecords should be here. */
2308 free_header->lcheader.free
2310 /* The type of the lcrecord must be right. */
2311 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2313 /* So must the size. */
2314 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2315 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2318 MARK_RECORD_HEADER (lheader);
2319 chain = free_header->chain;
2325 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2326 mark_lcrecord_list, internal_object_printer,
2327 0, 0, 0, 0, struct lcrecord_list);
2329 make_lcrecord_list (size_t size,
2330 const struct lrecord_implementation *implementation)
2332 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2333 &lrecord_lcrecord_list);
2336 p->implementation = implementation;
2339 XSETLCRECORD_LIST (val, p);
2344 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2346 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2347 if (!NILP (list->free))
2349 Lisp_Object val = list->free;
2350 struct free_lcrecord_header *free_header =
2351 (struct free_lcrecord_header *) XPNTR (val);
2353 #ifdef ERROR_CHECK_GC
2354 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2356 /* There should be no other pointers to the free list. */
2357 assert (! MARKED_RECORD_HEADER_P (lheader));
2358 /* Only lcrecords should be here. */
2359 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2360 /* Only free lcrecords should be here. */
2361 assert (free_header->lcheader.free);
2362 /* The type of the lcrecord must be right. */
2363 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2364 /* So must the size. */
2365 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2366 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2367 #endif /* ERROR_CHECK_GC */
2369 list->free = free_header->chain;
2370 free_header->lcheader.free = 0;
2377 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2383 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2385 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2386 struct free_lcrecord_header *free_header =
2387 (struct free_lcrecord_header *) XPNTR (lcrecord);
2388 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2389 const struct lrecord_implementation *implementation
2390 = LHEADER_IMPLEMENTATION (lheader);
2392 /* Make sure the size is correct. This will catch, for example,
2393 putting a window configuration on the wrong free list. */
2394 gc_checking_assert ((implementation->size_in_bytes_method ?
2395 implementation->size_in_bytes_method (lheader) :
2396 implementation->static_size)
2399 if (implementation->finalizer)
2400 implementation->finalizer (lheader, 0);
2401 free_header->chain = list->free;
2402 free_header->lcheader.free = 1;
2403 list->free = lcrecord;
2409 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2410 Kept for compatibility, returns its argument.
2412 Make a copy of OBJECT in pure storage.
2413 Recursively copies contents of vectors and cons cells.
2414 Does not copy symbols.
2422 /************************************************************************/
2423 /* Garbage Collection */
2424 /************************************************************************/
2426 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2427 Additional ones may be defined by a module (none yet). We leave some
2428 room in `lrecord_implementations_table' for such new lisp object types. */
2429 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2430 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2431 /* Object marker functions are in the lrecord_implementation structure.
2432 But copying them to a parallel array is much more cache-friendly.
2433 This hack speeds up (garbage-collect) by about 5%. */
2434 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2436 struct gcpro *gcprolist;
2438 /* We want the staticpros relocated, but not the pointers found therein.
2439 Hence we use a trivial description, as for pointerless objects. */
2440 static const struct lrecord_description staticpro_description_1[] = {
2444 static const struct struct_description staticpro_description = {
2445 sizeof (Lisp_Object *),
2446 staticpro_description_1
2449 static const struct lrecord_description staticpros_description_1[] = {
2450 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
2454 static const struct struct_description staticpros_description = {
2455 sizeof (Lisp_Object_ptr_dynarr),
2456 staticpros_description_1
2459 Lisp_Object_ptr_dynarr *staticpros;
2461 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2462 garbage collection, and for dumping. */
2464 staticpro (Lisp_Object *varaddress)
2466 Dynarr_add (staticpros, varaddress);
2467 dump_add_root_object (varaddress);
2471 Lisp_Object_ptr_dynarr *staticpros_nodump;
2473 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2474 garbage collection, but not for dumping. */
2476 staticpro_nodump (Lisp_Object *varaddress)
2478 Dynarr_add (staticpros_nodump, varaddress);
2481 #ifdef ERROR_CHECK_GC
2482 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2483 struct lrecord_header * GCLI_lh = (lheader); \
2484 assert (GCLI_lh != 0); \
2485 assert (GCLI_lh->type < lrecord_type_count); \
2486 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2487 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2488 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2491 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2495 /* Mark reference to a Lisp_Object. If the object referred to has not been
2496 seen yet, recursively mark all the references contained in it. */
2499 mark_object (Lisp_Object obj)
2503 /* Checks we used to perform */
2504 /* if (EQ (obj, Qnull_pointer)) return; */
2505 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2506 /* if (PURIFIED (XPNTR (obj))) return; */
2508 if (XTYPE (obj) == Lisp_Type_Record)
2510 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2512 GC_CHECK_LHEADER_INVARIANTS (lheader);
2514 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2515 ! ((struct lcrecord_header *) lheader)->free);
2517 /* All c_readonly objects have their mark bit set,
2518 so that we only need to check the mark bit here. */
2519 if ( (!MARKED_RECORD_HEADER_P (lheader))
2521 && (!OLDER_RECORD_HEADER_P (lheader))
2525 MARK_RECORD_HEADER (lheader);
2527 if (RECORD_MARKER (lheader))
2529 obj = RECORD_MARKER (lheader) (obj);
2530 if (!NILP (obj)) goto tail_recurse;
2536 /* mark all of the conses in a list and mark the final cdr; but
2537 DO NOT mark the cars.
2539 Use only for internal lists! There should never be other pointers
2540 to the cons cells, because if so, the cars will remain unmarked
2541 even when they maybe should be marked. */
2543 mark_conses_in_list (Lisp_Object obj)
2547 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2549 if (CONS_MARKED_P (XCONS (rest)))
2551 MARK_CONS (XCONS (rest));
2558 /* Find all structures not marked, and free them. */
2560 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2561 static int gc_count_bit_vector_storage;
2562 static int gc_count_num_short_string_in_use;
2563 static int gc_count_string_total_size;
2564 static int gc_count_short_string_total_size;
2566 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2569 /* stats on lcrecords in use - kinda kludgy */
2573 int instances_in_use;
2575 int instances_freed;
2577 int instances_on_free_list;
2578 } lcrecord_stats [countof (lrecord_implementations_table)];
2581 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2583 unsigned int type_index = h->type;
2585 if (((struct lcrecord_header *) h)->free)
2587 gc_checking_assert (!free_p);
2588 lcrecord_stats[type_index].instances_on_free_list++;
2592 const struct lrecord_implementation *implementation =
2593 LHEADER_IMPLEMENTATION (h);
2595 size_t sz = (implementation->size_in_bytes_method ?
2596 implementation->size_in_bytes_method (h) :
2597 implementation->static_size);
2600 lcrecord_stats[type_index].instances_freed++;
2601 lcrecord_stats[type_index].bytes_freed += sz;
2605 lcrecord_stats[type_index].instances_in_use++;
2606 lcrecord_stats[type_index].bytes_in_use += sz;
2612 /* Free all unmarked records */
2614 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2616 struct lcrecord_header *header;
2618 /* int total_size = 0; */
2620 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2622 /* First go through and call all the finalize methods.
2623 Then go through and free the objects. There used to
2624 be only one loop here, with the call to the finalizer
2625 occurring directly before the xfree() below. That
2626 is marginally faster but much less safe -- if the
2627 finalize method for an object needs to reference any
2628 other objects contained within it (and many do),
2629 we could easily be screwed by having already freed that
2632 for (header = *prev; header; header = header->next)
2634 struct lrecord_header *h = &(header->lheader);
2636 GC_CHECK_LHEADER_INVARIANTS (h);
2638 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2640 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2641 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2645 for (header = *prev; header; )
2647 struct lrecord_header *h = &(header->lheader);
2648 if (MARKED_RECORD_HEADER_P (h))
2650 if (! C_READONLY_RECORD_HEADER_P (h))
2651 UNMARK_RECORD_HEADER (h);
2653 /* total_size += n->implementation->size_in_bytes (h);*/
2654 /* #### May modify header->next on a C_READONLY lcrecord */
2655 prev = &(header->next);
2657 tick_lcrecord_stats (h, 0);
2661 struct lcrecord_header *next = header->next;
2663 tick_lcrecord_stats (h, 1);
2664 /* used to call finalizer right here. */
2670 /* *total = total_size; */
2675 sweep_bit_vectors_1 (Lisp_Object *prev,
2676 int *used, int *total, int *storage)
2678 Lisp_Object bit_vector;
2681 int total_storage = 0;
2683 /* BIT_VECTORP fails because the objects are marked, which changes
2684 their implementation */
2685 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2687 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2689 if (MARKED_RECORD_P (bit_vector))
2691 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2692 UNMARK_RECORD_HEADER (&(v->lheader));
2696 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2697 BIT_VECTOR_LONG_STORAGE (len));
2699 /* #### May modify next on a C_READONLY bitvector */
2700 prev = &(bit_vector_next (v));
2705 Lisp_Object next = bit_vector_next (v);
2712 *total = total_size;
2713 *storage = total_storage;
2716 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2717 to make macros prettier. */
2719 #ifdef ERROR_CHECK_GC
2721 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2723 struct typename##_block *SFTB_current; \
2725 int num_free = 0, num_used = 0; \
2727 for (SFTB_current = current_##typename##_block, \
2728 SFTB_limit = current_##typename##_block_index; \
2734 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2736 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2738 if (LRECORD_FREE_P (SFTB_victim)) \
2742 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2746 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2749 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2754 UNMARK_##typename (SFTB_victim); \
2757 SFTB_current = SFTB_current->prev; \
2758 SFTB_limit = countof (current_##typename##_block->block); \
2761 gc_count_num_##typename##_in_use = num_used; \
2762 gc_count_num_##typename##_freelist = num_free; \
2765 #else /* !ERROR_CHECK_GC */
2767 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2769 struct typename##_block *SFTB_current; \
2770 struct typename##_block **SFTB_prev; \
2772 int num_free = 0, num_used = 0; \
2774 typename##_free_list = 0; \
2776 for (SFTB_prev = ¤t_##typename##_block, \
2777 SFTB_current = current_##typename##_block, \
2778 SFTB_limit = current_##typename##_block_index; \
2783 int SFTB_empty = 1; \
2784 Lisp_Free *SFTB_old_free_list = typename##_free_list; \
2786 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2788 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2790 if (LRECORD_FREE_P (SFTB_victim)) \
2793 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2795 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2800 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2803 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2809 UNMARK_##typename (SFTB_victim); \
2814 SFTB_prev = &(SFTB_current->prev); \
2815 SFTB_current = SFTB_current->prev; \
2817 else if (SFTB_current == current_##typename##_block \
2818 && !SFTB_current->prev) \
2820 /* No real point in freeing sole allocation block */ \
2825 struct typename##_block *SFTB_victim_block = SFTB_current; \
2826 if (SFTB_victim_block == current_##typename##_block) \
2827 current_##typename##_block_index \
2828 = countof (current_##typename##_block->block); \
2829 SFTB_current = SFTB_current->prev; \
2831 *SFTB_prev = SFTB_current; \
2832 xfree (SFTB_victim_block); \
2833 /* Restore free list to what it was before victim was swept */ \
2834 typename##_free_list = SFTB_old_free_list; \
2835 num_free -= SFTB_limit; \
2838 SFTB_limit = countof (current_##typename##_block->block); \
2841 gc_count_num_##typename##_in_use = num_used; \
2842 gc_count_num_##typename##_freelist = num_free; \
2845 #endif /* !ERROR_CHECK_GC */
2853 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2854 #define ADDITIONAL_FREE_cons(ptr)
2856 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2859 /* Explicitly free a cons cell. */
2861 free_cons (Lisp_Cons *ptr)
2863 #ifdef ERROR_CHECK_GC
2864 /* If the CAR is not an int, then it will be a pointer, which will
2865 always be four-byte aligned. If this cons cell has already been
2866 placed on the free list, however, its car will probably contain
2867 a chain pointer to the next cons on the list, which has cleverly
2868 had all its 0's and 1's inverted. This allows for a quick
2869 check to make sure we're not freeing something already freed. */
2870 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2871 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2872 #endif /* ERROR_CHECK_GC */
2874 #ifndef ALLOC_NO_POOLS
2875 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2876 #endif /* ALLOC_NO_POOLS */
2879 /* explicitly free a list. You **must make sure** that you have
2880 created all the cons cells that make up this list and that there
2881 are no pointers to any of these cons cells anywhere else. If there
2882 are, you will lose. */
2885 free_list (Lisp_Object list)
2887 Lisp_Object rest, next;
2889 for (rest = list; !NILP (rest); rest = next)
2892 free_cons (XCONS (rest));
2896 /* explicitly free an alist. You **must make sure** that you have
2897 created all the cons cells that make up this alist and that there
2898 are no pointers to any of these cons cells anywhere else. If there
2899 are, you will lose. */
2902 free_alist (Lisp_Object alist)
2904 Lisp_Object rest, next;
2906 for (rest = alist; !NILP (rest); rest = next)
2909 free_cons (XCONS (XCAR (rest)));
2910 free_cons (XCONS (rest));
2915 sweep_compiled_functions (void)
2917 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2918 #define ADDITIONAL_FREE_compiled_function(ptr)
2920 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2924 #ifdef LISP_FLOAT_TYPE
2928 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2929 #define ADDITIONAL_FREE_float(ptr)
2931 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2933 #endif /* LISP_FLOAT_TYPE */
2936 sweep_symbols (void)
2938 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2939 #define ADDITIONAL_FREE_symbol(ptr)
2941 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2945 sweep_extents (void)
2947 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2948 #define ADDITIONAL_FREE_extent(ptr)
2950 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2956 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2957 #define ADDITIONAL_FREE_event(ptr)
2959 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2963 sweep_markers (void)
2965 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2966 #define ADDITIONAL_FREE_marker(ptr) \
2967 do { Lisp_Object tem; \
2968 XSETMARKER (tem, ptr); \
2969 unchain_marker (tem); \
2972 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2975 /* Explicitly free a marker. */
2977 free_marker (Lisp_Marker *ptr)
2979 /* Perhaps this will catch freeing an already-freed marker. */
2980 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
2982 #ifndef ALLOC_NO_POOLS
2983 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2984 #endif /* ALLOC_NO_POOLS */
2988 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2991 verify_string_chars_integrity (void)
2993 struct string_chars_block *sb;
2995 /* Scan each existing string block sequentially, string by string. */
2996 for (sb = first_string_chars_block; sb; sb = sb->next)
2999 /* POS is the index of the next string in the block. */
3000 while (pos < sb->pos)
3002 struct string_chars *s_chars =
3003 (struct string_chars *) &(sb->string_chars[pos]);
3004 Lisp_String *string;
3008 /* If the string_chars struct is marked as free (i.e. the
3009 STRING pointer is NULL) then this is an unused chunk of
3010 string storage. (See below.) */
3012 if (STRING_CHARS_FREE_P (s_chars))
3014 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3019 string = s_chars->string;
3020 /* Must be 32-bit aligned. */
3021 assert ((((int) string) & 3) == 0);
3023 size = string_length (string);
3024 fullsize = STRING_FULLSIZE (size);
3026 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3027 assert (string_data (string) == s_chars->chars);
3030 assert (pos == sb->pos);
3034 #endif /* MULE && ERROR_CHECK_GC */
3036 /* Compactify string chars, relocating the reference to each --
3037 free any empty string_chars_block we see. */
3039 compact_string_chars (void)
3041 struct string_chars_block *to_sb = first_string_chars_block;
3043 struct string_chars_block *from_sb;
3045 /* Scan each existing string block sequentially, string by string. */
3046 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3049 /* FROM_POS is the index of the next string in the block. */
3050 while (from_pos < from_sb->pos)
3052 struct string_chars *from_s_chars =
3053 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3054 struct string_chars *to_s_chars;
3055 Lisp_String *string;
3059 /* If the string_chars struct is marked as free (i.e. the
3060 STRING pointer is NULL) then this is an unused chunk of
3061 string storage. This happens under Mule when a string's
3062 size changes in such a way that its fullsize changes.
3063 (Strings can change size because a different-length
3064 character can be substituted for another character.)
3065 In this case, after the bogus string pointer is the
3066 "fullsize" of this entry, i.e. how many bytes to skip. */
3068 if (STRING_CHARS_FREE_P (from_s_chars))
3070 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3071 from_pos += fullsize;
3075 string = from_s_chars->string;
3076 assert (!(LRECORD_FREE_P (string)));
3078 size = string_length (string);
3079 fullsize = STRING_FULLSIZE (size);
3081 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3083 /* Just skip it if it isn't marked. */
3084 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3086 from_pos += fullsize;
3090 /* If it won't fit in what's left of TO_SB, close TO_SB out
3091 and go on to the next string_chars_block. We know that TO_SB
3092 cannot advance past FROM_SB here since FROM_SB is large enough
3093 to currently contain this string. */
3094 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3096 to_sb->pos = to_pos;
3097 to_sb = to_sb->next;
3101 /* Compute new address of this string
3102 and update TO_POS for the space being used. */
3103 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3105 /* Copy the string_chars to the new place. */
3106 if (from_s_chars != to_s_chars)
3107 memmove (to_s_chars, from_s_chars, fullsize);
3109 /* Relocate FROM_S_CHARS's reference */
3110 set_string_data (string, &(to_s_chars->chars[0]));
3112 from_pos += fullsize;
3117 /* Set current to the last string chars block still used and
3118 free any that follow. */
3120 struct string_chars_block *victim;
3122 for (victim = to_sb->next; victim; )
3124 struct string_chars_block *next = victim->next;
3129 current_string_chars_block = to_sb;
3130 current_string_chars_block->pos = to_pos;
3131 current_string_chars_block->next = 0;
3135 #if 1 /* Hack to debug missing purecopy's */
3136 static int debug_string_purity;
3139 debug_string_purity_print (Lisp_String *p)
3142 Charcount s = string_char_length (p);
3144 for (i = 0; i < s; i++)
3146 Emchar ch = string_char (p, i);
3147 if (ch < 32 || ch >= 126)
3148 stderr_out ("\\%03o", ch);
3149 else if (ch == '\\' || ch == '\"')
3150 stderr_out ("\\%c", ch);
3152 stderr_out ("%c", ch);
3154 stderr_out ("\"\n");
3160 sweep_strings (void)
3162 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3163 int debug = debug_string_purity;
3165 #define UNMARK_string(ptr) do { \
3166 Lisp_String *p = (ptr); \
3167 size_t size = string_length (p); \
3168 UNMARK_RECORD_HEADER (&(p->lheader)); \
3169 num_bytes += size; \
3170 if (!BIG_STRING_SIZE_P (size)) \
3172 num_small_bytes += size; \
3176 debug_string_purity_print (p); \
3178 #define ADDITIONAL_FREE_string(ptr) do { \
3179 size_t size = string_length (ptr); \
3180 if (BIG_STRING_SIZE_P (size)) \
3181 xfree (ptr->data); \
3184 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3186 gc_count_num_short_string_in_use = num_small_used;
3187 gc_count_string_total_size = num_bytes;
3188 gc_count_short_string_total_size = num_small_bytes;
3192 /* I hate duplicating all this crap! */
3194 marked_p (Lisp_Object obj)
3196 /* Checks we used to perform. */
3197 /* if (EQ (obj, Qnull_pointer)) return 1; */
3198 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3199 /* if (PURIFIED (XPNTR (obj))) return 1; */
3201 if (XTYPE (obj) == Lisp_Type_Record)
3203 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3205 GC_CHECK_LHEADER_INVARIANTS (lheader);
3207 return MARKED_RECORD_HEADER_P (lheader);
3215 /* Free all unmarked records. Do this at the very beginning,
3216 before anything else, so that the finalize methods can safely
3217 examine items in the objects. sweep_lcrecords_1() makes
3218 sure to call all the finalize methods *before* freeing anything,
3219 to complete the safety. */
3222 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3225 compact_string_chars ();
3227 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3228 macros) must be *extremely* careful to make sure they're not
3229 referencing freed objects. The only two existing finalize
3230 methods (for strings and markers) pass muster -- the string
3231 finalizer doesn't look at anything but its own specially-
3232 created block, and the marker finalizer only looks at live
3233 buffers (which will never be freed) and at the markers before
3234 and after it in the chain (which, by induction, will never be
3235 freed because if so, they would have already removed themselves
3238 /* Put all unmarked strings on free list, free'ing the string chars
3239 of large unmarked strings */
3242 /* Put all unmarked conses on free list */
3245 /* Free all unmarked bit vectors */
3246 sweep_bit_vectors_1 (&all_bit_vectors,
3247 &gc_count_num_bit_vector_used,
3248 &gc_count_bit_vector_total_size,
3249 &gc_count_bit_vector_storage);
3251 /* Free all unmarked compiled-function objects */
3252 sweep_compiled_functions ();
3254 #ifdef LISP_FLOAT_TYPE
3255 /* Put all unmarked floats on free list */
3259 /* Put all unmarked symbols on free list */
3262 /* Put all unmarked extents on free list */
3265 /* Put all unmarked markers on free list.
3266 Dechain each one first from the buffer into which it points. */
3272 pdump_objects_unmark ();
3276 /* Clearing for disksave. */
3279 disksave_object_finalization (void)
3281 /* It's important that certain information from the environment not get
3282 dumped with the executable (pathnames, environment variables, etc.).
3283 To make it easier to tell when this has happened with strings(1) we
3284 clear some known-to-be-garbage blocks of memory, so that leftover
3285 results of old evaluation don't look like potential problems.
3286 But first we set some notable variables to nil and do one more GC,
3287 to turn those strings into garbage.
3290 /* Yeah, this list is pretty ad-hoc... */
3291 Vprocess_environment = Qnil;
3292 Vexec_directory = Qnil;
3293 Vdata_directory = Qnil;
3294 Vsite_directory = Qnil;
3295 Vdoc_directory = Qnil;
3296 Vconfigure_info_directory = Qnil;
3299 /* Vdump_load_path = Qnil; */
3300 /* Release hash tables for locate_file */
3301 Flocate_file_clear_hashing (Qt);
3302 uncache_home_directory();
3304 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3305 defined(LOADHIST_BUILTIN))
3306 Vload_history = Qnil;
3308 Vshell_file_name = Qnil;
3310 garbage_collect_1 ();
3312 /* Run the disksave finalization methods of all live objects. */
3313 disksave_object_finalization_1 ();
3315 /* Zero out the uninitialized (really, unused) part of the containers
3316 for the live strings. */
3318 struct string_chars_block *scb;
3319 for (scb = first_string_chars_block; scb; scb = scb->next)
3321 int count = sizeof (scb->string_chars) - scb->pos;
3323 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3326 /* from the block's fill ptr to the end */
3327 memset ((scb->string_chars + scb->pos), 0, count);
3332 /* There, that ought to be enough... */
3338 restore_gc_inhibit (Lisp_Object val)
3340 gc_currently_forbidden = XINT (val);
3344 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3345 static int gc_hooks_inhibited;
3349 garbage_collect_1 (void)
3351 #if MAX_SAVE_STACK > 0
3352 char stack_top_variable;
3353 extern char *stack_bottom;
3358 Lisp_Object pre_gc_cursor;
3359 struct gcpro gcpro1;
3362 || gc_currently_forbidden
3364 || preparing_for_armageddon)
3367 /* We used to call selected_frame() here.
3369 The following functions cannot be called inside GC
3370 so we move to after the above tests. */
3373 Lisp_Object device = Fselected_device (Qnil);
3374 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3376 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3378 signal_simple_error ("No frames exist on device", device);
3382 pre_gc_cursor = Qnil;
3385 GCPRO1 (pre_gc_cursor);
3387 /* Very important to prevent GC during any of the following
3388 stuff that might run Lisp code; otherwise, we'll likely
3389 have infinite GC recursion. */
3390 speccount = specpdl_depth ();
3391 record_unwind_protect (restore_gc_inhibit,
3392 make_int (gc_currently_forbidden));
3393 gc_currently_forbidden = 1;
3395 if (!gc_hooks_inhibited)
3396 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3398 /* Now show the GC cursor/message. */
3399 if (!noninteractive)
3401 if (FRAME_WIN_P (f))
3403 Lisp_Object frame = make_frame (f);
3404 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3405 FRAME_SELECTED_WINDOW (f),
3407 pre_gc_cursor = f->pointer;
3408 if (POINTER_IMAGE_INSTANCEP (cursor)
3409 /* don't change if we don't know how to change back. */
3410 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3413 Fset_frame_pointer (frame, cursor);
3417 /* Don't print messages to the stream device. */
3418 if (!cursor_changed && !FRAME_STREAM_P (f))
3420 char *msg = (STRINGP (Vgc_message)
3421 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3423 Lisp_Object args[2], whole_msg;
3424 args[0] = build_string (msg ? msg :
3425 GETTEXT ((const char *) gc_default_message));
3426 args[1] = build_string ("...");
3427 whole_msg = Fconcat (2, args);
3428 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3429 Qgarbage_collecting);
3433 /***** Now we actually start the garbage collection. */
3437 gc_generation_number[0]++;
3439 #if MAX_SAVE_STACK > 0
3441 /* Save a copy of the contents of the stack, for debugging. */
3444 /* Static buffer in which we save a copy of the C stack at each GC. */
3445 static char *stack_copy;
3446 static size_t stack_copy_size;
3448 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3449 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3450 if (stack_size < MAX_SAVE_STACK)
3452 if (stack_copy_size < stack_size)
3454 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3455 stack_copy_size = stack_size;
3459 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3463 #endif /* MAX_SAVE_STACK > 0 */
3465 /* Do some totally ad-hoc resource clearing. */
3466 /* #### generalize this? */
3467 clear_event_resource ();
3468 cleanup_specifiers ();
3470 /* Mark all the special slots that serve as the roots of accessibility. */
3473 Lisp_Object **p = Dynarr_begin (staticpros);
3475 for (count = Dynarr_length (staticpros); count; count--)
3476 mark_object (**p++);
3479 { /* staticpro_nodump() */
3480 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
3482 for (count = Dynarr_length (staticpros_nodump); count; count--)
3483 mark_object (**p++);
3489 for (tail = gcprolist; tail; tail = tail->next)
3490 for (i = 0; i < tail->nvars; i++)
3491 mark_object (tail->var[i]);
3495 struct specbinding *bind;
3496 for (bind = specpdl; bind != specpdl_ptr; bind++)
3498 mark_object (bind->symbol);
3499 mark_object (bind->old_value);
3504 struct catchtag *catch;
3505 for (catch = catchlist; catch; catch = catch->next)
3507 mark_object (catch->tag);
3508 mark_object (catch->val);
3513 struct backtrace *backlist;
3514 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3516 int nargs = backlist->nargs;
3519 mark_object (*backlist->function);
3520 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
3521 mark_object (backlist->args[0]);
3523 for (i = 0; i < nargs; i++)
3524 mark_object (backlist->args[i]);
3529 mark_profiling_info ();
3531 /* OK, now do the after-mark stuff. This is for things that
3532 are only marked when something else is marked (e.g. weak hash tables).
3533 There may be complex dependencies between such objects -- e.g.
3534 a weak hash table might be unmarked, but after processing a later
3535 weak hash table, the former one might get marked. So we have to
3536 iterate until nothing more gets marked. */
3538 while (finish_marking_weak_hash_tables () > 0 ||
3539 finish_marking_weak_lists () > 0)
3542 /* And prune (this needs to be called after everything else has been
3543 marked and before we do any sweeping). */
3544 /* #### this is somewhat ad-hoc and should probably be an object
3546 prune_weak_hash_tables ();
3547 prune_weak_lists ();
3548 prune_specifiers ();
3549 prune_syntax_tables ();
3553 consing_since_gc = 0;
3554 #ifndef DEBUG_XEMACS
3555 /* Allow you to set it really fucking low if you really want ... */
3556 if (gc_cons_threshold < 10000)
3557 gc_cons_threshold = 10000;
3562 /******* End of garbage collection ********/
3564 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3566 /* Now remove the GC cursor/message */
3567 if (!noninteractive)
3570 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3571 else if (!FRAME_STREAM_P (f))
3573 char *msg = (STRINGP (Vgc_message)
3574 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3577 /* Show "...done" only if the echo area would otherwise be empty. */
3578 if (NILP (clear_echo_area (selected_frame (),
3579 Qgarbage_collecting, 0)))
3581 Lisp_Object args[2], whole_msg;
3582 args[0] = build_string (msg ? msg :
3583 GETTEXT ((const char *)
3584 gc_default_message));
3585 args[1] = build_string ("... done");
3586 whole_msg = Fconcat (2, args);
3587 echo_area_message (selected_frame (), (Bufbyte *) 0,
3589 Qgarbage_collecting);
3594 /* now stop inhibiting GC */
3595 unbind_to (speccount, Qnil);
3597 if (!breathing_space)
3599 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3606 /* Debugging aids. */
3609 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3611 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3612 or portable numeric datatypes, or bit-vectors, or characters, or
3613 arrays, or exceptions, or ...) */
3614 return cons3 (intern (name), make_int (value), tail);
3617 #define HACK_O_MATIC(type, name, pl) do { \
3619 struct type##_block *x = current_##type##_block; \
3620 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3621 (pl) = gc_plist_hack ((name), s, (pl)); \
3624 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3625 Reclaim storage for Lisp objects no longer needed.
3626 Return info on amount of space in use:
3627 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3628 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3630 where `PLIST' is a list of alternating keyword/value pairs providing
3631 more detailed information.
3632 Garbage collection happens automatically if you cons more than
3633 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3637 Lisp_Object pl = Qnil;
3639 int gc_count_vector_total_size = 0;
3641 garbage_collect_1 ();
3643 for (i = 0; i < lrecord_type_count; i++)
3645 if (lcrecord_stats[i].bytes_in_use != 0
3646 || lcrecord_stats[i].bytes_freed != 0
3647 || lcrecord_stats[i].instances_on_free_list != 0)
3650 const char *name = lrecord_implementations_table[i]->name;
3651 int len = strlen (name);
3652 /* save this for the FSFmacs-compatible part of the summary */
3653 if (i == lrecord_vector.lrecord_type_index)
3654 gc_count_vector_total_size =
3655 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3657 sprintf (buf, "%s-storage", name);
3658 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3659 /* Okay, simple pluralization check for `symbol-value-varalias' */
3660 if (name[len-1] == 's')
3661 sprintf (buf, "%ses-freed", name);
3663 sprintf (buf, "%ss-freed", name);
3664 if (lcrecord_stats[i].instances_freed != 0)
3665 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3666 if (name[len-1] == 's')
3667 sprintf (buf, "%ses-on-free-list", name);
3669 sprintf (buf, "%ss-on-free-list", name);
3670 if (lcrecord_stats[i].instances_on_free_list != 0)
3671 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3673 if (name[len-1] == 's')
3674 sprintf (buf, "%ses-used", name);
3676 sprintf (buf, "%ss-used", name);
3677 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3681 HACK_O_MATIC (extent, "extent-storage", pl);
3682 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3683 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3684 HACK_O_MATIC (event, "event-storage", pl);
3685 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3686 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3687 HACK_O_MATIC (marker, "marker-storage", pl);
3688 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3689 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3690 #ifdef LISP_FLOAT_TYPE
3691 HACK_O_MATIC (float, "float-storage", pl);
3692 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3693 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3694 #endif /* LISP_FLOAT_TYPE */
3695 HACK_O_MATIC (string, "string-header-storage", pl);
3696 pl = gc_plist_hack ("long-strings-total-length",
3697 gc_count_string_total_size
3698 - gc_count_short_string_total_size, pl);
3699 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3700 pl = gc_plist_hack ("short-strings-total-length",
3701 gc_count_short_string_total_size, pl);
3702 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3703 pl = gc_plist_hack ("long-strings-used",
3704 gc_count_num_string_in_use
3705 - gc_count_num_short_string_in_use, pl);
3706 pl = gc_plist_hack ("short-strings-used",
3707 gc_count_num_short_string_in_use, pl);
3709 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3710 pl = gc_plist_hack ("compiled-functions-free",
3711 gc_count_num_compiled_function_freelist, pl);
3712 pl = gc_plist_hack ("compiled-functions-used",
3713 gc_count_num_compiled_function_in_use, pl);
3715 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3716 pl = gc_plist_hack ("bit-vectors-total-length",
3717 gc_count_bit_vector_total_size, pl);
3718 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3720 HACK_O_MATIC (symbol, "symbol-storage", pl);
3721 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3722 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3724 HACK_O_MATIC (cons, "cons-storage", pl);
3725 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3726 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3728 /* The things we do for backwards-compatibility */
3730 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3731 make_int (gc_count_num_cons_freelist)),
3732 Fcons (make_int (gc_count_num_symbol_in_use),
3733 make_int (gc_count_num_symbol_freelist)),
3734 Fcons (make_int (gc_count_num_marker_in_use),
3735 make_int (gc_count_num_marker_freelist)),
3736 make_int (gc_count_string_total_size),
3737 make_int (gc_count_vector_total_size),
3742 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3743 Return the number of bytes consed since the last garbage collection.
3744 \"Consed\" is a misnomer in that this actually counts allocation
3745 of all different kinds of objects, not just conses.
3747 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3751 return make_int (consing_since_gc);
3755 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
3756 Return the address of the last byte Emacs has allocated, divided by 1024.
3757 This may be helpful in debugging Emacs's memory usage.
3758 The value is divided by 1024 to make sure it will fit in a lisp integer.
3762 return make_int ((EMACS_INT) sbrk (0) / 1024);
3768 object_dead_p (Lisp_Object obj)
3770 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3771 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3772 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3773 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3774 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3775 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3776 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3779 #ifdef MEMORY_USAGE_STATS
3781 /* Attempt to determine the actual amount of space that is used for
3782 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3784 It seems that the following holds:
3786 1. When using the old allocator (malloc.c):
3788 -- blocks are always allocated in chunks of powers of two. For
3789 each block, there is an overhead of 8 bytes if rcheck is not
3790 defined, 20 bytes if it is defined. In other words, a
3791 one-byte allocation needs 8 bytes of overhead for a total of
3792 9 bytes, and needs to have 16 bytes of memory chunked out for
3795 2. When using the new allocator (gmalloc.c):
3797 -- blocks are always allocated in chunks of powers of two up
3798 to 4096 bytes. Larger blocks are allocated in chunks of
3799 an integral multiple of 4096 bytes. The minimum block
3800 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3801 is defined. There is no per-block overhead, but there
3802 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3805 3. When using the system malloc, anything goes, but they are
3806 generally slower and more space-efficient than the GNU
3807 allocators. One possibly reasonable assumption to make
3808 for want of better data is that sizeof (void *), or maybe
3809 2 * sizeof (void *), is required as overhead and that
3810 blocks are allocated in the minimum required size except
3811 that some minimum block size is imposed (e.g. 16 bytes). */
3814 malloced_storage_size (void *ptr, size_t claimed_size,
3815 struct overhead_stats *stats)
3817 size_t orig_claimed_size = claimed_size;
3821 if (claimed_size < 2 * sizeof (void *))
3822 claimed_size = 2 * sizeof (void *);
3823 # ifdef SUNOS_LOCALTIME_BUG
3824 if (claimed_size < 16)
3827 if (claimed_size < 4096)
3831 /* compute the log base two, more or less, then use it to compute
3832 the block size needed. */
3834 /* It's big, it's heavy, it's wood! */
3835 while ((claimed_size /= 2) != 0)
3838 /* It's better than bad, it's good! */
3844 /* We have to come up with some average about the amount of
3846 if ((size_t) (rand () & 4095) < claimed_size)
3847 claimed_size += 3 * sizeof (void *);
3851 claimed_size += 4095;
3852 claimed_size &= ~4095;
3853 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3856 #elif defined (SYSTEM_MALLOC)
3858 if (claimed_size < 16)
3860 claimed_size += 2 * sizeof (void *);
3862 #else /* old GNU allocator */
3864 # ifdef rcheck /* #### may not be defined here */
3872 /* compute the log base two, more or less, then use it to compute
3873 the block size needed. */
3875 /* It's big, it's heavy, it's wood! */
3876 while ((claimed_size /= 2) != 0)
3879 /* It's better than bad, it's good! */
3887 #endif /* old GNU allocator */
3891 stats->was_requested += orig_claimed_size;
3892 stats->malloc_overhead += claimed_size - orig_claimed_size;
3894 return claimed_size;
3898 fixed_type_block_overhead (size_t size)
3900 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3901 size_t overhead = 0;
3902 size_t storage_size = malloced_storage_size (0, per_block, 0);
3903 while (size >= per_block)
3906 overhead += sizeof (void *) + per_block - storage_size;
3908 if (rand () % per_block < size)
3909 overhead += sizeof (void *) + per_block - storage_size;
3913 #endif /* MEMORY_USAGE_STATS */
3916 /* Initialization */
3918 reinit_alloc_once_early (void)
3920 gc_generation_number[0] = 0;
3921 breathing_space = 0;
3922 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3923 XSETINT (Vgc_message, 0);
3926 all_older_lcrecords = 0;
3928 ignore_malloc_warnings = 1;
3929 #ifdef DOUG_LEA_MALLOC
3930 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3931 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3932 #if 0 /* Moved to emacs.c */
3933 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3936 init_string_alloc ();
3937 init_string_chars_alloc ();
3939 init_symbol_alloc ();
3940 init_compiled_function_alloc ();
3941 #ifdef LISP_FLOAT_TYPE
3942 init_float_alloc ();
3943 #endif /* LISP_FLOAT_TYPE */
3944 init_marker_alloc ();
3945 init_extent_alloc ();
3946 init_event_alloc ();
3948 ignore_malloc_warnings = 0;
3950 if (staticpros_nodump)
3951 Dynarr_free (staticpros_nodump);
3952 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3953 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
3955 consing_since_gc = 0;
3957 gc_cons_threshold = 500000; /* XEmacs change */
3959 gc_cons_threshold = 15000; /* debugging */
3961 lrecord_uid_counter = 259;
3962 debug_string_purity = 0;
3965 gc_currently_forbidden = 0;
3966 gc_hooks_inhibited = 0;
3968 #ifdef ERROR_CHECK_TYPECHECK
3969 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3972 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3974 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3976 #endif /* ERROR_CHECK_TYPECHECK */
3980 init_alloc_once_early (void)
3982 reinit_alloc_once_early ();
3986 for (i = 0; i < countof (lrecord_implementations_table); i++)
3987 lrecord_implementations_table[i] = 0;
3990 INIT_LRECORD_IMPLEMENTATION (cons);
3991 INIT_LRECORD_IMPLEMENTATION (vector);
3992 INIT_LRECORD_IMPLEMENTATION (string);
3993 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3995 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3996 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3997 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
4007 syms_of_alloc (void)
4009 DEFSYMBOL (Qpre_gc_hook);
4010 DEFSYMBOL (Qpost_gc_hook);
4011 DEFSYMBOL (Qgarbage_collecting);
4016 DEFSUBR (Fbit_vector);
4017 DEFSUBR (Fmake_byte_code);
4018 DEFSUBR (Fmake_list);
4019 DEFSUBR (Fmake_vector);
4020 DEFSUBR (Fmake_bit_vector);
4021 DEFSUBR (Fmake_string);
4023 DEFSUBR (Fmake_symbol);
4024 DEFSUBR (Fmake_marker);
4025 DEFSUBR (Fpurecopy);
4026 DEFSUBR (Fgarbage_collect);
4028 DEFSUBR (Fmemory_limit);
4030 DEFSUBR (Fconsing_since_gc);
4034 vars_of_alloc (void)
4036 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4037 *Number of bytes of consing between garbage collections.
4038 \"Consing\" is a misnomer in that this actually counts allocation
4039 of all different kinds of objects, not just conses.
4040 Garbage collection can happen automatically once this many bytes have been
4041 allocated since the last garbage collection. All data types count.
4043 Garbage collection happens automatically when `eval' or `funcall' are
4044 called. (Note that `funcall' is called implicitly as part of evaluation.)
4045 By binding this temporarily to a large number, you can effectively
4046 prevent garbage collection during a part of the program.
4048 See also `consing-since-gc'.
4052 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4053 If non-zero, print out information to stderr about all objects allocated.
4054 See also `debug-allocation-backtrace-length'.
4056 debug_allocation = 0;
4058 DEFVAR_INT ("debug-allocation-backtrace-length",
4059 &debug_allocation_backtrace_length /*
4060 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4062 debug_allocation_backtrace_length = 2;
4065 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4066 Non-nil means loading Lisp code in order to dump an executable.
4067 This means that certain objects should be allocated in readonly space.
4070 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4071 Function or functions to be run just before each garbage collection.
4072 Interrupts, garbage collection, and errors are inhibited while this hook
4073 runs, so be extremely careful in what you add here. In particular, avoid
4074 consing, and do not interact with the user.
4076 Vpre_gc_hook = Qnil;
4078 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4079 Function or functions to be run just after each garbage collection.
4080 Interrupts, garbage collection, and errors are inhibited while this hook
4081 runs, so be extremely careful in what you add here. In particular, avoid
4082 consing, and do not interact with the user.
4084 Vpost_gc_hook = Qnil;
4086 DEFVAR_LISP ("gc-message", &Vgc_message /*
4087 String to print to indicate that a garbage collection is in progress.
4088 This is printed in the echo area. If the selected frame is on a
4089 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4090 image instance) in the domain of the selected frame, the mouse pointer
4091 will change instead of this message being printed.
4093 Vgc_message = build_string (gc_default_message);
4095 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4096 Pointer glyph used to indicate that a garbage collection is in progress.
4097 If the selected window is on a window system and this glyph specifies a
4098 value (i.e. a pointer image instance) in the domain of the selected
4099 window, the pointer will be changed as specified during garbage collection.
4100 Otherwise, a message will be printed in the echo area, as controlled
4106 complex_vars_of_alloc (void)
4108 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);